1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2021 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.c, 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
) + 1);
1099 strcpy (fullname
, p
->path
);
1100 strcat (fullname
, name
);
1102 f
= gzopen (fullname
, "r");
1105 if (gfc_cpp_makedep ())
1106 gfc_cpp_add_dep (fullname
, system
);
1108 free (module_fullpath
);
1109 module_fullpath
= xstrdup (fullname
);
1118 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1122 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1124 f
= gzopen (name
, "r");
1127 if (gfc_cpp_makedep ())
1128 gfc_cpp_add_dep (name
, false);
1130 free (module_fullpath
);
1131 module_fullpath
= xstrdup (name
);
1136 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1142 gzopen_intrinsic_module (const char* name
)
1146 if (IS_ABSOLUTE_PATH (name
))
1148 f
= gzopen (name
, "r");
1151 if (gfc_cpp_makedep ())
1152 gfc_cpp_add_dep (name
, true);
1154 free (module_fullpath
);
1155 module_fullpath
= xstrdup (name
);
1160 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1168 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1171 static atom_type last_atom
;
1174 /* The name buffer must be at least as long as a symbol name. Right
1175 now it's not clear how we're going to store numeric constants--
1176 probably as a hexadecimal string, since this will allow the exact
1177 number to be preserved (this can't be done by a decimal
1178 representation). Worry about that later. TODO! */
1180 #define MAX_ATOM_SIZE 100
1182 static HOST_WIDE_INT atom_int
;
1183 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1186 /* Report problems with a module. Error reporting is not very
1187 elaborate, since this sorts of errors shouldn't really happen.
1188 This subroutine never returns. */
1190 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1193 bad_module (const char *msgid
)
1195 XDELETEVEC (module_content
);
1196 module_content
= NULL
;
1201 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1202 module_fullpath
, module_line
, module_column
, msgid
);
1205 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1206 module_name
, module_line
, module_column
, msgid
);
1209 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1210 module_name
, module_line
, module_column
, msgid
);
1216 /* Set the module's input pointer. */
1219 set_module_locus (module_locus
*m
)
1221 module_column
= m
->column
;
1222 module_line
= m
->line
;
1223 module_pos
= m
->pos
;
1227 /* Get the module's input pointer so that we can restore it later. */
1230 get_module_locus (module_locus
*m
)
1232 m
->column
= module_column
;
1233 m
->line
= module_line
;
1234 m
->pos
= module_pos
;
1237 /* Peek at the next character in the module. */
1240 module_peek_char (void)
1242 return module_content
[module_pos
];
1245 /* Get the next character in the module, updating our reckoning of
1251 const char c
= module_content
[module_pos
++];
1253 bad_module ("Unexpected EOF");
1255 prev_module_line
= module_line
;
1256 prev_module_column
= module_column
;
1268 /* Unget a character while remembering the line and column. Works for
1269 a single character only. */
1272 module_unget_char (void)
1274 module_line
= prev_module_line
;
1275 module_column
= prev_module_column
;
1279 /* Parse a string constant. The delimiter is guaranteed to be a
1289 atom_string
= XNEWVEC (char, cursz
);
1297 int c2
= module_char ();
1300 module_unget_char ();
1308 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1310 atom_string
[len
] = c
;
1314 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1315 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1319 /* Parse an integer. Should fit in a HOST_WIDE_INT. */
1322 parse_integer (int c
)
1343 module_unget_char ();
1347 atom_int
= 10 * atom_int
+ c
- '0';
1370 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1372 module_unget_char ();
1377 if (++len
> GFC_MAX_SYMBOL_LEN
)
1378 bad_module ("Name too long");
1386 /* Read the next atom in the module's input stream. */
1397 while (c
== ' ' || c
== '\r' || c
== '\n');
1422 return ATOM_INTEGER
;
1426 if (ISDIGIT (module_peek_char ()))
1429 return ATOM_INTEGER
;
1432 bad_module ("Bad name");
1490 bad_module ("Bad name");
1497 /* Peek at the next atom on the input. */
1508 while (c
== ' ' || c
== '\r' || c
== '\n');
1513 module_unget_char ();
1517 module_unget_char ();
1521 module_unget_char ();
1534 module_unget_char ();
1535 return ATOM_INTEGER
;
1539 if (ISDIGIT (module_peek_char ()))
1541 module_unget_char ();
1542 return ATOM_INTEGER
;
1545 bad_module ("Bad name");
1599 module_unget_char ();
1603 bad_module ("Bad name");
1608 /* Read the next atom from the input, requiring that it be a
1612 require_atom (atom_type type
)
1618 column
= module_column
;
1627 p
= _("Expected name");
1630 p
= _("Expected left parenthesis");
1633 p
= _("Expected right parenthesis");
1636 p
= _("Expected integer");
1639 p
= _("Expected string");
1642 gfc_internal_error ("require_atom(): bad atom type required");
1645 module_column
= column
;
1652 /* Given a pointer to an mstring array, require that the current input
1653 be one of the strings in the array. We return the enum value. */
1656 find_enum (const mstring
*m
)
1660 i
= gfc_string2code (m
, atom_name
);
1664 bad_module ("find_enum(): Enum not found");
1670 /* Read a string. The caller is responsible for freeing. */
1676 require_atom (ATOM_STRING
);
1683 /**************** Module output subroutines ***************************/
1685 /* Output a character to a module file. */
1688 write_char (char out
)
1690 if (gzputc (module_fp
, out
) == EOF
)
1691 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1703 /* Write an atom to a module. The line wrapping isn't perfect, but it
1704 should work most of the time. This isn't that big of a deal, since
1705 the file really isn't meant to be read by people anyway. */
1708 write_atom (atom_type atom
, const void *v
)
1712 /* Workaround -Wmaybe-uninitialized false positive during
1713 profiledbootstrap by initializing them. */
1715 HOST_WIDE_INT i
= 0;
1722 p
= (const char *) v
;
1734 i
= *((const HOST_WIDE_INT
*) v
);
1736 snprintf (buffer
, sizeof (buffer
), HOST_WIDE_INT_PRINT_DEC
, i
);
1741 gfc_internal_error ("write_atom(): Trying to write dab atom");
1745 if(p
== NULL
|| *p
== '\0')
1750 if (atom
!= ATOM_RPAREN
)
1752 if (module_column
+ len
> 72)
1757 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1762 if (atom
== ATOM_STRING
)
1765 while (p
!= NULL
&& *p
)
1767 if (atom
== ATOM_STRING
&& *p
== '\'')
1772 if (atom
== ATOM_STRING
)
1780 /***************** Mid-level I/O subroutines *****************/
1782 /* These subroutines let their caller read or write atoms without
1783 caring about which of the two is actually happening. This lets a
1784 subroutine concentrate on the actual format of the data being
1787 static void mio_expr (gfc_expr
**);
1788 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1789 pointer_info
*mio_interface_rest (gfc_interface
**);
1790 static void mio_symtree_ref (gfc_symtree
**);
1792 /* Read or write an enumerated value. On writing, we return the input
1793 value for the convenience of callers. We avoid using an integer
1794 pointer because enums are sometimes inside bitfields. */
1797 mio_name (int t
, const mstring
*m
)
1799 if (iomode
== IO_OUTPUT
)
1800 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1803 require_atom (ATOM_NAME
);
1810 /* Specialization of mio_name. */
1812 #define DECL_MIO_NAME(TYPE) \
1813 static inline TYPE \
1814 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1816 return (TYPE) mio_name ((int) t, m); \
1818 #define MIO_NAME(TYPE) mio_name_##TYPE
1823 if (iomode
== IO_OUTPUT
)
1824 write_atom (ATOM_LPAREN
, NULL
);
1826 require_atom (ATOM_LPAREN
);
1833 if (iomode
== IO_OUTPUT
)
1834 write_atom (ATOM_RPAREN
, NULL
);
1836 require_atom (ATOM_RPAREN
);
1841 mio_integer (int *ip
)
1843 if (iomode
== IO_OUTPUT
)
1845 HOST_WIDE_INT hwi
= *ip
;
1846 write_atom (ATOM_INTEGER
, &hwi
);
1850 require_atom (ATOM_INTEGER
);
1856 mio_hwi (HOST_WIDE_INT
*hwi
)
1858 if (iomode
== IO_OUTPUT
)
1859 write_atom (ATOM_INTEGER
, hwi
);
1862 require_atom (ATOM_INTEGER
);
1868 /* Read or write a gfc_intrinsic_op value. */
1871 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1873 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1874 if (iomode
== IO_OUTPUT
)
1876 HOST_WIDE_INT converted
= (HOST_WIDE_INT
) *op
;
1877 write_atom (ATOM_INTEGER
, &converted
);
1881 require_atom (ATOM_INTEGER
);
1882 *op
= (gfc_intrinsic_op
) atom_int
;
1887 /* Read or write a character pointer that points to a string on the heap. */
1890 mio_allocated_string (const char *s
)
1892 if (iomode
== IO_OUTPUT
)
1894 write_atom (ATOM_STRING
, s
);
1899 require_atom (ATOM_STRING
);
1905 /* Functions for quoting and unquoting strings. */
1908 quote_string (const gfc_char_t
*s
, const size_t slength
)
1910 const gfc_char_t
*p
;
1914 /* Calculate the length we'll need: a backslash takes two ("\\"),
1915 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1916 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1920 else if (!gfc_wide_is_printable (*p
))
1926 q
= res
= XCNEWVEC (char, len
+ 1);
1927 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1930 *q
++ = '\\', *q
++ = '\\';
1931 else if (!gfc_wide_is_printable (*p
))
1933 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1934 (unsigned HOST_WIDE_INT
) *p
);
1938 *q
++ = (unsigned char) *p
;
1946 unquote_string (const char *s
)
1952 for (p
= s
, len
= 0; *p
; p
++, len
++)
1959 else if (p
[1] == 'U')
1960 p
+= 9; /* That is a "\U????????". */
1962 gfc_internal_error ("unquote_string(): got bad string");
1965 res
= gfc_get_wide_string (len
+ 1);
1966 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1971 res
[i
] = (unsigned char) *p
;
1972 else if (p
[1] == '\\')
1974 res
[i
] = (unsigned char) '\\';
1979 /* We read the 8-digits hexadecimal constant that follows. */
1984 gcc_assert (p
[1] == 'U');
1985 for (j
= 0; j
< 8; j
++)
1988 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
2002 /* Read or write a character pointer that points to a wide string on the
2003 heap, performing quoting/unquoting of nonprintable characters using the
2004 form \U???????? (where each ? is a hexadecimal digit).
2005 Length is the length of the string, only known and used in output mode. */
2007 static const gfc_char_t
*
2008 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
2010 if (iomode
== IO_OUTPUT
)
2012 char *quoted
= quote_string (s
, length
);
2013 write_atom (ATOM_STRING
, quoted
);
2019 gfc_char_t
*unquoted
;
2021 require_atom (ATOM_STRING
);
2022 unquoted
= unquote_string (atom_string
);
2029 /* Read or write a string that is in static memory. */
2032 mio_pool_string (const char **stringp
)
2034 /* TODO: one could write the string only once, and refer to it via a
2037 /* As a special case we have to deal with a NULL string. This
2038 happens for the 'module' member of 'gfc_symbol's that are not in a
2039 module. We read / write these as the empty string. */
2040 if (iomode
== IO_OUTPUT
)
2042 const char *p
= *stringp
== NULL
? "" : *stringp
;
2043 write_atom (ATOM_STRING
, p
);
2047 require_atom (ATOM_STRING
);
2048 *stringp
= (atom_string
[0] == '\0'
2049 ? NULL
: gfc_get_string ("%s", atom_string
));
2055 /* Read or write a string that is inside of some already-allocated
2059 mio_internal_string (char *string
)
2061 if (iomode
== IO_OUTPUT
)
2062 write_atom (ATOM_STRING
, string
);
2065 require_atom (ATOM_STRING
);
2066 strcpy (string
, atom_string
);
2073 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
2074 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
2075 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
2076 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
2077 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
2078 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
2079 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
, AB_EVENT_COMP
,
2080 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
2081 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
2082 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
2083 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
2084 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
, AB_OACC_DECLARE_CREATE
,
2085 AB_OACC_DECLARE_COPYIN
, AB_OACC_DECLARE_DEVICEPTR
,
2086 AB_OACC_DECLARE_DEVICE_RESIDENT
, AB_OACC_DECLARE_LINK
,
2087 AB_OMP_DECLARE_TARGET_LINK
, AB_PDT_KIND
, AB_PDT_LEN
, AB_PDT_TYPE
,
2088 AB_PDT_TEMPLATE
, AB_PDT_ARRAY
, AB_PDT_STRING
,
2089 AB_OACC_ROUTINE_LOP_GANG
, AB_OACC_ROUTINE_LOP_WORKER
,
2090 AB_OACC_ROUTINE_LOP_VECTOR
, AB_OACC_ROUTINE_LOP_SEQ
,
2091 AB_OMP_REQ_REVERSE_OFFLOAD
, AB_OMP_REQ_UNIFIED_ADDRESS
,
2092 AB_OMP_REQ_UNIFIED_SHARED_MEMORY
, AB_OMP_REQ_DYNAMIC_ALLOCATORS
,
2093 AB_OMP_REQ_MEM_ORDER_SEQ_CST
, AB_OMP_REQ_MEM_ORDER_ACQ_REL
,
2094 AB_OMP_REQ_MEM_ORDER_RELAXED
, AB_OMP_DEVICE_TYPE_NOHOST
,
2095 AB_OMP_DEVICE_TYPE_HOST
, AB_OMP_DEVICE_TYPE_ANY
2098 static const mstring attr_bits
[] =
2100 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
2101 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
2102 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
2103 minit ("DIMENSION", AB_DIMENSION
),
2104 minit ("CODIMENSION", AB_CODIMENSION
),
2105 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
2106 minit ("EXTERNAL", AB_EXTERNAL
),
2107 minit ("INTRINSIC", AB_INTRINSIC
),
2108 minit ("OPTIONAL", AB_OPTIONAL
),
2109 minit ("POINTER", AB_POINTER
),
2110 minit ("VOLATILE", AB_VOLATILE
),
2111 minit ("TARGET", AB_TARGET
),
2112 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
2113 minit ("DUMMY", AB_DUMMY
),
2114 minit ("RESULT", AB_RESULT
),
2115 minit ("DATA", AB_DATA
),
2116 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
2117 minit ("IN_COMMON", AB_IN_COMMON
),
2118 minit ("FUNCTION", AB_FUNCTION
),
2119 minit ("SUBROUTINE", AB_SUBROUTINE
),
2120 minit ("SEQUENCE", AB_SEQUENCE
),
2121 minit ("ELEMENTAL", AB_ELEMENTAL
),
2122 minit ("PURE", AB_PURE
),
2123 minit ("RECURSIVE", AB_RECURSIVE
),
2124 minit ("GENERIC", AB_GENERIC
),
2125 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
2126 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
2127 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
2128 minit ("IS_BIND_C", AB_IS_BIND_C
),
2129 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
2130 minit ("IS_ISO_C", AB_IS_ISO_C
),
2131 minit ("VALUE", AB_VALUE
),
2132 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
2133 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
2134 minit ("LOCK_COMP", AB_LOCK_COMP
),
2135 minit ("EVENT_COMP", AB_EVENT_COMP
),
2136 minit ("POINTER_COMP", AB_POINTER_COMP
),
2137 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
2138 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
2139 minit ("ZERO_COMP", AB_ZERO_COMP
),
2140 minit ("PROTECTED", AB_PROTECTED
),
2141 minit ("ABSTRACT", AB_ABSTRACT
),
2142 minit ("IS_CLASS", AB_IS_CLASS
),
2143 minit ("PROCEDURE", AB_PROCEDURE
),
2144 minit ("PROC_POINTER", AB_PROC_POINTER
),
2145 minit ("VTYPE", AB_VTYPE
),
2146 minit ("VTAB", AB_VTAB
),
2147 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2148 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2149 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2150 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2151 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2152 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2153 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE
),
2154 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN
),
2155 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR
),
2156 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT
),
2157 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK
),
2158 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK
),
2159 minit ("PDT_KIND", AB_PDT_KIND
),
2160 minit ("PDT_LEN", AB_PDT_LEN
),
2161 minit ("PDT_TYPE", AB_PDT_TYPE
),
2162 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE
),
2163 minit ("PDT_ARRAY", AB_PDT_ARRAY
),
2164 minit ("PDT_STRING", AB_PDT_STRING
),
2165 minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG
),
2166 minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER
),
2167 minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR
),
2168 minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ
),
2169 minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD
),
2170 minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS
),
2171 minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY
),
2172 minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS
),
2173 minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST
),
2174 minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL
),
2175 minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED
),
2176 minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST
),
2177 minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST
),
2178 minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY
),
2182 /* For binding attributes. */
2183 static const mstring binding_passing
[] =
2186 minit ("NOPASS", 1),
2189 static const mstring binding_overriding
[] =
2191 minit ("OVERRIDABLE", 0),
2192 minit ("NON_OVERRIDABLE", 1),
2193 minit ("DEFERRED", 2),
2196 static const mstring binding_generic
[] =
2198 minit ("SPECIFIC", 0),
2199 minit ("GENERIC", 1),
2202 static const mstring binding_ppc
[] =
2204 minit ("NO_PPC", 0),
2209 /* Specialization of mio_name. */
2210 DECL_MIO_NAME (ab_attribute
)
2211 DECL_MIO_NAME (ar_type
)
2212 DECL_MIO_NAME (array_type
)
2214 DECL_MIO_NAME (expr_t
)
2215 DECL_MIO_NAME (gfc_access
)
2216 DECL_MIO_NAME (gfc_intrinsic_op
)
2217 DECL_MIO_NAME (ifsrc
)
2218 DECL_MIO_NAME (save_state
)
2219 DECL_MIO_NAME (procedure_type
)
2220 DECL_MIO_NAME (ref_type
)
2221 DECL_MIO_NAME (sym_flavor
)
2222 DECL_MIO_NAME (sym_intent
)
2223 DECL_MIO_NAME (inquiry_type
)
2224 #undef DECL_MIO_NAME
2226 /* Verify OACC_ROUTINE_LOP_NONE. */
2229 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop
)
2231 if (lop
!= OACC_ROUTINE_LOP_NONE
)
2232 bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2235 /* Symbol attributes are stored in list with the first three elements
2236 being the enumerated fields, while the remaining elements (if any)
2237 indicate the individual attribute bits. The access field is not
2238 saved-- it controls what symbols are exported when a module is
2242 mio_symbol_attribute (symbol_attribute
*attr
)
2245 unsigned ext_attr
,extension_level
;
2249 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2250 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2251 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2252 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2253 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2255 ext_attr
= attr
->ext_attr
;
2256 mio_integer ((int *) &ext_attr
);
2257 attr
->ext_attr
= ext_attr
;
2259 extension_level
= attr
->extension
;
2260 mio_integer ((int *) &extension_level
);
2261 attr
->extension
= extension_level
;
2263 if (iomode
== IO_OUTPUT
)
2265 if (attr
->allocatable
)
2266 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2267 if (attr
->artificial
)
2268 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2269 if (attr
->asynchronous
)
2270 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2271 if (attr
->dimension
)
2272 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2273 if (attr
->codimension
)
2274 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2275 if (attr
->contiguous
)
2276 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2278 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2279 if (attr
->intrinsic
)
2280 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2282 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2284 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2285 if (attr
->class_pointer
)
2286 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2287 if (attr
->is_protected
)
2288 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2290 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2291 if (attr
->volatile_
)
2292 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2294 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2295 if (attr
->threadprivate
)
2296 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2298 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2300 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2301 /* We deliberately don't preserve the "entry" flag. */
2304 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2305 if (attr
->in_namelist
)
2306 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2307 if (attr
->in_common
)
2308 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2311 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2312 if (attr
->subroutine
)
2313 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2315 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2317 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2320 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2321 if (attr
->elemental
)
2322 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2324 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2325 if (attr
->implicit_pure
)
2326 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2327 if (attr
->unlimited_polymorphic
)
2328 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2329 if (attr
->recursive
)
2330 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2331 if (attr
->always_explicit
)
2332 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2333 if (attr
->cray_pointer
)
2334 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2335 if (attr
->cray_pointee
)
2336 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2337 if (attr
->is_bind_c
)
2338 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2339 if (attr
->is_c_interop
)
2340 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2342 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2343 if (attr
->alloc_comp
)
2344 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2345 if (attr
->pointer_comp
)
2346 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2347 if (attr
->proc_pointer_comp
)
2348 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2349 if (attr
->private_comp
)
2350 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2351 if (attr
->coarray_comp
)
2352 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2353 if (attr
->lock_comp
)
2354 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2355 if (attr
->event_comp
)
2356 MIO_NAME (ab_attribute
) (AB_EVENT_COMP
, attr_bits
);
2357 if (attr
->zero_comp
)
2358 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2360 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2361 if (attr
->procedure
)
2362 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2363 if (attr
->proc_pointer
)
2364 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2366 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2368 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2369 if (attr
->omp_declare_target
)
2370 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2371 if (attr
->array_outer_dependency
)
2372 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2373 if (attr
->module_procedure
)
2374 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2375 if (attr
->oacc_declare_create
)
2376 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_CREATE
, attr_bits
);
2377 if (attr
->oacc_declare_copyin
)
2378 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_COPYIN
, attr_bits
);
2379 if (attr
->oacc_declare_deviceptr
)
2380 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICEPTR
, attr_bits
);
2381 if (attr
->oacc_declare_device_resident
)
2382 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_DEVICE_RESIDENT
, attr_bits
);
2383 if (attr
->oacc_declare_link
)
2384 MIO_NAME (ab_attribute
) (AB_OACC_DECLARE_LINK
, attr_bits
);
2385 if (attr
->omp_declare_target_link
)
2386 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET_LINK
, attr_bits
);
2388 MIO_NAME (ab_attribute
) (AB_PDT_KIND
, attr_bits
);
2390 MIO_NAME (ab_attribute
) (AB_PDT_LEN
, attr_bits
);
2392 MIO_NAME (ab_attribute
) (AB_PDT_TYPE
, attr_bits
);
2393 if (attr
->pdt_template
)
2394 MIO_NAME (ab_attribute
) (AB_PDT_TEMPLATE
, attr_bits
);
2395 if (attr
->pdt_array
)
2396 MIO_NAME (ab_attribute
) (AB_PDT_ARRAY
, attr_bits
);
2397 if (attr
->pdt_string
)
2398 MIO_NAME (ab_attribute
) (AB_PDT_STRING
, attr_bits
);
2399 switch (attr
->oacc_routine_lop
)
2401 case OACC_ROUTINE_LOP_NONE
:
2402 /* This is the default anyway, and for maintaining compatibility with
2403 the current MOD_VERSION, we're not emitting anything in that
2406 case OACC_ROUTINE_LOP_GANG
:
2407 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_GANG
, attr_bits
);
2409 case OACC_ROUTINE_LOP_WORKER
:
2410 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_WORKER
, attr_bits
);
2412 case OACC_ROUTINE_LOP_VECTOR
:
2413 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_VECTOR
, attr_bits
);
2415 case OACC_ROUTINE_LOP_SEQ
:
2416 MIO_NAME (ab_attribute
) (AB_OACC_ROUTINE_LOP_SEQ
, attr_bits
);
2418 case OACC_ROUTINE_LOP_ERROR
:
2419 /* ... intentionally omitted here; it's only unsed internally. */
2424 if (attr
->flavor
== FL_MODULE
&& gfc_current_ns
->omp_requires
)
2426 if (gfc_current_ns
->omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
2427 MIO_NAME (ab_attribute
) (AB_OMP_REQ_REVERSE_OFFLOAD
, attr_bits
);
2428 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
2429 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_ADDRESS
, attr_bits
);
2430 if (gfc_current_ns
->omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
2431 MIO_NAME (ab_attribute
) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY
, attr_bits
);
2432 if (gfc_current_ns
->omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
2433 MIO_NAME (ab_attribute
) (AB_OMP_REQ_DYNAMIC_ALLOCATORS
, attr_bits
);
2434 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2435 == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
)
2436 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_SEQ_CST
, attr_bits
);
2437 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2438 == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
)
2439 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_ACQ_REL
, attr_bits
);
2440 if ((gfc_current_ns
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
2441 == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
)
2442 MIO_NAME (ab_attribute
) (AB_OMP_REQ_MEM_ORDER_RELAXED
, attr_bits
);
2444 switch (attr
->omp_device_type
)
2446 case OMP_DEVICE_TYPE_UNSET
:
2448 case OMP_DEVICE_TYPE_HOST
:
2449 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_HOST
, attr_bits
);
2451 case OMP_DEVICE_TYPE_NOHOST
:
2452 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_NOHOST
, attr_bits
);
2454 case OMP_DEVICE_TYPE_ANY
:
2455 MIO_NAME (ab_attribute
) (AB_OMP_DEVICE_TYPE_ANY
, attr_bits
);
2467 if (t
== ATOM_RPAREN
)
2470 bad_module ("Expected attribute bit name");
2472 switch ((ab_attribute
) find_enum (attr_bits
))
2474 case AB_ALLOCATABLE
:
2475 attr
->allocatable
= 1;
2478 attr
->artificial
= 1;
2480 case AB_ASYNCHRONOUS
:
2481 attr
->asynchronous
= 1;
2484 attr
->dimension
= 1;
2486 case AB_CODIMENSION
:
2487 attr
->codimension
= 1;
2490 attr
->contiguous
= 1;
2496 attr
->intrinsic
= 1;
2504 case AB_CLASS_POINTER
:
2505 attr
->class_pointer
= 1;
2508 attr
->is_protected
= 1;
2514 attr
->volatile_
= 1;
2519 case AB_THREADPRIVATE
:
2520 attr
->threadprivate
= 1;
2531 case AB_IN_NAMELIST
:
2532 attr
->in_namelist
= 1;
2535 attr
->in_common
= 1;
2541 attr
->subroutine
= 1;
2553 attr
->elemental
= 1;
2558 case AB_IMPLICIT_PURE
:
2559 attr
->implicit_pure
= 1;
2561 case AB_UNLIMITED_POLY
:
2562 attr
->unlimited_polymorphic
= 1;
2565 attr
->recursive
= 1;
2567 case AB_ALWAYS_EXPLICIT
:
2568 attr
->always_explicit
= 1;
2570 case AB_CRAY_POINTER
:
2571 attr
->cray_pointer
= 1;
2573 case AB_CRAY_POINTEE
:
2574 attr
->cray_pointee
= 1;
2577 attr
->is_bind_c
= 1;
2579 case AB_IS_C_INTEROP
:
2580 attr
->is_c_interop
= 1;
2586 attr
->alloc_comp
= 1;
2588 case AB_COARRAY_COMP
:
2589 attr
->coarray_comp
= 1;
2592 attr
->lock_comp
= 1;
2595 attr
->event_comp
= 1;
2597 case AB_POINTER_COMP
:
2598 attr
->pointer_comp
= 1;
2600 case AB_PROC_POINTER_COMP
:
2601 attr
->proc_pointer_comp
= 1;
2603 case AB_PRIVATE_COMP
:
2604 attr
->private_comp
= 1;
2607 attr
->zero_comp
= 1;
2613 attr
->procedure
= 1;
2615 case AB_PROC_POINTER
:
2616 attr
->proc_pointer
= 1;
2624 case AB_OMP_DECLARE_TARGET
:
2625 attr
->omp_declare_target
= 1;
2627 case AB_OMP_DECLARE_TARGET_LINK
:
2628 attr
->omp_declare_target_link
= 1;
2630 case AB_ARRAY_OUTER_DEPENDENCY
:
2631 attr
->array_outer_dependency
=1;
2633 case AB_MODULE_PROCEDURE
:
2634 attr
->module_procedure
=1;
2636 case AB_OACC_DECLARE_CREATE
:
2637 attr
->oacc_declare_create
= 1;
2639 case AB_OACC_DECLARE_COPYIN
:
2640 attr
->oacc_declare_copyin
= 1;
2642 case AB_OACC_DECLARE_DEVICEPTR
:
2643 attr
->oacc_declare_deviceptr
= 1;
2645 case AB_OACC_DECLARE_DEVICE_RESIDENT
:
2646 attr
->oacc_declare_device_resident
= 1;
2648 case AB_OACC_DECLARE_LINK
:
2649 attr
->oacc_declare_link
= 1;
2660 case AB_PDT_TEMPLATE
:
2661 attr
->pdt_template
= 1;
2664 attr
->pdt_array
= 1;
2667 attr
->pdt_string
= 1;
2669 case AB_OACC_ROUTINE_LOP_GANG
:
2670 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2671 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_GANG
;
2673 case AB_OACC_ROUTINE_LOP_WORKER
:
2674 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2675 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_WORKER
;
2677 case AB_OACC_ROUTINE_LOP_VECTOR
:
2678 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2679 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_VECTOR
;
2681 case AB_OACC_ROUTINE_LOP_SEQ
:
2682 verify_OACC_ROUTINE_LOP_NONE (attr
->oacc_routine_lop
);
2683 attr
->oacc_routine_lop
= OACC_ROUTINE_LOP_SEQ
;
2685 case AB_OMP_REQ_REVERSE_OFFLOAD
:
2686 gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD
,
2691 case AB_OMP_REQ_UNIFIED_ADDRESS
:
2692 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS
,
2697 case AB_OMP_REQ_UNIFIED_SHARED_MEMORY
:
2698 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY
,
2699 "unified_shared_memory",
2703 case AB_OMP_REQ_DYNAMIC_ALLOCATORS
:
2704 gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS
,
2705 "dynamic_allocators",
2709 case AB_OMP_REQ_MEM_ORDER_SEQ_CST
:
2710 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
,
2711 "seq_cst", &gfc_current_locus
,
2714 case AB_OMP_REQ_MEM_ORDER_ACQ_REL
:
2715 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
,
2716 "acq_rel", &gfc_current_locus
,
2719 case AB_OMP_REQ_MEM_ORDER_RELAXED
:
2720 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
,
2721 "relaxed", &gfc_current_locus
,
2724 case AB_OMP_DEVICE_TYPE_HOST
:
2725 attr
->omp_device_type
= OMP_DEVICE_TYPE_HOST
;
2727 case AB_OMP_DEVICE_TYPE_NOHOST
:
2728 attr
->omp_device_type
= OMP_DEVICE_TYPE_NOHOST
;
2730 case AB_OMP_DEVICE_TYPE_ANY
:
2731 attr
->omp_device_type
= OMP_DEVICE_TYPE_ANY
;
2739 static const mstring bt_types
[] = {
2740 minit ("INTEGER", BT_INTEGER
),
2741 minit ("REAL", BT_REAL
),
2742 minit ("COMPLEX", BT_COMPLEX
),
2743 minit ("LOGICAL", BT_LOGICAL
),
2744 minit ("CHARACTER", BT_CHARACTER
),
2745 minit ("UNION", BT_UNION
),
2746 minit ("DERIVED", BT_DERIVED
),
2747 minit ("CLASS", BT_CLASS
),
2748 minit ("PROCEDURE", BT_PROCEDURE
),
2749 minit ("UNKNOWN", BT_UNKNOWN
),
2750 minit ("VOID", BT_VOID
),
2751 minit ("ASSUMED", BT_ASSUMED
),
2757 mio_charlen (gfc_charlen
**clp
)
2763 if (iomode
== IO_OUTPUT
)
2767 mio_expr (&cl
->length
);
2771 if (peek_atom () != ATOM_RPAREN
)
2773 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2774 mio_expr (&cl
->length
);
2783 /* See if a name is a generated name. */
2786 check_unique_name (const char *name
)
2788 return *name
== '@';
2793 mio_typespec (gfc_typespec
*ts
)
2797 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2799 if (!gfc_bt_struct (ts
->type
) && ts
->type
!= BT_CLASS
)
2800 mio_integer (&ts
->kind
);
2802 mio_symbol_ref (&ts
->u
.derived
);
2804 mio_symbol_ref (&ts
->interface
);
2806 /* Add info for C interop and is_iso_c. */
2807 mio_integer (&ts
->is_c_interop
);
2808 mio_integer (&ts
->is_iso_c
);
2810 /* If the typespec is for an identifier either from iso_c_binding, or
2811 a constant that was initialized to an identifier from it, use the
2812 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2814 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2816 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2818 if (ts
->type
!= BT_CHARACTER
)
2820 /* ts->u.cl is only valid for BT_CHARACTER. */
2825 mio_charlen (&ts
->u
.cl
);
2827 /* So as not to disturb the existing API, use an ATOM_NAME to
2828 transmit deferred characteristic for characters (F2003). */
2829 if (iomode
== IO_OUTPUT
)
2831 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2832 write_atom (ATOM_NAME
, "DEFERRED_CL");
2834 else if (peek_atom () != ATOM_RPAREN
)
2836 if (parse_atom () != ATOM_NAME
)
2837 bad_module ("Expected string");
2845 static const mstring array_spec_types
[] = {
2846 minit ("EXPLICIT", AS_EXPLICIT
),
2847 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2848 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2849 minit ("DEFERRED", AS_DEFERRED
),
2850 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2856 mio_array_spec (gfc_array_spec
**asp
)
2863 if (iomode
== IO_OUTPUT
)
2871 /* mio_integer expects nonnegative values. */
2872 rank
= as
->rank
> 0 ? as
->rank
: 0;
2873 mio_integer (&rank
);
2877 if (peek_atom () == ATOM_RPAREN
)
2883 *asp
= as
= gfc_get_array_spec ();
2884 mio_integer (&as
->rank
);
2887 mio_integer (&as
->corank
);
2888 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2890 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2892 if (iomode
== IO_INPUT
&& as
->corank
)
2893 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2895 if (as
->rank
+ as
->corank
> 0)
2896 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2898 mio_expr (&as
->lower
[i
]);
2899 mio_expr (&as
->upper
[i
]);
2907 /* Given a pointer to an array reference structure (which lives in a
2908 gfc_ref structure), find the corresponding array specification
2909 structure. Storing the pointer in the ref structure doesn't quite
2910 work when loading from a module. Generating code for an array
2911 reference also needs more information than just the array spec. */
2913 static const mstring array_ref_types
[] = {
2914 minit ("FULL", AR_FULL
),
2915 minit ("ELEMENT", AR_ELEMENT
),
2916 minit ("SECTION", AR_SECTION
),
2922 mio_array_ref (gfc_array_ref
*ar
)
2927 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2928 mio_integer (&ar
->dimen
);
2936 for (i
= 0; i
< ar
->dimen
; i
++)
2937 mio_expr (&ar
->start
[i
]);
2942 for (i
= 0; i
< ar
->dimen
; i
++)
2944 mio_expr (&ar
->start
[i
]);
2945 mio_expr (&ar
->end
[i
]);
2946 mio_expr (&ar
->stride
[i
]);
2952 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2955 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2956 we can't call mio_integer directly. Instead loop over each element
2957 and cast it to/from an integer. */
2958 if (iomode
== IO_OUTPUT
)
2960 for (i
= 0; i
< ar
->dimen
; i
++)
2962 HOST_WIDE_INT tmp
= (HOST_WIDE_INT
)ar
->dimen_type
[i
];
2963 write_atom (ATOM_INTEGER
, &tmp
);
2968 for (i
= 0; i
< ar
->dimen
; i
++)
2970 require_atom (ATOM_INTEGER
);
2971 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2975 if (iomode
== IO_INPUT
)
2977 ar
->where
= gfc_current_locus
;
2979 for (i
= 0; i
< ar
->dimen
; i
++)
2980 ar
->c_where
[i
] = gfc_current_locus
;
2987 /* Saves or restores a pointer. The pointer is converted back and
2988 forth from an integer. We return the pointer_info pointer so that
2989 the caller can take additional action based on the pointer type. */
2991 static pointer_info
*
2992 mio_pointer_ref (void *gp
)
2996 if (iomode
== IO_OUTPUT
)
2998 p
= get_pointer (*((char **) gp
));
2999 HOST_WIDE_INT hwi
= p
->integer
;
3000 write_atom (ATOM_INTEGER
, &hwi
);
3004 require_atom (ATOM_INTEGER
);
3005 p
= add_fixup (atom_int
, gp
);
3012 /* Save and load references to components that occur within
3013 expressions. We have to describe these references by a number and
3014 by name. The number is necessary for forward references during
3015 reading, and the name is necessary if the symbol already exists in
3016 the namespace and is not loaded again. */
3019 mio_component_ref (gfc_component
**cp
)
3023 p
= mio_pointer_ref (cp
);
3024 if (p
->type
== P_UNKNOWN
)
3025 p
->type
= P_COMPONENT
;
3029 static void mio_namespace_ref (gfc_namespace
**nsp
);
3030 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
3031 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
3032 static void mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
);
3035 mio_component (gfc_component
*c
, int vtype
)
3041 if (iomode
== IO_OUTPUT
)
3043 p
= get_pointer (c
);
3044 mio_hwi (&p
->integer
);
3050 p
= get_integer (n
);
3051 associate_integer_pointer (p
, c
);
3054 if (p
->type
== P_UNKNOWN
)
3055 p
->type
= P_COMPONENT
;
3057 mio_pool_string (&c
->name
);
3058 mio_typespec (&c
->ts
);
3059 mio_array_spec (&c
->as
);
3061 /* PDT templates store the expression for the kind of a component here. */
3062 mio_expr (&c
->kind_expr
);
3064 /* PDT types store the component specification list here. */
3065 mio_actual_arglist (&c
->param_list
, true);
3067 mio_symbol_attribute (&c
->attr
);
3068 if (c
->ts
.type
== BT_CLASS
)
3069 c
->attr
.class_ok
= 1;
3070 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
3072 if (!vtype
|| strcmp (c
->name
, "_final") == 0
3073 || strcmp (c
->name
, "_hash") == 0)
3074 mio_expr (&c
->initializer
);
3076 if (c
->attr
.proc_pointer
)
3077 mio_typebound_proc (&c
->tb
);
3079 c
->loc
= gfc_current_locus
;
3086 mio_component_list (gfc_component
**cp
, int vtype
)
3088 gfc_component
*c
, *tail
;
3092 if (iomode
== IO_OUTPUT
)
3094 for (c
= *cp
; c
; c
= c
->next
)
3095 mio_component (c
, vtype
);
3104 if (peek_atom () == ATOM_RPAREN
)
3107 c
= gfc_get_component ();
3108 mio_component (c
, vtype
);
3124 mio_actual_arg (gfc_actual_arglist
*a
, bool pdt
)
3127 mio_pool_string (&a
->name
);
3128 mio_expr (&a
->expr
);
3130 mio_integer ((int *)&a
->spec_type
);
3136 mio_actual_arglist (gfc_actual_arglist
**ap
, bool pdt
)
3138 gfc_actual_arglist
*a
, *tail
;
3142 if (iomode
== IO_OUTPUT
)
3144 for (a
= *ap
; a
; a
= a
->next
)
3145 mio_actual_arg (a
, pdt
);
3154 if (peek_atom () != ATOM_LPAREN
)
3157 a
= gfc_get_actual_arglist ();
3165 mio_actual_arg (a
, pdt
);
3173 /* Read and write formal argument lists. */
3176 mio_formal_arglist (gfc_formal_arglist
**formal
)
3178 gfc_formal_arglist
*f
, *tail
;
3182 if (iomode
== IO_OUTPUT
)
3184 for (f
= *formal
; f
; f
= f
->next
)
3185 mio_symbol_ref (&f
->sym
);
3189 *formal
= tail
= NULL
;
3191 while (peek_atom () != ATOM_RPAREN
)
3193 f
= gfc_get_formal_arglist ();
3194 mio_symbol_ref (&f
->sym
);
3196 if (*formal
== NULL
)
3209 /* Save or restore a reference to a symbol node. */
3212 mio_symbol_ref (gfc_symbol
**symp
)
3216 p
= mio_pointer_ref (symp
);
3217 if (p
->type
== P_UNKNOWN
)
3220 if (iomode
== IO_OUTPUT
)
3222 if (p
->u
.wsym
.state
== UNREFERENCED
)
3223 p
->u
.wsym
.state
= NEEDS_WRITE
;
3227 if (p
->u
.rsym
.state
== UNUSED
)
3228 p
->u
.rsym
.state
= NEEDED
;
3234 /* Save or restore a reference to a symtree node. */
3237 mio_symtree_ref (gfc_symtree
**stp
)
3242 if (iomode
== IO_OUTPUT
)
3243 mio_symbol_ref (&(*stp
)->n
.sym
);
3246 require_atom (ATOM_INTEGER
);
3247 p
= get_integer (atom_int
);
3249 /* An unused equivalence member; make a symbol and a symtree
3251 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
3253 /* Since this is not used, it must have a unique name. */
3254 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
3256 /* Make the symbol. */
3257 if (p
->u
.rsym
.sym
== NULL
)
3259 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
3261 p
->u
.rsym
.sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
3264 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
3265 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
3266 p
->u
.rsym
.referenced
= 1;
3268 /* If the symbol is PRIVATE and in COMMON, load_commons will
3269 generate a fixup symbol, which must be associated. */
3271 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
3275 if (p
->type
== P_UNKNOWN
)
3278 if (p
->u
.rsym
.state
== UNUSED
)
3279 p
->u
.rsym
.state
= NEEDED
;
3281 if (p
->u
.rsym
.symtree
!= NULL
)
3283 *stp
= p
->u
.rsym
.symtree
;
3287 f
= XCNEW (fixup_t
);
3289 f
->next
= p
->u
.rsym
.stfixup
;
3290 p
->u
.rsym
.stfixup
= f
;
3292 f
->pointer
= (void **) stp
;
3299 mio_iterator (gfc_iterator
**ip
)
3305 if (iomode
== IO_OUTPUT
)
3312 if (peek_atom () == ATOM_RPAREN
)
3318 *ip
= gfc_get_iterator ();
3323 mio_expr (&iter
->var
);
3324 mio_expr (&iter
->start
);
3325 mio_expr (&iter
->end
);
3326 mio_expr (&iter
->step
);
3334 mio_constructor (gfc_constructor_base
*cp
)
3340 if (iomode
== IO_OUTPUT
)
3342 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
3345 mio_expr (&c
->expr
);
3346 mio_iterator (&c
->iterator
);
3352 while (peek_atom () != ATOM_RPAREN
)
3354 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
3357 mio_expr (&c
->expr
);
3358 mio_iterator (&c
->iterator
);
3367 static const mstring ref_types
[] = {
3368 minit ("ARRAY", REF_ARRAY
),
3369 minit ("COMPONENT", REF_COMPONENT
),
3370 minit ("SUBSTRING", REF_SUBSTRING
),
3371 minit ("INQUIRY", REF_INQUIRY
),
3375 static const mstring inquiry_types
[] = {
3376 minit ("RE", INQUIRY_RE
),
3377 minit ("IM", INQUIRY_IM
),
3378 minit ("KIND", INQUIRY_KIND
),
3379 minit ("LEN", INQUIRY_LEN
),
3385 mio_ref (gfc_ref
**rp
)
3392 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3397 mio_array_ref (&r
->u
.ar
);
3401 mio_symbol_ref (&r
->u
.c
.sym
);
3402 mio_component_ref (&r
->u
.c
.component
);
3406 mio_expr (&r
->u
.ss
.start
);
3407 mio_expr (&r
->u
.ss
.end
);
3408 mio_charlen (&r
->u
.ss
.length
);
3412 r
->u
.i
= MIO_NAME (inquiry_type
) (r
->u
.i
, inquiry_types
);
3421 mio_ref_list (gfc_ref
**rp
)
3423 gfc_ref
*ref
, *head
, *tail
;
3427 if (iomode
== IO_OUTPUT
)
3429 for (ref
= *rp
; ref
; ref
= ref
->next
)
3436 while (peek_atom () != ATOM_RPAREN
)
3439 head
= tail
= gfc_get_ref ();
3442 tail
->next
= gfc_get_ref ();
3456 /* Read and write an integer value. */
3459 mio_gmp_integer (mpz_t
*integer
)
3463 if (iomode
== IO_INPUT
)
3465 if (parse_atom () != ATOM_STRING
)
3466 bad_module ("Expected integer string");
3468 mpz_init (*integer
);
3469 if (mpz_set_str (*integer
, atom_string
, 10))
3470 bad_module ("Error converting integer");
3476 p
= mpz_get_str (NULL
, 10, *integer
);
3477 write_atom (ATOM_STRING
, p
);
3484 mio_gmp_real (mpfr_t
*real
)
3486 mpfr_exp_t exponent
;
3489 if (iomode
== IO_INPUT
)
3491 if (parse_atom () != ATOM_STRING
)
3492 bad_module ("Expected real string");
3495 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3500 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3502 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3504 write_atom (ATOM_STRING
, p
);
3509 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3511 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3513 /* Fix negative numbers. */
3514 if (atom_string
[2] == '-')
3516 atom_string
[0] = '-';
3517 atom_string
[1] = '0';
3518 atom_string
[2] = '.';
3521 write_atom (ATOM_STRING
, atom_string
);
3529 /* Save and restore the shape of an array constructor. */
3532 mio_shape (mpz_t
**pshape
, int rank
)
3538 /* A NULL shape is represented by (). */
3541 if (iomode
== IO_OUTPUT
)
3553 if (t
== ATOM_RPAREN
)
3560 shape
= gfc_get_shape (rank
);
3564 for (n
= 0; n
< rank
; n
++)
3565 mio_gmp_integer (&shape
[n
]);
3571 static const mstring expr_types
[] = {
3572 minit ("OP", EXPR_OP
),
3573 minit ("FUNCTION", EXPR_FUNCTION
),
3574 minit ("CONSTANT", EXPR_CONSTANT
),
3575 minit ("VARIABLE", EXPR_VARIABLE
),
3576 minit ("SUBSTRING", EXPR_SUBSTRING
),
3577 minit ("STRUCTURE", EXPR_STRUCTURE
),
3578 minit ("ARRAY", EXPR_ARRAY
),
3579 minit ("NULL", EXPR_NULL
),
3580 minit ("COMPCALL", EXPR_COMPCALL
),
3584 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3585 generic operators, not in expressions. INTRINSIC_USER is also
3586 replaced by the correct function name by the time we see it. */
3588 static const mstring intrinsics
[] =
3590 minit ("UPLUS", INTRINSIC_UPLUS
),
3591 minit ("UMINUS", INTRINSIC_UMINUS
),
3592 minit ("PLUS", INTRINSIC_PLUS
),
3593 minit ("MINUS", INTRINSIC_MINUS
),
3594 minit ("TIMES", INTRINSIC_TIMES
),
3595 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3596 minit ("POWER", INTRINSIC_POWER
),
3597 minit ("CONCAT", INTRINSIC_CONCAT
),
3598 minit ("AND", INTRINSIC_AND
),
3599 minit ("OR", INTRINSIC_OR
),
3600 minit ("EQV", INTRINSIC_EQV
),
3601 minit ("NEQV", INTRINSIC_NEQV
),
3602 minit ("EQ_SIGN", INTRINSIC_EQ
),
3603 minit ("EQ", INTRINSIC_EQ_OS
),
3604 minit ("NE_SIGN", INTRINSIC_NE
),
3605 minit ("NE", INTRINSIC_NE_OS
),
3606 minit ("GT_SIGN", INTRINSIC_GT
),
3607 minit ("GT", INTRINSIC_GT_OS
),
3608 minit ("GE_SIGN", INTRINSIC_GE
),
3609 minit ("GE", INTRINSIC_GE_OS
),
3610 minit ("LT_SIGN", INTRINSIC_LT
),
3611 minit ("LT", INTRINSIC_LT_OS
),
3612 minit ("LE_SIGN", INTRINSIC_LE
),
3613 minit ("LE", INTRINSIC_LE_OS
),
3614 minit ("NOT", INTRINSIC_NOT
),
3615 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3616 minit ("USER", INTRINSIC_USER
),
3621 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3624 fix_mio_expr (gfc_expr
*e
)
3626 gfc_symtree
*ns_st
= NULL
;
3629 if (iomode
!= IO_OUTPUT
)
3634 /* If this is a symtree for a symbol that came from a contained module
3635 namespace, it has a unique name and we should look in the current
3636 namespace to see if the required, non-contained symbol is available
3637 yet. If so, the latter should be written. */
3638 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3640 const char *name
= e
->symtree
->n
.sym
->name
;
3641 if (gfc_fl_struct (e
->symtree
->n
.sym
->attr
.flavor
))
3642 name
= gfc_dt_upper_string (name
);
3643 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3646 /* On the other hand, if the existing symbol is the module name or the
3647 new symbol is a dummy argument, do not do the promotion. */
3648 if (ns_st
&& ns_st
->n
.sym
3649 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3650 && !e
->symtree
->n
.sym
->attr
.dummy
)
3653 else if (e
->expr_type
== EXPR_FUNCTION
3654 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3658 /* In some circumstances, a function used in an initialization
3659 expression, in one use associated module, can fail to be
3660 coupled to its symtree when used in a specification
3661 expression in another module. */
3662 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3663 : e
->value
.function
.isym
->name
;
3664 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3669 /* This is probably a reference to a private procedure from another
3670 module. To prevent a segfault, make a generic with no specific
3671 instances. If this module is used, without the required
3672 specific coming from somewhere, the appropriate error message
3674 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3675 sym
->attr
.flavor
= FL_PROCEDURE
;
3676 sym
->attr
.generic
= 1;
3677 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3678 gfc_commit_symbol (sym
);
3683 /* Read and write expressions. The form "()" is allowed to indicate a
3687 mio_expr (gfc_expr
**ep
)
3696 if (iomode
== IO_OUTPUT
)
3705 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3710 if (t
== ATOM_RPAREN
)
3717 bad_module ("Expected expression type");
3719 e
= *ep
= gfc_get_expr ();
3720 e
->where
= gfc_current_locus
;
3721 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3724 mio_typespec (&e
->ts
);
3725 mio_integer (&e
->rank
);
3729 switch (e
->expr_type
)
3733 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3735 switch (e
->value
.op
.op
)
3737 case INTRINSIC_UPLUS
:
3738 case INTRINSIC_UMINUS
:
3740 case INTRINSIC_PARENTHESES
:
3741 mio_expr (&e
->value
.op
.op1
);
3744 case INTRINSIC_PLUS
:
3745 case INTRINSIC_MINUS
:
3746 case INTRINSIC_TIMES
:
3747 case INTRINSIC_DIVIDE
:
3748 case INTRINSIC_POWER
:
3749 case INTRINSIC_CONCAT
:
3753 case INTRINSIC_NEQV
:
3755 case INTRINSIC_EQ_OS
:
3757 case INTRINSIC_NE_OS
:
3759 case INTRINSIC_GT_OS
:
3761 case INTRINSIC_GE_OS
:
3763 case INTRINSIC_LT_OS
:
3765 case INTRINSIC_LE_OS
:
3766 mio_expr (&e
->value
.op
.op1
);
3767 mio_expr (&e
->value
.op
.op2
);
3770 case INTRINSIC_USER
:
3771 /* INTRINSIC_USER should not appear in resolved expressions,
3772 though for UDRs we need to stream unresolved ones. */
3773 if (iomode
== IO_OUTPUT
)
3774 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3777 char *name
= read_string ();
3778 const char *uop_name
= find_use_name (name
, true);
3779 if (uop_name
== NULL
)
3781 size_t len
= strlen (name
);
3782 char *name2
= XCNEWVEC (char, len
+ 2);
3783 memcpy (name2
, name
, len
);
3785 name2
[len
+ 1] = '\0';
3787 uop_name
= name
= name2
;
3789 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3792 mio_expr (&e
->value
.op
.op1
);
3793 mio_expr (&e
->value
.op
.op2
);
3797 bad_module ("Bad operator");
3803 mio_symtree_ref (&e
->symtree
);
3804 mio_actual_arglist (&e
->value
.function
.actual
, false);
3806 if (iomode
== IO_OUTPUT
)
3808 e
->value
.function
.name
3809 = mio_allocated_string (e
->value
.function
.name
);
3810 if (e
->value
.function
.esym
)
3814 else if (e
->value
.function
.isym
== NULL
)
3818 mio_integer (&flag
);
3822 mio_symbol_ref (&e
->value
.function
.esym
);
3825 mio_ref_list (&e
->ref
);
3830 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3835 require_atom (ATOM_STRING
);
3836 if (atom_string
[0] == '\0')
3837 e
->value
.function
.name
= NULL
;
3839 e
->value
.function
.name
= gfc_get_string ("%s", atom_string
);
3842 mio_integer (&flag
);
3846 mio_symbol_ref (&e
->value
.function
.esym
);
3849 mio_ref_list (&e
->ref
);
3854 require_atom (ATOM_STRING
);
3855 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3863 mio_symtree_ref (&e
->symtree
);
3864 mio_ref_list (&e
->ref
);
3867 case EXPR_SUBSTRING
:
3868 e
->value
.character
.string
3869 = CONST_CAST (gfc_char_t
*,
3870 mio_allocated_wide_string (e
->value
.character
.string
,
3871 e
->value
.character
.length
));
3872 mio_ref_list (&e
->ref
);
3875 case EXPR_STRUCTURE
:
3877 mio_constructor (&e
->value
.constructor
);
3878 mio_shape (&e
->shape
, e
->rank
);
3885 mio_gmp_integer (&e
->value
.integer
);
3889 gfc_set_model_kind (e
->ts
.kind
);
3890 mio_gmp_real (&e
->value
.real
);
3894 gfc_set_model_kind (e
->ts
.kind
);
3895 mio_gmp_real (&mpc_realref (e
->value
.complex));
3896 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3900 mio_integer (&e
->value
.logical
);
3904 hwi
= e
->value
.character
.length
;
3906 e
->value
.character
.length
= hwi
;
3907 e
->value
.character
.string
3908 = CONST_CAST (gfc_char_t
*,
3909 mio_allocated_wide_string (e
->value
.character
.string
,
3910 e
->value
.character
.length
));
3914 bad_module ("Bad type in constant expression");
3929 /* PDT types store the expression specification list here. */
3930 mio_actual_arglist (&e
->param_list
, true);
3936 /* Read and write namelists. */
3939 mio_namelist (gfc_symbol
*sym
)
3941 gfc_namelist
*n
, *m
;
3945 if (iomode
== IO_OUTPUT
)
3947 for (n
= sym
->namelist
; n
; n
= n
->next
)
3948 mio_symbol_ref (&n
->sym
);
3953 while (peek_atom () != ATOM_RPAREN
)
3955 n
= gfc_get_namelist ();
3956 mio_symbol_ref (&n
->sym
);
3958 if (sym
->namelist
== NULL
)
3965 sym
->namelist_tail
= m
;
3972 /* Save/restore lists of gfc_interface structures. When loading an
3973 interface, we are really appending to the existing list of
3974 interfaces. Checking for duplicate and ambiguous interfaces has to
3975 be done later when all symbols have been loaded. */
3978 mio_interface_rest (gfc_interface
**ip
)
3980 gfc_interface
*tail
, *p
;
3981 pointer_info
*pi
= NULL
;
3983 if (iomode
== IO_OUTPUT
)
3986 for (p
= *ip
; p
; p
= p
->next
)
3987 mio_symbol_ref (&p
->sym
);
4002 if (peek_atom () == ATOM_RPAREN
)
4005 p
= gfc_get_interface ();
4006 p
->where
= gfc_current_locus
;
4007 pi
= mio_symbol_ref (&p
->sym
);
4023 /* Save/restore a nameless operator interface. */
4026 mio_interface (gfc_interface
**ip
)
4029 mio_interface_rest (ip
);
4033 /* Save/restore a named operator interface. */
4036 mio_symbol_interface (const char **name
, const char **module
,
4040 mio_pool_string (name
);
4041 mio_pool_string (module
);
4042 mio_interface_rest (ip
);
4047 mio_namespace_ref (gfc_namespace
**nsp
)
4052 p
= mio_pointer_ref (nsp
);
4054 if (p
->type
== P_UNKNOWN
)
4055 p
->type
= P_NAMESPACE
;
4057 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
4059 ns
= (gfc_namespace
*) p
->u
.pointer
;
4062 ns
= gfc_get_namespace (NULL
, 0);
4063 associate_integer_pointer (p
, ns
);
4071 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
4073 static gfc_namespace
* current_f2k_derived
;
4076 mio_typebound_proc (gfc_typebound_proc
** proc
)
4079 int overriding_flag
;
4081 if (iomode
== IO_INPUT
)
4083 *proc
= gfc_get_typebound_proc (NULL
);
4084 (*proc
)->where
= gfc_current_locus
;
4090 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
4092 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
4093 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4094 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
4095 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
4096 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
4097 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
4098 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
4100 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
4101 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
4102 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
4104 mio_pool_string (&((*proc
)->pass_arg
));
4106 flag
= (int) (*proc
)->pass_arg_num
;
4107 mio_integer (&flag
);
4108 (*proc
)->pass_arg_num
= (unsigned) flag
;
4110 if ((*proc
)->is_generic
)
4117 if (iomode
== IO_OUTPUT
)
4118 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
4120 iop
= (int) g
->is_operator
;
4122 mio_allocated_string (g
->specific_st
->name
);
4126 (*proc
)->u
.generic
= NULL
;
4127 while (peek_atom () != ATOM_RPAREN
)
4129 gfc_symtree
** sym_root
;
4131 g
= gfc_get_tbp_generic ();
4135 g
->is_operator
= (bool) iop
;
4137 require_atom (ATOM_STRING
);
4138 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
4139 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
4142 g
->next
= (*proc
)->u
.generic
;
4143 (*proc
)->u
.generic
= g
;
4149 else if (!(*proc
)->ppc
)
4150 mio_symtree_ref (&(*proc
)->u
.specific
);
4155 /* Walker-callback function for this purpose. */
4157 mio_typebound_symtree (gfc_symtree
* st
)
4159 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
4162 if (iomode
== IO_OUTPUT
)
4165 mio_allocated_string (st
->name
);
4167 /* For IO_INPUT, the above is done in mio_f2k_derived. */
4169 mio_typebound_proc (&st
->n
.tb
);
4173 /* IO a full symtree (in all depth). */
4175 mio_full_typebound_tree (gfc_symtree
** root
)
4179 if (iomode
== IO_OUTPUT
)
4180 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
4183 while (peek_atom () == ATOM_LPAREN
)
4189 require_atom (ATOM_STRING
);
4190 st
= gfc_get_tbp_symtree (root
, atom_string
);
4193 mio_typebound_symtree (st
);
4201 mio_finalizer (gfc_finalizer
**f
)
4203 if (iomode
== IO_OUTPUT
)
4206 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
4207 mio_symtree_ref (&(*f
)->proc_tree
);
4211 *f
= gfc_get_finalizer ();
4212 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
4215 mio_symtree_ref (&(*f
)->proc_tree
);
4216 (*f
)->proc_sym
= NULL
;
4221 mio_f2k_derived (gfc_namespace
*f2k
)
4223 current_f2k_derived
= f2k
;
4225 /* Handle the list of finalizer procedures. */
4227 if (iomode
== IO_OUTPUT
)
4230 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
4235 f2k
->finalizers
= NULL
;
4236 while (peek_atom () != ATOM_RPAREN
)
4238 gfc_finalizer
*cur
= NULL
;
4239 mio_finalizer (&cur
);
4240 cur
->next
= f2k
->finalizers
;
4241 f2k
->finalizers
= cur
;
4246 /* Handle type-bound procedures. */
4247 mio_full_typebound_tree (&f2k
->tb_sym_root
);
4249 /* Type-bound user operators. */
4250 mio_full_typebound_tree (&f2k
->tb_uop_root
);
4252 /* Type-bound intrinsic operators. */
4254 if (iomode
== IO_OUTPUT
)
4257 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
4259 gfc_intrinsic_op realop
;
4261 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
4265 realop
= (gfc_intrinsic_op
) op
;
4266 mio_intrinsic_op (&realop
);
4267 mio_typebound_proc (&f2k
->tb_op
[op
]);
4272 while (peek_atom () != ATOM_RPAREN
)
4274 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
4277 mio_intrinsic_op (&op
);
4278 mio_typebound_proc (&f2k
->tb_op
[op
]);
4285 mio_full_f2k_derived (gfc_symbol
*sym
)
4289 if (iomode
== IO_OUTPUT
)
4291 if (sym
->f2k_derived
)
4292 mio_f2k_derived (sym
->f2k_derived
);
4296 if (peek_atom () != ATOM_RPAREN
)
4300 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4302 /* PDT templates make use of the mechanisms for formal args
4303 and so the parameter symbols are stored in the formal
4304 namespace. Transfer the sym_root to f2k_derived and then
4305 free the formal namespace since it is uneeded. */
4306 if (sym
->attr
.pdt_template
&& sym
->formal
&& sym
->formal
->sym
)
4308 ns
= sym
->formal
->sym
->ns
;
4309 sym
->f2k_derived
->sym_root
= ns
->sym_root
;
4310 ns
->sym_root
= NULL
;
4312 gfc_free_namespace (ns
);
4316 mio_f2k_derived (sym
->f2k_derived
);
4319 gcc_assert (!sym
->f2k_derived
);
4325 static const mstring omp_declare_simd_clauses
[] =
4327 minit ("INBRANCH", 0),
4328 minit ("NOTINBRANCH", 1),
4329 minit ("SIMDLEN", 2),
4330 minit ("UNIFORM", 3),
4331 minit ("LINEAR", 4),
4332 minit ("ALIGNED", 5),
4333 minit ("LINEAR_REF", 33),
4334 minit ("LINEAR_VAL", 34),
4335 minit ("LINEAR_UVAL", 35),
4339 /* Handle !$omp declare simd. */
4342 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
4344 if (iomode
== IO_OUTPUT
)
4349 else if (peek_atom () != ATOM_LPAREN
)
4352 gfc_omp_declare_simd
*ods
= *odsp
;
4355 if (iomode
== IO_OUTPUT
)
4357 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
4360 gfc_omp_namelist
*n
;
4362 if (ods
->clauses
->inbranch
)
4363 mio_name (0, omp_declare_simd_clauses
);
4364 if (ods
->clauses
->notinbranch
)
4365 mio_name (1, omp_declare_simd_clauses
);
4366 if (ods
->clauses
->simdlen_expr
)
4368 mio_name (2, omp_declare_simd_clauses
);
4369 mio_expr (&ods
->clauses
->simdlen_expr
);
4371 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
4373 mio_name (3, omp_declare_simd_clauses
);
4374 mio_symbol_ref (&n
->sym
);
4376 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
4378 if (n
->u
.linear_op
== OMP_LINEAR_DEFAULT
)
4379 mio_name (4, omp_declare_simd_clauses
);
4381 mio_name (32 + n
->u
.linear_op
, omp_declare_simd_clauses
);
4382 mio_symbol_ref (&n
->sym
);
4383 mio_expr (&n
->expr
);
4385 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4387 mio_name (5, omp_declare_simd_clauses
);
4388 mio_symbol_ref (&n
->sym
);
4389 mio_expr (&n
->expr
);
4395 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
4397 require_atom (ATOM_NAME
);
4398 *odsp
= ods
= gfc_get_omp_declare_simd ();
4399 ods
->where
= gfc_current_locus
;
4400 ods
->proc_name
= ns
->proc_name
;
4401 if (peek_atom () == ATOM_NAME
)
4403 ods
->clauses
= gfc_get_omp_clauses ();
4404 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
4405 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
4406 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
4408 while (peek_atom () == ATOM_NAME
)
4410 gfc_omp_namelist
*n
;
4411 int t
= mio_name (0, omp_declare_simd_clauses
);
4415 case 0: ods
->clauses
->inbranch
= true; break;
4416 case 1: ods
->clauses
->notinbranch
= true; break;
4417 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4421 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4423 n
->where
= gfc_current_locus
;
4424 ptrs
[t
- 3] = &n
->next
;
4425 mio_symbol_ref (&n
->sym
);
4427 mio_expr (&n
->expr
);
4432 *ptrs
[1] = n
= gfc_get_omp_namelist ();
4433 n
->u
.linear_op
= (enum gfc_omp_linear_op
) (t
- 32);
4435 goto finish_namelist
;
4440 mio_omp_declare_simd (ns
, &ods
->next
);
4446 static const mstring omp_declare_reduction_stmt
[] =
4448 minit ("ASSIGN", 0),
4455 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4456 gfc_namespace
*ns
, bool is_initializer
)
4458 if (iomode
== IO_OUTPUT
)
4460 if ((*sym1
)->module
== NULL
)
4462 (*sym1
)->module
= module_name
;
4463 (*sym2
)->module
= module_name
;
4465 mio_symbol_ref (sym1
);
4466 mio_symbol_ref (sym2
);
4467 if (ns
->code
->op
== EXEC_ASSIGN
)
4469 mio_name (0, omp_declare_reduction_stmt
);
4470 mio_expr (&ns
->code
->expr1
);
4471 mio_expr (&ns
->code
->expr2
);
4476 mio_name (1, omp_declare_reduction_stmt
);
4477 mio_symtree_ref (&ns
->code
->symtree
);
4478 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4480 flag
= ns
->code
->resolved_isym
!= NULL
;
4481 mio_integer (&flag
);
4483 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4485 mio_symbol_ref (&ns
->code
->resolved_sym
);
4490 pointer_info
*p1
= mio_symbol_ref (sym1
);
4491 pointer_info
*p2
= mio_symbol_ref (sym2
);
4493 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4494 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4495 /* Add hidden symbols to the symtree. */
4496 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4497 q
->u
.pointer
= (void *) ns
;
4498 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4500 sym
->module
= gfc_get_string ("%s", p1
->u
.rsym
.module
);
4501 associate_integer_pointer (p1
, sym
);
4502 sym
->attr
.omp_udr_artificial_var
= 1;
4503 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4504 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4506 sym
->module
= gfc_get_string ("%s", p2
->u
.rsym
.module
);
4507 associate_integer_pointer (p2
, sym
);
4508 sym
->attr
.omp_udr_artificial_var
= 1;
4509 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4511 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4512 mio_expr (&ns
->code
->expr1
);
4513 mio_expr (&ns
->code
->expr2
);
4518 ns
->code
= gfc_get_code (EXEC_CALL
);
4519 mio_symtree_ref (&ns
->code
->symtree
);
4520 mio_actual_arglist (&ns
->code
->ext
.actual
, false);
4522 mio_integer (&flag
);
4525 require_atom (ATOM_STRING
);
4526 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4530 mio_symbol_ref (&ns
->code
->resolved_sym
);
4532 ns
->code
->loc
= gfc_current_locus
;
4538 /* Unlike most other routines, the address of the symbol node is already
4539 fixed on input and the name/module has already been filled in.
4540 If you update the symbol format here, don't forget to update read_module
4541 as well (look for "seek to the symbol's component list"). */
4544 mio_symbol (gfc_symbol
*sym
)
4546 int intmod
= INTMOD_NONE
;
4550 mio_symbol_attribute (&sym
->attr
);
4552 if (sym
->attr
.pdt_type
)
4553 sym
->name
= gfc_dt_upper_string (sym
->name
);
4555 /* Note that components are always saved, even if they are supposed
4556 to be private. Component access is checked during searching. */
4557 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4558 if (sym
->components
!= NULL
)
4559 sym
->component_access
4560 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4562 mio_typespec (&sym
->ts
);
4563 if (sym
->ts
.type
== BT_CLASS
)
4564 sym
->attr
.class_ok
= 1;
4566 if (iomode
== IO_OUTPUT
)
4567 mio_namespace_ref (&sym
->formal_ns
);
4570 mio_namespace_ref (&sym
->formal_ns
);
4572 sym
->formal_ns
->proc_name
= sym
;
4575 /* Save/restore common block links. */
4576 mio_symbol_ref (&sym
->common_next
);
4578 mio_formal_arglist (&sym
->formal
);
4580 if (sym
->attr
.flavor
== FL_PARAMETER
)
4581 mio_expr (&sym
->value
);
4583 mio_array_spec (&sym
->as
);
4585 mio_symbol_ref (&sym
->result
);
4587 if (sym
->attr
.cray_pointee
)
4588 mio_symbol_ref (&sym
->cp_pointer
);
4590 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4591 mio_full_f2k_derived (sym
);
4593 /* PDT types store the symbol specification list here. */
4594 mio_actual_arglist (&sym
->param_list
, true);
4598 /* Add the fields that say whether this is from an intrinsic module,
4599 and if so, what symbol it is within the module. */
4600 /* mio_integer (&(sym->from_intmod)); */
4601 if (iomode
== IO_OUTPUT
)
4603 intmod
= sym
->from_intmod
;
4604 mio_integer (&intmod
);
4608 mio_integer (&intmod
);
4610 sym
->from_intmod
= current_intmod
;
4612 sym
->from_intmod
= (intmod_id
) intmod
;
4615 mio_integer (&(sym
->intmod_sym_id
));
4617 if (gfc_fl_struct (sym
->attr
.flavor
))
4618 mio_integer (&(sym
->hash_value
));
4621 && sym
->formal_ns
->proc_name
== sym
4622 && sym
->formal_ns
->entries
== NULL
)
4623 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4629 /************************* Top level subroutines *************************/
4631 /* A recursive function to look for a specific symbol by name and by
4632 module. Whilst several symtrees might point to one symbol, its
4633 is sufficient for the purposes here than one exist. Note that
4634 generic interfaces are distinguished as are symbols that have been
4635 renamed in another module. */
4636 static gfc_symtree
*
4637 find_symbol (gfc_symtree
*st
, const char *name
,
4638 const char *module
, int generic
)
4641 gfc_symtree
*retval
, *s
;
4643 if (st
== NULL
|| st
->n
.sym
== NULL
)
4646 c
= strcmp (name
, st
->n
.sym
->name
);
4647 if (c
== 0 && st
->n
.sym
->module
4648 && strcmp (module
, st
->n
.sym
->module
) == 0
4649 && !check_unique_name (st
->name
))
4651 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4653 /* Detect symbols that are renamed by use association in another
4654 module by the absence of a symtree and null attr.use_rename,
4655 since the latter is not transmitted in the module file. */
4656 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4657 || (generic
&& st
->n
.sym
->attr
.generic
))
4658 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4662 retval
= find_symbol (st
->left
, name
, module
, generic
);
4665 retval
= find_symbol (st
->right
, name
, module
, generic
);
4671 /* Skip a list between balanced left and right parens.
4672 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4673 have been already parsed by hand, and the remaining of the content is to be
4674 skipped here. The default value is 0 (balanced parens). */
4677 skip_list (int nest_level
= 0)
4684 switch (parse_atom ())
4707 /* Load operator interfaces from the module. Interfaces are unusual
4708 in that they attach themselves to existing symbols. */
4711 load_operator_interfaces (void)
4714 /* "module" must be large enough for the case of submodules in which the name
4715 has the form module.submodule */
4716 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4718 pointer_info
*pi
= NULL
;
4723 while (peek_atom () != ATOM_RPAREN
)
4727 mio_internal_string (name
);
4728 mio_internal_string (module
);
4730 n
= number_use_names (name
, true);
4733 for (i
= 1; i
<= n
; i
++)
4735 /* Decide if we need to load this one or not. */
4736 p
= find_use_name_n (name
, &i
, true);
4740 while (parse_atom () != ATOM_RPAREN
);
4746 uop
= gfc_get_uop (p
);
4747 pi
= mio_interface_rest (&uop
->op
);
4751 if (gfc_find_uop (p
, NULL
))
4753 uop
= gfc_get_uop (p
);
4754 uop
->op
= gfc_get_interface ();
4755 uop
->op
->where
= gfc_current_locus
;
4756 add_fixup (pi
->integer
, &uop
->op
->sym
);
4765 /* Load interfaces from the module. Interfaces are unusual in that
4766 they attach themselves to existing symbols. */
4769 load_generic_interfaces (void)
4772 /* "module" must be large enough for the case of submodules in which the name
4773 has the form module.submodule */
4774 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
4776 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4778 bool ambiguous_set
= false;
4782 while (peek_atom () != ATOM_RPAREN
)
4786 mio_internal_string (name
);
4787 mio_internal_string (module
);
4789 n
= number_use_names (name
, false);
4790 renamed
= n
? 1 : 0;
4793 for (i
= 1; i
<= n
; i
++)
4796 /* Decide if we need to load this one or not. */
4797 p
= find_use_name_n (name
, &i
, false);
4799 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4801 /* Skip the specific names for these cases. */
4802 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4807 st
= find_symbol (gfc_current_ns
->sym_root
,
4808 name
, module_name
, 1);
4810 /* If the symbol exists already and is being USEd without being
4811 in an ONLY clause, do not load a new symtree(11.3.2). */
4812 if (!only_flag
&& st
)
4820 if (strcmp (st
->name
, p
) != 0)
4822 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4828 /* Since we haven't found a valid generic interface, we had
4832 gfc_get_symbol (p
, NULL
, &sym
);
4833 sym
->name
= gfc_get_string ("%s", name
);
4834 sym
->module
= module_name
;
4835 sym
->attr
.flavor
= FL_PROCEDURE
;
4836 sym
->attr
.generic
= 1;
4837 sym
->attr
.use_assoc
= 1;
4842 /* Unless sym is a generic interface, this reference
4845 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4849 if (st
&& !sym
->attr
.generic
4852 && strcmp (module
, sym
->module
))
4854 ambiguous_set
= true;
4859 sym
->attr
.use_only
= only_flag
;
4860 sym
->attr
.use_rename
= renamed
;
4864 mio_interface_rest (&sym
->generic
);
4865 generic
= sym
->generic
;
4867 else if (!sym
->generic
)
4869 sym
->generic
= generic
;
4870 sym
->attr
.generic_copy
= 1;
4873 /* If a procedure that is not generic has generic interfaces
4874 that include itself, it is generic! We need to take care
4875 to retain symbols ambiguous that were already so. */
4876 if (sym
->attr
.use_assoc
4877 && !sym
->attr
.generic
4878 && sym
->attr
.flavor
== FL_PROCEDURE
)
4880 for (gen
= generic
; gen
; gen
= gen
->next
)
4882 if (gen
->sym
== sym
)
4884 sym
->attr
.generic
= 1;
4899 /* Load common blocks. */
4904 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4909 while (peek_atom () != ATOM_RPAREN
)
4914 mio_internal_string (name
);
4916 p
= gfc_get_common (name
, 1);
4918 mio_symbol_ref (&p
->head
);
4919 mio_integer (&flags
);
4923 p
->threadprivate
= 1;
4924 p
->omp_device_type
= (gfc_omp_device_type
) ((flags
>> 2) & 3);
4927 /* Get whether this was a bind(c) common or not. */
4928 mio_integer (&p
->is_bind_c
);
4929 /* Get the binding label. */
4930 label
= read_string ();
4932 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4942 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4943 so that unused variables are not loaded and so that the expression can
4949 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4953 in_load_equiv
= true;
4955 end
= gfc_current_ns
->equiv
;
4956 while (end
!= NULL
&& end
->next
!= NULL
)
4959 while (peek_atom () != ATOM_RPAREN
) {
4963 while(peek_atom () != ATOM_RPAREN
)
4966 head
= tail
= gfc_get_equiv ();
4969 tail
->eq
= gfc_get_equiv ();
4973 mio_pool_string (&tail
->module
);
4974 mio_expr (&tail
->expr
);
4977 /* Check for duplicate equivalences being loaded from different modules */
4979 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4981 if (equiv
->module
&& head
->module
4982 && strcmp (equiv
->module
, head
->module
) == 0)
4991 for (eq
= head
; eq
; eq
= head
)
4994 gfc_free_expr (eq
->expr
);
5000 gfc_current_ns
->equiv
= head
;
5011 in_load_equiv
= false;
5015 /* This function loads OpenMP user defined reductions. */
5017 load_omp_udrs (void)
5020 while (peek_atom () != ATOM_RPAREN
)
5022 const char *name
= NULL
, *newname
;
5026 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
5029 mio_pool_string (&name
);
5032 if (gfc_str_startswith (name
, "operator "))
5034 const char *p
= name
+ sizeof ("operator ") - 1;
5035 if (strcmp (p
, "+") == 0)
5036 rop
= OMP_REDUCTION_PLUS
;
5037 else if (strcmp (p
, "*") == 0)
5038 rop
= OMP_REDUCTION_TIMES
;
5039 else if (strcmp (p
, "-") == 0)
5040 rop
= OMP_REDUCTION_MINUS
;
5041 else if (strcmp (p
, ".and.") == 0)
5042 rop
= OMP_REDUCTION_AND
;
5043 else if (strcmp (p
, ".or.") == 0)
5044 rop
= OMP_REDUCTION_OR
;
5045 else if (strcmp (p
, ".eqv.") == 0)
5046 rop
= OMP_REDUCTION_EQV
;
5047 else if (strcmp (p
, ".neqv.") == 0)
5048 rop
= OMP_REDUCTION_NEQV
;
5051 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
5053 size_t len
= strlen (name
+ 1);
5054 altname
= XALLOCAVEC (char, len
);
5055 gcc_assert (name
[len
] == '.');
5056 memcpy (altname
, name
+ 1, len
- 1);
5057 altname
[len
- 1] = '\0';
5060 if (rop
== OMP_REDUCTION_USER
)
5061 newname
= find_use_name (altname
? altname
: name
, !!altname
);
5062 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
5064 if (newname
== NULL
)
5069 if (altname
&& newname
!= altname
)
5071 size_t len
= strlen (newname
);
5072 altname
= XALLOCAVEC (char, len
+ 3);
5074 memcpy (altname
+ 1, newname
, len
);
5075 altname
[len
+ 1] = '.';
5076 altname
[len
+ 2] = '\0';
5077 name
= gfc_get_string ("%s", altname
);
5079 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
5080 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
5083 require_atom (ATOM_INTEGER
);
5084 pointer_info
*p
= get_integer (atom_int
);
5085 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
5087 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
5089 p
->u
.rsym
.module
, &gfc_current_locus
);
5090 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
5092 udr
->omp_out
->module
, &udr
->where
);
5097 udr
= gfc_get_omp_udr ();
5101 udr
->where
= gfc_current_locus
;
5102 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5103 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
5104 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
5106 if (peek_atom () != ATOM_RPAREN
)
5108 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5109 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
5110 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5111 udr
->initializer_ns
, true);
5115 udr
->next
= st
->n
.omp_udr
;
5116 st
->n
.omp_udr
= udr
;
5120 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
5121 st
->n
.omp_udr
= udr
;
5129 /* Recursive function to traverse the pointer_info tree and load a
5130 needed symbol. We return nonzero if we load a symbol and stop the
5131 traversal, because the act of loading can alter the tree. */
5134 load_needed (pointer_info
*p
)
5145 rv
|= load_needed (p
->left
);
5146 rv
|= load_needed (p
->right
);
5148 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
5151 p
->u
.rsym
.state
= USED
;
5153 set_module_locus (&p
->u
.rsym
.where
);
5155 sym
= p
->u
.rsym
.sym
;
5158 q
= get_integer (p
->u
.rsym
.ns
);
5160 ns
= (gfc_namespace
*) q
->u
.pointer
;
5163 /* Create an interface namespace if necessary. These are
5164 the namespaces that hold the formal parameters of module
5167 ns
= gfc_get_namespace (NULL
, 0);
5168 associate_integer_pointer (q
, ns
);
5171 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5172 doesn't go pear-shaped if the symbol is used. */
5174 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
5177 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
5178 sym
->name
= gfc_dt_lower_string (p
->u
.rsym
.true_name
);
5179 sym
->module
= gfc_get_string ("%s", p
->u
.rsym
.module
);
5180 if (p
->u
.rsym
.binding_label
)
5181 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
5182 (p
->u
.rsym
.binding_label
));
5184 associate_integer_pointer (p
, sym
);
5188 sym
->attr
.use_assoc
= 1;
5190 /* Unliked derived types, a STRUCTURE may share names with other symbols.
5191 We greedily converted the symbol name to lowercase before we knew its
5192 type, so now we must fix it. */
5193 if (sym
->attr
.flavor
== FL_STRUCT
)
5194 sym
->name
= gfc_dt_upper_string (sym
->name
);
5196 /* Mark as only or rename for later diagnosis for explicitly imported
5197 but not used warnings; don't mark internal symbols such as __vtab,
5198 __def_init etc. Only mark them if they have been explicitly loaded. */
5200 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
5204 /* Search the use/rename list for the variable; if the variable is
5206 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5208 if (strcmp (u
->use_name
, sym
->name
) == 0)
5210 sym
->attr
.use_only
= 1;
5216 if (p
->u
.rsym
.renamed
)
5217 sym
->attr
.use_rename
= 1;
5223 /* Recursive function for cleaning up things after a module has been read. */
5226 read_cleanup (pointer_info
*p
)
5234 read_cleanup (p
->left
);
5235 read_cleanup (p
->right
);
5237 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
5240 /* Add hidden symbols to the symtree. */
5241 q
= get_integer (p
->u
.rsym
.ns
);
5242 ns
= (gfc_namespace
*) q
->u
.pointer
;
5244 if (!p
->u
.rsym
.sym
->attr
.vtype
5245 && !p
->u
.rsym
.sym
->attr
.vtab
)
5246 st
= gfc_get_unique_symtree (ns
);
5249 /* There is no reason to use 'unique_symtrees' for vtabs or
5250 vtypes - their name is fine for a symtree and reduces the
5251 namespace pollution. */
5252 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5254 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
5257 st
->n
.sym
= p
->u
.rsym
.sym
;
5260 /* Fixup any symtree references. */
5261 p
->u
.rsym
.symtree
= st
;
5262 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
5263 p
->u
.rsym
.stfixup
= NULL
;
5266 /* Free unused symbols. */
5267 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
5268 gfc_free_symbol (p
->u
.rsym
.sym
);
5272 /* It is not quite enough to check for ambiguity in the symbols by
5273 the loaded symbol and the new symbol not being identical. */
5275 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
5279 symbol_attribute attr
;
5282 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
5284 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5285 "current program unit", st
->name
, module_name
);
5290 rsym
= info
->u
.rsym
.sym
;
5294 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
5297 /* If the existing symbol is generic from a different module and
5298 the new symbol is generic there can be no ambiguity. */
5299 if (st_sym
->attr
.generic
5301 && st_sym
->module
!= module_name
)
5303 /* The new symbol's attributes have not yet been read. Since
5304 we need attr.generic, read it directly. */
5305 get_module_locus (&locus
);
5306 set_module_locus (&info
->u
.rsym
.where
);
5309 mio_symbol_attribute (&attr
);
5310 set_module_locus (&locus
);
5319 /* Read a module file. */
5324 module_locus operator_interfaces
, user_operators
, omp_udrs
;
5326 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5328 /* Workaround -Wmaybe-uninitialized false positive during
5329 profiledbootstrap by initializing them. */
5330 int ambiguous
= 0, j
, nuse
, symbol
= 0;
5331 pointer_info
*info
, *q
;
5332 gfc_use_rename
*u
= NULL
;
5336 get_module_locus (&operator_interfaces
); /* Skip these for now. */
5339 get_module_locus (&user_operators
);
5343 /* Skip commons and equivalences for now. */
5347 /* Skip OpenMP UDRs. */
5348 get_module_locus (&omp_udrs
);
5353 /* Create the fixup nodes for all the symbols. */
5355 while (peek_atom () != ATOM_RPAREN
)
5358 require_atom (ATOM_INTEGER
);
5359 info
= get_integer (atom_int
);
5361 info
->type
= P_SYMBOL
;
5362 info
->u
.rsym
.state
= UNUSED
;
5364 info
->u
.rsym
.true_name
= read_string ();
5365 info
->u
.rsym
.module
= read_string ();
5366 bind_label
= read_string ();
5367 if (strlen (bind_label
))
5368 info
->u
.rsym
.binding_label
= bind_label
;
5370 XDELETEVEC (bind_label
);
5372 require_atom (ATOM_INTEGER
);
5373 info
->u
.rsym
.ns
= atom_int
;
5375 get_module_locus (&info
->u
.rsym
.where
);
5377 /* See if the symbol has already been loaded by a previous module.
5378 If so, we reference the existing symbol and prevent it from
5379 being loaded again. This should not happen if the symbol being
5380 read is an index for an assumed shape dummy array (ns != 1). */
5382 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
5385 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
5391 info
->u
.rsym
.state
= USED
;
5392 info
->u
.rsym
.sym
= sym
;
5393 /* The current symbol has already been loaded, so we can avoid loading
5394 it again. However, if it is a derived type, some of its components
5395 can be used in expressions in the module. To avoid the module loading
5396 failing, we need to associate the module's component pointer indexes
5397 with the existing symbol's component pointers. */
5398 if (gfc_fl_struct (sym
->attr
.flavor
))
5402 /* First seek to the symbol's component list. */
5403 mio_lparen (); /* symbol opening. */
5404 skip_list (); /* skip symbol attribute. */
5406 mio_lparen (); /* component list opening. */
5407 for (c
= sym
->components
; c
; c
= c
->next
)
5410 const char *comp_name
= NULL
;
5413 mio_lparen (); /* component opening. */
5415 p
= get_integer (n
);
5416 if (p
->u
.pointer
== NULL
)
5417 associate_integer_pointer (p
, c
);
5418 mio_pool_string (&comp_name
);
5419 if (comp_name
!= c
->name
)
5421 gfc_fatal_error ("Mismatch in components of derived type "
5422 "%qs from %qs at %C: expecting %qs, "
5423 "but got %qs", sym
->name
, sym
->module
,
5424 c
->name
, comp_name
);
5426 skip_list (1); /* component end. */
5428 mio_rparen (); /* component list closing. */
5430 skip_list (1); /* symbol end. */
5435 /* Some symbols do not have a namespace (eg. formal arguments),
5436 so the automatic "unique symtree" mechanism must be suppressed
5437 by marking them as referenced. */
5438 q
= get_integer (info
->u
.rsym
.ns
);
5439 if (q
->u
.pointer
== NULL
)
5441 info
->u
.rsym
.referenced
= 1;
5448 /* Parse the symtree lists. This lets us mark which symbols need to
5449 be loaded. Renaming is also done at this point by replacing the
5454 while (peek_atom () != ATOM_RPAREN
)
5456 mio_internal_string (name
);
5457 mio_integer (&ambiguous
);
5458 mio_integer (&symbol
);
5460 info
= get_integer (symbol
);
5462 /* See how many use names there are. If none, go through the start
5463 of the loop at least once. */
5464 nuse
= number_use_names (name
, false);
5465 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5470 for (j
= 1; j
<= nuse
; j
++)
5472 /* Get the jth local name for this symbol. */
5473 p
= find_use_name_n (name
, &j
, false);
5475 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5478 /* Exception: Always import vtabs & vtypes. */
5479 if (p
== NULL
&& name
[0] == '_'
5480 && (gfc_str_startswith (name
, "__vtab_")
5481 || gfc_str_startswith (name
, "__vtype_")))
5484 /* Skip symtree nodes not in an ONLY clause, unless there
5485 is an existing symtree loaded from another USE statement. */
5488 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5490 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5491 && st
->n
.sym
->module
!= NULL
5492 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5494 info
->u
.rsym
.symtree
= st
;
5495 info
->u
.rsym
.sym
= st
->n
.sym
;
5500 /* If a symbol of the same name and module exists already,
5501 this symbol, which is not in an ONLY clause, must not be
5502 added to the namespace(11.3.2). Note that find_symbol
5503 only returns the first occurrence that it finds. */
5504 if (!only_flag
&& !info
->u
.rsym
.renamed
5505 && strcmp (name
, module_name
) != 0
5506 && find_symbol (gfc_current_ns
->sym_root
, name
,
5510 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5513 && !(st
->n
.sym
&& st
->n
.sym
->attr
.used_in_submodule
))
5515 /* Check for ambiguous symbols. */
5516 if (check_for_ambiguous (st
, info
))
5519 info
->u
.rsym
.symtree
= st
;
5525 /* This symbol is host associated from a module in a
5526 submodule. Hide it with a unique symtree. */
5527 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
5528 s
->n
.sym
= st
->n
.sym
;
5533 /* Create a symtree node in the current namespace for this
5535 st
= check_unique_name (p
)
5536 ? gfc_get_unique_symtree (gfc_current_ns
)
5537 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5538 st
->ambiguous
= ambiguous
;
5541 sym
= info
->u
.rsym
.sym
;
5543 /* Create a symbol node if it doesn't already exist. */
5546 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5548 info
->u
.rsym
.sym
->name
= gfc_dt_lower_string (info
->u
.rsym
.true_name
);
5549 sym
= info
->u
.rsym
.sym
;
5550 sym
->module
= gfc_get_string ("%s", info
->u
.rsym
.module
);
5552 if (info
->u
.rsym
.binding_label
)
5554 tree id
= get_identifier (info
->u
.rsym
.binding_label
);
5555 sym
->binding_label
= IDENTIFIER_POINTER (id
);
5562 if (strcmp (name
, p
) != 0)
5563 sym
->attr
.use_rename
= 1;
5566 || (!gfc_str_startswith (name
, "__vtab_")
5567 && !gfc_str_startswith (name
, "__vtype_")))
5568 sym
->attr
.use_only
= only_flag
;
5570 /* Store the symtree pointing to this symbol. */
5571 info
->u
.rsym
.symtree
= st
;
5573 if (info
->u
.rsym
.state
== UNUSED
)
5574 info
->u
.rsym
.state
= NEEDED
;
5575 info
->u
.rsym
.referenced
= 1;
5582 /* Load intrinsic operator interfaces. */
5583 set_module_locus (&operator_interfaces
);
5586 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5588 if (i
== INTRINSIC_USER
)
5593 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5604 mio_interface (&gfc_current_ns
->op
[i
]);
5605 if (u
&& !gfc_current_ns
->op
[i
])
5611 /* Load generic and user operator interfaces. These must follow the
5612 loading of symtree because otherwise symbols can be marked as
5615 set_module_locus (&user_operators
);
5617 load_operator_interfaces ();
5618 load_generic_interfaces ();
5623 /* Load OpenMP user defined reductions. */
5624 set_module_locus (&omp_udrs
);
5627 /* At this point, we read those symbols that are needed but haven't
5628 been loaded yet. If one symbol requires another, the other gets
5629 marked as NEEDED if its previous state was UNUSED. */
5631 while (load_needed (pi_root
));
5633 /* Make sure all elements of the rename-list were found in the module. */
5635 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5640 if (u
->op
== INTRINSIC_NONE
)
5642 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5643 u
->use_name
, &u
->where
, module_name
);
5647 if (u
->op
== INTRINSIC_USER
)
5649 gfc_error ("User operator %qs referenced at %L not found "
5650 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5654 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5655 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5659 /* Clean up symbol nodes that were never loaded, create references
5660 to hidden symbols. */
5662 read_cleanup (pi_root
);
5666 /* Given an access type that is specific to an entity and the default
5667 access, return nonzero if the entity is publicly accessible. If the
5668 element is declared as PUBLIC, then it is public; if declared
5669 PRIVATE, then private, and otherwise it is public unless the default
5670 access in this context has been declared PRIVATE. */
5672 static bool dump_smod
= false;
5675 check_access (gfc_access specific_access
, gfc_access default_access
)
5680 if (specific_access
== ACCESS_PUBLIC
)
5682 if (specific_access
== ACCESS_PRIVATE
)
5685 if (flag_module_private
)
5686 return default_access
== ACCESS_PUBLIC
;
5688 return default_access
!= ACCESS_PRIVATE
;
5693 gfc_check_symbol_access (gfc_symbol
*sym
)
5695 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5698 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5702 /* A structure to remember which commons we've already written. */
5704 struct written_common
5706 BBT_HEADER(written_common
);
5707 const char *name
, *label
;
5710 static struct written_common
*written_commons
= NULL
;
5712 /* Comparison function used for balancing the binary tree. */
5715 compare_written_commons (void *a1
, void *b1
)
5717 const char *aname
= ((struct written_common
*) a1
)->name
;
5718 const char *alabel
= ((struct written_common
*) a1
)->label
;
5719 const char *bname
= ((struct written_common
*) b1
)->name
;
5720 const char *blabel
= ((struct written_common
*) b1
)->label
;
5721 int c
= strcmp (aname
, bname
);
5723 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5726 /* Free a list of written commons. */
5729 free_written_common (struct written_common
*w
)
5735 free_written_common (w
->left
);
5737 free_written_common (w
->right
);
5742 /* Write a common block to the module -- recursive helper function. */
5745 write_common_0 (gfc_symtree
*st
, bool this_module
)
5751 struct written_common
*w
;
5752 bool write_me
= true;
5757 write_common_0 (st
->left
, this_module
);
5759 /* We will write out the binding label, or "" if no label given. */
5760 name
= st
->n
.common
->name
;
5762 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5764 /* Check if we've already output this common. */
5765 w
= written_commons
;
5768 int c
= strcmp (name
, w
->name
);
5769 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5773 w
= (c
< 0) ? w
->left
: w
->right
;
5776 if (this_module
&& p
->use_assoc
)
5781 /* Write the common to the module. */
5783 mio_pool_string (&name
);
5785 mio_symbol_ref (&p
->head
);
5786 flags
= p
->saved
? 1 : 0;
5787 if (p
->threadprivate
)
5789 flags
|= p
->omp_device_type
<< 2;
5790 mio_integer (&flags
);
5792 /* Write out whether the common block is bind(c) or not. */
5793 mio_integer (&(p
->is_bind_c
));
5795 mio_pool_string (&label
);
5798 /* Record that we have written this common. */
5799 w
= XCNEW (struct written_common
);
5802 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5805 write_common_0 (st
->right
, this_module
);
5809 /* Write a common, by initializing the list of written commons, calling
5810 the recursive function write_common_0() and cleaning up afterwards. */
5813 write_common (gfc_symtree
*st
)
5815 written_commons
= NULL
;
5816 write_common_0 (st
, true);
5817 write_common_0 (st
, false);
5818 free_written_common (written_commons
);
5819 written_commons
= NULL
;
5823 /* Write the blank common block to the module. */
5826 write_blank_common (void)
5828 const char * name
= BLANK_COMMON_NAME
;
5830 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5831 this, but it hasn't been checked. Just making it so for now. */
5834 if (gfc_current_ns
->blank_common
.head
== NULL
)
5839 mio_pool_string (&name
);
5841 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5842 saved
= gfc_current_ns
->blank_common
.saved
;
5843 mio_integer (&saved
);
5845 /* Write out whether the common block is bind(c) or not. */
5846 mio_integer (&is_bind_c
);
5848 /* Write out an empty binding label. */
5849 write_atom (ATOM_STRING
, "");
5855 /* Write equivalences to the module. */
5864 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5868 for (e
= eq
; e
; e
= e
->eq
)
5870 if (e
->module
== NULL
)
5871 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5872 mio_allocated_string (e
->module
);
5873 mio_expr (&e
->expr
);
5882 /* Write a symbol to the module. */
5885 write_symbol (int n
, gfc_symbol
*sym
)
5889 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5890 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5894 if (gfc_fl_struct (sym
->attr
.flavor
))
5897 name
= gfc_dt_upper_string (sym
->name
);
5898 mio_pool_string (&name
);
5901 mio_pool_string (&sym
->name
);
5903 mio_pool_string (&sym
->module
);
5904 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5906 label
= sym
->binding_label
;
5907 mio_pool_string (&label
);
5910 write_atom (ATOM_STRING
, "");
5912 mio_pointer_ref (&sym
->ns
);
5919 /* Recursive traversal function to write the initial set of symbols to
5920 the module. We check to see if the symbol should be written
5921 according to the access specification. */
5924 write_symbol0 (gfc_symtree
*st
)
5928 bool dont_write
= false;
5933 write_symbol0 (st
->left
);
5936 if (sym
->module
== NULL
)
5937 sym
->module
= module_name
;
5939 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5940 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5943 if (!gfc_check_symbol_access (sym
))
5948 p
= get_pointer (sym
);
5949 if (p
->type
== P_UNKNOWN
)
5952 if (p
->u
.wsym
.state
!= WRITTEN
)
5954 write_symbol (p
->integer
, sym
);
5955 p
->u
.wsym
.state
= WRITTEN
;
5959 write_symbol0 (st
->right
);
5964 write_omp_udr (gfc_omp_udr
*udr
)
5968 case OMP_REDUCTION_USER
:
5969 /* Non-operators can't be used outside of the module. */
5970 if (udr
->name
[0] != '.')
5975 size_t len
= strlen (udr
->name
+ 1);
5976 char *name
= XALLOCAVEC (char, len
);
5977 memcpy (name
, udr
->name
, len
- 1);
5978 name
[len
- 1] = '\0';
5979 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5980 /* If corresponding user operator is private, don't write
5984 gfc_user_op
*uop
= st
->n
.uop
;
5985 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5990 case OMP_REDUCTION_PLUS
:
5991 case OMP_REDUCTION_MINUS
:
5992 case OMP_REDUCTION_TIMES
:
5993 case OMP_REDUCTION_AND
:
5994 case OMP_REDUCTION_OR
:
5995 case OMP_REDUCTION_EQV
:
5996 case OMP_REDUCTION_NEQV
:
5997 /* If corresponding operator is private, don't write the UDR. */
5998 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5999 gfc_current_ns
->default_access
))
6005 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
6007 /* If derived type is private, don't write the UDR. */
6008 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
6013 mio_pool_string (&udr
->name
);
6014 mio_typespec (&udr
->ts
);
6015 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
6016 if (udr
->initializer_ns
)
6017 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
6018 udr
->initializer_ns
, true);
6024 write_omp_udrs (gfc_symtree
*st
)
6029 write_omp_udrs (st
->left
);
6031 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
6032 write_omp_udr (udr
);
6033 write_omp_udrs (st
->right
);
6037 /* Type for the temporary tree used when writing secondary symbols. */
6039 struct sorted_pointer_info
6041 BBT_HEADER (sorted_pointer_info
);
6046 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
6048 /* Recursively traverse the temporary tree, free its contents. */
6051 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
6056 free_sorted_pointer_info_tree (p
->left
);
6057 free_sorted_pointer_info_tree (p
->right
);
6062 /* Comparison function for the temporary tree. */
6065 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
6067 sorted_pointer_info
*spi1
, *spi2
;
6068 spi1
= (sorted_pointer_info
*)_spi1
;
6069 spi2
= (sorted_pointer_info
*)_spi2
;
6071 if (spi1
->p
->integer
< spi2
->p
->integer
)
6073 if (spi1
->p
->integer
> spi2
->p
->integer
)
6079 /* Finds the symbols that need to be written and collects them in the
6080 sorted_pi tree so that they can be traversed in an order
6081 independent of memory addresses. */
6084 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
6089 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
6091 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
6094 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
6097 find_symbols_to_write (tree
, p
->left
);
6098 find_symbols_to_write (tree
, p
->right
);
6102 /* Recursive function that traverses the tree of symbols that need to be
6103 written and writes them in order. */
6106 write_symbol1_recursion (sorted_pointer_info
*sp
)
6111 write_symbol1_recursion (sp
->left
);
6113 pointer_info
*p1
= sp
->p
;
6114 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
6116 p1
->u
.wsym
.state
= WRITTEN
;
6117 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
6118 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
6120 write_symbol1_recursion (sp
->right
);
6124 /* Write the secondary set of symbols to the module file. These are
6125 symbols that were not public yet are needed by the public symbols
6126 or another dependent symbol. The act of writing a symbol can add
6127 symbols to the pointer_info tree, so we return nonzero if a symbol
6128 was written and pass that information upwards. The caller will
6129 then call this function again until nothing was written. It uses
6130 the utility functions and a temporary tree to ensure a reproducible
6131 ordering of the symbol output and thus the module file. */
6134 write_symbol1 (pointer_info
*p
)
6139 /* Put symbols that need to be written into a tree sorted on the
6142 sorted_pointer_info
*spi_root
= NULL
;
6143 find_symbols_to_write (&spi_root
, p
);
6145 /* No symbols to write, return. */
6149 /* Otherwise, write and free the tree again. */
6150 write_symbol1_recursion (spi_root
);
6151 free_sorted_pointer_info_tree (spi_root
);
6157 /* Write operator interfaces associated with a symbol. */
6160 write_operator (gfc_user_op
*uop
)
6162 static char nullstring
[] = "";
6163 const char *p
= nullstring
;
6165 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
6168 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
6172 /* Write generic interfaces from the namespace sym_root. */
6175 write_generic (gfc_symtree
*st
)
6182 write_generic (st
->left
);
6185 if (sym
&& !check_unique_name (st
->name
)
6186 && sym
->generic
&& gfc_check_symbol_access (sym
))
6189 sym
->module
= module_name
;
6191 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
6194 write_generic (st
->right
);
6199 write_symtree (gfc_symtree
*st
)
6206 /* A symbol in an interface body must not be visible in the
6208 if (sym
->ns
!= gfc_current_ns
6209 && sym
->ns
->proc_name
6210 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
6213 if (!gfc_check_symbol_access (sym
)
6214 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
6215 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
6218 if (check_unique_name (st
->name
))
6221 p
= find_pointer (sym
);
6223 gfc_internal_error ("write_symtree(): Symbol not written");
6225 mio_pool_string (&st
->name
);
6226 mio_integer (&st
->ambiguous
);
6227 mio_hwi (&p
->integer
);
6236 /* Initialize the column counter. */
6239 /* Write the operator interfaces. */
6242 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
6244 if (i
== INTRINSIC_USER
)
6247 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
6248 gfc_current_ns
->default_access
)
6249 ? &gfc_current_ns
->op
[i
] : NULL
);
6257 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
6263 write_generic (gfc_current_ns
->sym_root
);
6269 write_blank_common ();
6270 write_common (gfc_current_ns
->common_root
);
6282 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
6287 /* Write symbol information. First we traverse all symbols in the
6288 primary namespace, writing those that need to be written.
6289 Sometimes writing one symbol will cause another to need to be
6290 written. A list of these symbols ends up on the write stack, and
6291 we end by popping the bottom of the stack and writing the symbol
6292 until the stack is empty. */
6296 write_symbol0 (gfc_current_ns
->sym_root
);
6297 while (write_symbol1 (pi_root
))
6306 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
6311 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6312 true on success, false on failure. */
6315 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
6321 /* Open the file in binary mode. */
6322 if ((file
= fopen (filename
, "rb")) == NULL
)
6325 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6326 file. See RFC 1952. */
6327 if (fseek (file
, -8, SEEK_END
) != 0)
6333 /* Read the CRC32. */
6334 if (fread (buf
, 1, 4, file
) != 4)
6340 /* Close the file. */
6343 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
6344 + ((buf
[3] & 0xFF) << 24);
6347 /* For debugging, the CRC value printed in hexadecimal should match
6348 the CRC printed by "zcat -l -v filename".
6349 printf("CRC of file %s is %x\n", filename, val); */
6355 /* Given module, dump it to disk. If there was an error while
6356 processing the module, dump_flag will be set to zero and we delete
6357 the module file, even if it was already there. */
6360 dump_module (const char *name
, int dump_flag
)
6363 char *filename
, *filename_tmp
;
6366 module_name
= gfc_get_string ("%s", name
);
6370 name
= submodule_name
;
6371 n
= strlen (name
) + strlen (SUBMODULE_EXTENSION
) + 1;
6374 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
6376 if (gfc_option
.module_dir
!= NULL
)
6378 n
+= strlen (gfc_option
.module_dir
);
6379 filename
= (char *) alloca (n
);
6380 strcpy (filename
, gfc_option
.module_dir
);
6381 strcat (filename
, name
);
6385 filename
= (char *) alloca (n
);
6386 strcpy (filename
, name
);
6390 strcat (filename
, SUBMODULE_EXTENSION
);
6392 strcat (filename
, MODULE_EXTENSION
);
6394 /* Name of the temporary file used to write the module. */
6395 filename_tmp
= (char *) alloca (n
+ 1);
6396 strcpy (filename_tmp
, filename
);
6397 strcat (filename_tmp
, "0");
6399 /* There was an error while processing the module. We delete the
6400 module file, even if it was already there. */
6407 if (gfc_cpp_makedep ())
6408 gfc_cpp_add_target (filename
);
6410 /* Write the module to the temporary file. */
6411 module_fp
= gzopen (filename_tmp
, "w");
6412 if (module_fp
== NULL
)
6413 gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6414 filename_tmp
, xstrerror (errno
));
6416 /* Use lbasename to ensure module files are reproducible regardless
6417 of the build path (see the reproducible builds project). */
6418 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
6419 MOD_VERSION
, lbasename (gfc_source_file
));
6421 /* Write the module itself. */
6428 free_pi_tree (pi_root
);
6433 if (gzclose (module_fp
))
6434 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6435 filename_tmp
, xstrerror (errno
));
6437 /* Read the CRC32 from the gzip trailers of the module files and
6439 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
6440 || !read_crc32_from_module_file (filename
, &crc_old
)
6443 /* Module file have changed, replace the old one. */
6444 if (remove (filename
) && errno
!= ENOENT
)
6445 gfc_fatal_error ("Cannot delete module file %qs: %s", filename
,
6447 if (rename (filename_tmp
, filename
))
6448 gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6449 filename_tmp
, filename
, xstrerror (errno
));
6453 if (remove (filename_tmp
))
6454 gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6455 filename_tmp
, xstrerror (errno
));
6460 /* Suppress the output of a .smod file by module, if no module
6461 procedures have been seen. */
6462 static bool no_module_procedures
;
6465 check_for_module_procedures (gfc_symbol
*sym
)
6467 if (sym
&& sym
->attr
.module_procedure
)
6468 no_module_procedures
= false;
6473 gfc_dump_module (const char *name
, int dump_flag
)
6475 if (gfc_state_stack
->state
== COMP_SUBMODULE
)
6480 no_module_procedures
= true;
6481 gfc_traverse_ns (gfc_current_ns
, check_for_module_procedures
);
6483 dump_module (name
, dump_flag
);
6485 if (no_module_procedures
|| dump_smod
)
6488 /* Write a submodule file from a module. The 'dump_smod' flag switches
6489 off the check for PRIVATE entities. */
6491 submodule_name
= module_name
;
6492 dump_module (name
, dump_flag
);
6497 create_intrinsic_function (const char *name
, int id
,
6498 const char *modname
, intmod_id module
,
6499 bool subroutine
, gfc_symbol
*result_type
)
6501 gfc_intrinsic_sym
*isym
;
6502 gfc_symtree
*tmp_symtree
;
6505 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6508 if (tmp_symtree
->n
.sym
&& tmp_symtree
->n
.sym
->module
6509 && strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6511 gfc_error ("Symbol %qs at %C already declared", name
);
6515 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6516 sym
= tmp_symtree
->n
.sym
;
6520 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6521 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6522 sym
->attr
.subroutine
= 1;
6526 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6527 isym
= gfc_intrinsic_function_by_id (isym_id
);
6529 sym
->attr
.function
= 1;
6532 sym
->ts
.type
= BT_DERIVED
;
6533 sym
->ts
.u
.derived
= result_type
;
6534 sym
->ts
.is_c_interop
= 1;
6535 isym
->ts
.f90_type
= BT_VOID
;
6536 isym
->ts
.type
= BT_DERIVED
;
6537 isym
->ts
.f90_type
= BT_VOID
;
6538 isym
->ts
.u
.derived
= result_type
;
6539 isym
->ts
.is_c_interop
= 1;
6544 sym
->attr
.flavor
= FL_PROCEDURE
;
6545 sym
->attr
.intrinsic
= 1;
6547 sym
->module
= gfc_get_string ("%s", modname
);
6548 sym
->attr
.use_assoc
= 1;
6549 sym
->from_intmod
= module
;
6550 sym
->intmod_sym_id
= id
;
6554 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6555 the current namespace for all named constants, pointer types, and
6556 procedures in the module unless the only clause was used or a rename
6557 list was provided. */
6560 import_iso_c_binding_module (void)
6562 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6563 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6564 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6565 const char *iso_c_module_name
= "__iso_c_binding";
6568 bool want_c_ptr
= false, want_c_funptr
= false;
6570 /* Look only in the current namespace. */
6571 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6573 if (mod_symtree
== NULL
)
6575 /* symtree doesn't already exist in current namespace. */
6576 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6579 if (mod_symtree
!= NULL
)
6580 mod_sym
= mod_symtree
->n
.sym
;
6582 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6583 "create symbol for %s", iso_c_module_name
);
6585 mod_sym
->attr
.flavor
= FL_MODULE
;
6586 mod_sym
->attr
.intrinsic
= 1;
6587 mod_sym
->module
= gfc_get_string ("%s", iso_c_module_name
);
6588 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6591 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6592 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6594 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6596 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6599 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6602 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6604 want_c_funptr
= true;
6605 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6607 want_c_funptr
= true;
6608 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6611 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6612 (iso_c_binding_symbol
)
6614 u
->local_name
[0] ? u
->local_name
6618 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6622 = generate_isocbinding_symbol (iso_c_module_name
,
6623 (iso_c_binding_symbol
)
6625 u
->local_name
[0] ? u
->local_name
6631 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6632 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6633 (iso_c_binding_symbol
)
6635 NULL
, NULL
, only_flag
);
6636 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6637 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6638 (iso_c_binding_symbol
)
6640 NULL
, NULL
, only_flag
);
6642 /* Generate the symbols for the named constants representing
6643 the kinds for intrinsic data types. */
6644 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6647 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6648 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6657 #define NAMED_FUNCTION(a,b,c,d) \
6659 not_in_std = (gfc_option.allow_std & d) == 0; \
6662 #define NAMED_SUBROUTINE(a,b,c,d) \
6664 not_in_std = (gfc_option.allow_std & d) == 0; \
6667 #define NAMED_INTCST(a,b,c,d) \
6669 not_in_std = (gfc_option.allow_std & d) == 0; \
6672 #define NAMED_REALCST(a,b,c,d) \
6674 not_in_std = (gfc_option.allow_std & d) == 0; \
6677 #define NAMED_CMPXCST(a,b,c,d) \
6679 not_in_std = (gfc_option.allow_std & d) == 0; \
6682 #include "iso-c-binding.def"
6690 gfc_error ("The symbol %qs, referenced at %L, is not "
6691 "in the selected standard", name
, &u
->where
);
6697 #define NAMED_FUNCTION(a,b,c,d) \
6699 if (a == ISOCBINDING_LOC) \
6700 return_type = c_ptr->n.sym; \
6701 else if (a == ISOCBINDING_FUNLOC) \
6702 return_type = c_funptr->n.sym; \
6704 return_type = NULL; \
6705 create_intrinsic_function (u->local_name[0] \
6706 ? u->local_name : u->use_name, \
6707 a, iso_c_module_name, \
6708 INTMOD_ISO_C_BINDING, false, \
6711 #define NAMED_SUBROUTINE(a,b,c,d) \
6713 create_intrinsic_function (u->local_name[0] ? u->local_name \
6715 a, iso_c_module_name, \
6716 INTMOD_ISO_C_BINDING, true, NULL); \
6718 #include "iso-c-binding.def"
6720 case ISOCBINDING_PTR
:
6721 case ISOCBINDING_FUNPTR
:
6722 /* Already handled above. */
6725 if (i
== ISOCBINDING_NULL_PTR
)
6726 tmp_symtree
= c_ptr
;
6727 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6728 tmp_symtree
= c_funptr
;
6731 generate_isocbinding_symbol (iso_c_module_name
,
6732 (iso_c_binding_symbol
) i
,
6734 ? u
->local_name
: u
->use_name
,
6735 tmp_symtree
, false);
6739 if (!found
&& !only_flag
)
6741 /* Skip, if the symbol is not in the enabled standard. */
6744 #define NAMED_FUNCTION(a,b,c,d) \
6746 if ((gfc_option.allow_std & d) == 0) \
6749 #define NAMED_SUBROUTINE(a,b,c,d) \
6751 if ((gfc_option.allow_std & d) == 0) \
6754 #define NAMED_INTCST(a,b,c,d) \
6756 if ((gfc_option.allow_std & d) == 0) \
6759 #define NAMED_REALCST(a,b,c,d) \
6761 if ((gfc_option.allow_std & d) == 0) \
6764 #define NAMED_CMPXCST(a,b,c,d) \
6766 if ((gfc_option.allow_std & d) == 0) \
6769 #include "iso-c-binding.def"
6771 ; /* Not GFC_STD_* versioned. */
6776 #define NAMED_FUNCTION(a,b,c,d) \
6778 if (a == ISOCBINDING_LOC) \
6779 return_type = c_ptr->n.sym; \
6780 else if (a == ISOCBINDING_FUNLOC) \
6781 return_type = c_funptr->n.sym; \
6783 return_type = NULL; \
6784 create_intrinsic_function (b, a, iso_c_module_name, \
6785 INTMOD_ISO_C_BINDING, false, \
6788 #define NAMED_SUBROUTINE(a,b,c,d) \
6790 create_intrinsic_function (b, a, iso_c_module_name, \
6791 INTMOD_ISO_C_BINDING, true, NULL); \
6793 #include "iso-c-binding.def"
6795 case ISOCBINDING_PTR
:
6796 case ISOCBINDING_FUNPTR
:
6797 /* Already handled above. */
6800 if (i
== ISOCBINDING_NULL_PTR
)
6801 tmp_symtree
= c_ptr
;
6802 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6803 tmp_symtree
= c_funptr
;
6806 generate_isocbinding_symbol (iso_c_module_name
,
6807 (iso_c_binding_symbol
) i
, NULL
,
6808 tmp_symtree
, false);
6813 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6818 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6819 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6824 /* Add an integer named constant from a given module. */
6827 create_int_parameter (const char *name
, int value
, const char *modname
,
6828 intmod_id module
, int id
)
6830 gfc_symtree
*tmp_symtree
;
6833 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6834 if (tmp_symtree
!= NULL
)
6836 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6839 gfc_error ("Symbol %qs already declared", name
);
6842 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6843 sym
= tmp_symtree
->n
.sym
;
6845 sym
->module
= gfc_get_string ("%s", modname
);
6846 sym
->attr
.flavor
= FL_PARAMETER
;
6847 sym
->ts
.type
= BT_INTEGER
;
6848 sym
->ts
.kind
= gfc_default_integer_kind
;
6849 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6850 sym
->attr
.use_assoc
= 1;
6851 sym
->from_intmod
= module
;
6852 sym
->intmod_sym_id
= id
;
6856 /* Value is already contained by the array constructor, but not
6860 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6861 const char *modname
, intmod_id module
, int id
)
6863 gfc_symtree
*tmp_symtree
;
6866 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6867 if (tmp_symtree
!= NULL
)
6869 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6872 gfc_error ("Symbol %qs already declared", name
);
6875 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6876 sym
= tmp_symtree
->n
.sym
;
6878 sym
->module
= gfc_get_string ("%s", modname
);
6879 sym
->attr
.flavor
= FL_PARAMETER
;
6880 sym
->ts
.type
= BT_INTEGER
;
6881 sym
->ts
.kind
= gfc_default_integer_kind
;
6882 sym
->attr
.use_assoc
= 1;
6883 sym
->from_intmod
= module
;
6884 sym
->intmod_sym_id
= id
;
6885 sym
->attr
.dimension
= 1;
6886 sym
->as
= gfc_get_array_spec ();
6888 sym
->as
->type
= AS_EXPLICIT
;
6889 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6890 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6893 sym
->value
->shape
= gfc_get_shape (1);
6894 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6898 /* Add an derived type for a given module. */
6901 create_derived_type (const char *name
, const char *modname
,
6902 intmod_id module
, int id
)
6904 gfc_symtree
*tmp_symtree
;
6905 gfc_symbol
*sym
, *dt_sym
;
6906 gfc_interface
*intr
, *head
;
6908 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6909 if (tmp_symtree
!= NULL
)
6911 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6914 gfc_error ("Symbol %qs already declared", name
);
6917 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6918 sym
= tmp_symtree
->n
.sym
;
6919 sym
->module
= gfc_get_string ("%s", modname
);
6920 sym
->from_intmod
= module
;
6921 sym
->intmod_sym_id
= id
;
6922 sym
->attr
.flavor
= FL_PROCEDURE
;
6923 sym
->attr
.function
= 1;
6924 sym
->attr
.generic
= 1;
6926 gfc_get_sym_tree (gfc_dt_upper_string (sym
->name
),
6927 gfc_current_ns
, &tmp_symtree
, false);
6928 dt_sym
= tmp_symtree
->n
.sym
;
6929 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
6930 dt_sym
->attr
.flavor
= FL_DERIVED
;
6931 dt_sym
->attr
.private_comp
= 1;
6932 dt_sym
->attr
.zero_comp
= 1;
6933 dt_sym
->attr
.use_assoc
= 1;
6934 dt_sym
->module
= gfc_get_string ("%s", modname
);
6935 dt_sym
->from_intmod
= module
;
6936 dt_sym
->intmod_sym_id
= id
;
6938 head
= sym
->generic
;
6939 intr
= gfc_get_interface ();
6941 intr
->where
= gfc_current_locus
;
6943 sym
->generic
= intr
;
6944 sym
->attr
.if_source
= IFSRC_DECL
;
6948 /* Read the contents of the module file into a temporary buffer. */
6951 read_module_to_tmpbuf ()
6953 /* We don't know the uncompressed size, so enlarge the buffer as
6959 module_content
= XNEWVEC (char, cursz
);
6963 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6968 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6969 rsize
= cursz
- len
;
6972 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6973 module_content
[len
] = '\0';
6979 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6982 use_iso_fortran_env_module (void)
6984 static char mod
[] = "iso_fortran_env";
6986 gfc_symbol
*mod_sym
;
6987 gfc_symtree
*mod_symtree
;
6991 intmod_sym symbol
[] = {
6992 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6993 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6994 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6995 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6996 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6997 #include "iso-fortran-env.def"
6998 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
7001 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
7002 #include "iso-fortran-env.def"
7004 /* Generate the symbol for the module itself. */
7005 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
7006 if (mod_symtree
== NULL
)
7008 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
7009 gcc_assert (mod_symtree
);
7010 mod_sym
= mod_symtree
->n
.sym
;
7012 mod_sym
->attr
.flavor
= FL_MODULE
;
7013 mod_sym
->attr
.intrinsic
= 1;
7014 mod_sym
->module
= gfc_get_string ("%s", mod
);
7015 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
7018 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
7019 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
7020 "non-intrinsic module name used previously", mod
);
7022 /* Generate the symbols for the module integer named constants. */
7024 for (i
= 0; symbol
[i
].name
; i
++)
7027 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7029 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
7034 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
7035 "referenced at %L, is not in the selected "
7036 "standard", symbol
[i
].name
, &u
->where
))
7039 if ((flag_default_integer
|| flag_default_real_8
)
7040 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7041 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
7042 "constant from intrinsic module "
7043 "ISO_FORTRAN_ENV at %L is incompatible with "
7044 "option %qs", &u
->where
,
7045 flag_default_integer
7046 ? "-fdefault-integer-8"
7047 : "-fdefault-real-8");
7048 switch (symbol
[i
].id
)
7050 #define NAMED_INTCST(a,b,c,d) \
7052 #include "iso-fortran-env.def"
7053 create_int_parameter (u
->local_name
[0] ? u
->local_name
7055 symbol
[i
].value
, mod
,
7056 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7059 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7061 expr = gfc_get_array_expr (BT_INTEGER, \
7062 gfc_default_integer_kind,\
7064 for (j = 0; KINDS[j].kind != 0; j++) \
7065 gfc_constructor_append_expr (&expr->value.constructor, \
7066 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7067 KINDS[j].kind), NULL); \
7068 create_int_parameter_array (u->local_name[0] ? u->local_name \
7071 INTMOD_ISO_FORTRAN_ENV, \
7074 #include "iso-fortran-env.def"
7076 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7078 #include "iso-fortran-env.def"
7079 create_derived_type (u
->local_name
[0] ? u
->local_name
7081 mod
, INTMOD_ISO_FORTRAN_ENV
,
7085 #define NAMED_FUNCTION(a,b,c,d) \
7087 #include "iso-fortran-env.def"
7088 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
7091 INTMOD_ISO_FORTRAN_ENV
, false,
7101 if (!found
&& !only_flag
)
7103 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
7106 if ((flag_default_integer
|| flag_default_real_8
)
7107 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
7109 "Use of the NUMERIC_STORAGE_SIZE named constant "
7110 "from intrinsic module ISO_FORTRAN_ENV at %C is "
7111 "incompatible with option %s",
7112 flag_default_integer
7113 ? "-fdefault-integer-8" : "-fdefault-real-8");
7115 switch (symbol
[i
].id
)
7117 #define NAMED_INTCST(a,b,c,d) \
7119 #include "iso-fortran-env.def"
7120 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
7121 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
7124 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7126 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
7128 for (j = 0; KINDS[j].kind != 0; j++) \
7129 gfc_constructor_append_expr (&expr->value.constructor, \
7130 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7131 KINDS[j].kind), NULL); \
7132 create_int_parameter_array (symbol[i].name, j, expr, mod, \
7133 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7135 #include "iso-fortran-env.def"
7137 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7139 #include "iso-fortran-env.def"
7140 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
7144 #define NAMED_FUNCTION(a,b,c,d) \
7146 #include "iso-fortran-env.def"
7147 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
7148 INTMOD_ISO_FORTRAN_ENV
, false,
7158 for (u
= gfc_rename_list
; u
; u
= u
->next
)
7163 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7164 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
7169 /* Process a USE directive. */
7172 gfc_use_module (gfc_use_list
*module
)
7177 gfc_symtree
*mod_symtree
;
7178 gfc_use_list
*use_stmt
;
7179 locus old_locus
= gfc_current_locus
;
7181 gfc_current_locus
= module
->where
;
7182 module_name
= module
->module_name
;
7183 gfc_rename_list
= module
->rename
;
7184 only_flag
= module
->only_flag
;
7185 current_intmod
= INTMOD_NONE
;
7188 gfc_warning_now (OPT_Wuse_without_only
,
7189 "USE statement at %C has no ONLY qualifier");
7191 if (gfc_state_stack
->state
== COMP_MODULE
7192 || module
->submodule_name
== NULL
)
7194 filename
= XALLOCAVEC (char, strlen (module_name
)
7195 + strlen (MODULE_EXTENSION
) + 1);
7196 strcpy (filename
, module_name
);
7197 strcat (filename
, MODULE_EXTENSION
);
7201 filename
= XALLOCAVEC (char, strlen (module
->submodule_name
)
7202 + strlen (SUBMODULE_EXTENSION
) + 1);
7203 strcpy (filename
, module
->submodule_name
);
7204 strcat (filename
, SUBMODULE_EXTENSION
);
7207 /* First, try to find an non-intrinsic module, unless the USE statement
7208 specified that the module is intrinsic. */
7210 if (!module
->intrinsic
)
7211 module_fp
= gzopen_included_file (filename
, true, true);
7213 /* Then, see if it's an intrinsic one, unless the USE statement
7214 specified that the module is non-intrinsic. */
7215 if (module_fp
== NULL
&& !module
->non_intrinsic
)
7217 if (strcmp (module_name
, "iso_fortran_env") == 0
7218 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
7219 "intrinsic module at %C"))
7221 use_iso_fortran_env_module ();
7222 free_rename (module
->rename
);
7223 module
->rename
= NULL
;
7224 gfc_current_locus
= old_locus
;
7225 module
->intrinsic
= true;
7229 if (strcmp (module_name
, "iso_c_binding") == 0
7230 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
7232 import_iso_c_binding_module();
7233 free_rename (module
->rename
);
7234 module
->rename
= NULL
;
7235 gfc_current_locus
= old_locus
;
7236 module
->intrinsic
= true;
7240 module_fp
= gzopen_intrinsic_module (filename
);
7242 if (module_fp
== NULL
&& module
->intrinsic
)
7243 gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7246 /* Check for the IEEE modules, so we can mark their symbols
7247 accordingly when we read them. */
7248 if (strcmp (module_name
, "ieee_features") == 0
7249 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
7251 current_intmod
= INTMOD_IEEE_FEATURES
;
7253 else if (strcmp (module_name
, "ieee_exceptions") == 0
7254 && gfc_notify_std (GFC_STD_F2003
,
7255 "IEEE_EXCEPTIONS module at %C"))
7257 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
7259 else if (strcmp (module_name
, "ieee_arithmetic") == 0
7260 && gfc_notify_std (GFC_STD_F2003
,
7261 "IEEE_ARITHMETIC module at %C"))
7263 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
7267 if (module_fp
== NULL
)
7269 if (gfc_state_stack
->state
!= COMP_SUBMODULE
7270 && module
->submodule_name
== NULL
)
7271 gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7272 filename
, xstrerror (errno
));
7274 gfc_fatal_error ("Module file %qs has not been generated, either "
7275 "because the module does not contain a MODULE "
7276 "PROCEDURE or there is an error in the module.",
7280 /* Check that we haven't already USEd an intrinsic module with the
7283 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
7284 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
7285 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7286 "intrinsic module name used previously", module_name
);
7293 read_module_to_tmpbuf ();
7294 gzclose (module_fp
);
7296 /* Skip the first line of the module, after checking that this is
7297 a gfortran module file. */
7303 bad_module ("Unexpected end of module");
7306 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
7307 || (start
== 2 && strcmp (atom_name
, " module") != 0))
7308 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7309 " module file", module_fullpath
);
7312 if (strcmp (atom_name
, " version") != 0
7313 || module_char () != ' '
7314 || parse_atom () != ATOM_STRING
7315 || strcmp (atom_string
, MOD_VERSION
))
7316 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7317 " because it was created by a different"
7318 " version of GNU Fortran", module_fullpath
);
7327 /* Make sure we're not reading the same module that we may be building. */
7328 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
7329 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
7330 && strcmp (p
->sym
->name
, module_name
) == 0)
7332 if (p
->state
== COMP_SUBMODULE
)
7333 gfc_fatal_error ("Cannot USE a submodule that is currently built");
7335 gfc_fatal_error ("Cannot USE a module that is currently built");
7339 init_true_name_tree ();
7343 free_true_name (true_name_root
);
7344 true_name_root
= NULL
;
7346 free_pi_tree (pi_root
);
7349 XDELETEVEC (module_content
);
7350 module_content
= NULL
;
7352 use_stmt
= gfc_get_use_list ();
7353 *use_stmt
= *module
;
7354 use_stmt
->next
= gfc_current_ns
->use_stmts
;
7355 gfc_current_ns
->use_stmts
= use_stmt
;
7357 gfc_current_locus
= old_locus
;
7361 /* Remove duplicated intrinsic operators from the rename list. */
7364 rename_list_remove_duplicate (gfc_use_rename
*list
)
7366 gfc_use_rename
*seek
, *last
;
7368 for (; list
; list
= list
->next
)
7369 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
7372 for (seek
= list
->next
; seek
; seek
= last
->next
)
7374 if (list
->op
== seek
->op
)
7376 last
->next
= seek
->next
;
7386 /* Process all USE directives. */
7389 gfc_use_modules (void)
7391 gfc_use_list
*next
, *seek
, *last
;
7393 for (next
= module_list
; next
; next
= next
->next
)
7395 bool non_intrinsic
= next
->non_intrinsic
;
7396 bool intrinsic
= next
->intrinsic
;
7397 bool neither
= !non_intrinsic
&& !intrinsic
;
7399 for (seek
= next
->next
; seek
; seek
= seek
->next
)
7401 if (next
->module_name
!= seek
->module_name
)
7404 if (seek
->non_intrinsic
)
7405 non_intrinsic
= true;
7406 else if (seek
->intrinsic
)
7412 if (intrinsic
&& neither
&& !non_intrinsic
)
7417 filename
= XALLOCAVEC (char,
7418 strlen (next
->module_name
)
7419 + strlen (MODULE_EXTENSION
) + 1);
7420 strcpy (filename
, next
->module_name
);
7421 strcat (filename
, MODULE_EXTENSION
);
7422 fp
= gfc_open_included_file (filename
, true, true);
7425 non_intrinsic
= true;
7431 for (seek
= next
->next
; seek
; seek
= last
->next
)
7433 if (next
->module_name
!= seek
->module_name
)
7439 if ((!next
->intrinsic
&& !seek
->intrinsic
)
7440 || (next
->intrinsic
&& seek
->intrinsic
)
7443 if (!seek
->only_flag
)
7444 next
->only_flag
= false;
7447 gfc_use_rename
*r
= seek
->rename
;
7450 r
->next
= next
->rename
;
7451 next
->rename
= seek
->rename
;
7453 last
->next
= seek
->next
;
7461 for (; module_list
; module_list
= next
)
7463 next
= module_list
->next
;
7464 rename_list_remove_duplicate (module_list
->rename
);
7465 gfc_use_module (module_list
);
7468 gfc_rename_list
= NULL
;
7473 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
7476 for (; use_stmts
; use_stmts
= next
)
7478 gfc_use_rename
*next_rename
;
7480 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
7482 next_rename
= use_stmts
->rename
->next
;
7483 free (use_stmts
->rename
);
7485 next
= use_stmts
->next
;
7492 gfc_module_init_2 (void)
7494 last_atom
= ATOM_LPAREN
;
7495 gfc_rename_list
= NULL
;
7501 gfc_module_done_2 (void)
7503 free_rename (gfc_rename_list
);
7504 gfc_rename_list
= NULL
;