1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2015 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 sequence of atoms, which can be left or right parenthesis, names,
24 integers or strings. Parenthesis are always matched which allows
25 us to skip over sections at high speed without having to know
26 anything about the internal structure of the lists. A "name" is
27 usually a fortran 95 identifier, but can also start with '@' in
28 order to reference a hidden symbol.
30 The first line of a module is an informational message about what
31 created the module, the file it came from and when it was created.
32 The second line is a warning for people not to edit the module.
33 The rest of the module looks like:
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ( ( <common name> <symbol> <saved flag>)
51 ( <Symbol Number (in no particular order)>
53 <Module name of symbol>
54 ( <symbol information> )
63 In general, symbols refer to other symbols by their symbol number,
64 which are zero based. Symbols are written to the module in no
69 #include "coretypes.h"
73 #include "parse.h" /* FIXME */
74 #include "constructor.h"
80 #include "stringpool.h"
84 #define MODULE_EXTENSION ".mod"
86 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
88 #define MOD_VERSION "14"
91 /* Structure that describes a position within a module file. */
100 /* Structure for list of symbols of intrinsic modules. */
113 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
117 /* The fixup structure lists pointers to pointers that have to
118 be updated when a pointer value becomes known. */
120 typedef struct fixup_t
123 struct fixup_t
*next
;
128 /* Structure for holding extra info needed for pointers being read. */
144 typedef struct pointer_info
146 BBT_HEADER (pointer_info
);
150 /* The first component of each member of the union is the pointer
157 void *pointer
; /* Member for doing pointer searches. */
162 char *true_name
, *module
, *binding_label
;
164 gfc_symtree
*symtree
;
165 enum gfc_rsym_state state
;
166 int ns
, referenced
, renamed
;
174 enum gfc_wsym_state state
;
183 #define gfc_get_pointer_info() XCNEW (pointer_info)
186 /* Local variables */
188 /* The gzFile for the module we're reading or writing. */
189 static gzFile module_fp
;
192 /* The name of the module we're reading (USE'ing) or writing. */
193 static const char *module_name
;
194 static gfc_use_list
*module_list
;
196 /* If we're reading an intrinsic module, this is its ID. */
197 static intmod_id current_intmod
;
199 /* Content of module. */
200 static char* module_content
;
202 static long module_pos
;
203 static int module_line
, module_column
, only_flag
;
204 static int prev_module_line
, prev_module_column
;
207 { IO_INPUT
, IO_OUTPUT
}
210 static gfc_use_rename
*gfc_rename_list
;
211 static pointer_info
*pi_root
;
212 static int symbol_number
; /* Counter for assigning symbol numbers */
214 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
215 static bool in_load_equiv
;
219 /*****************************************************************/
221 /* Pointer/integer conversion. Pointers between structures are stored
222 as integers in the module file. The next couple of subroutines
223 handle this translation for reading and writing. */
225 /* Recursively free the tree of pointer structures. */
228 free_pi_tree (pointer_info
*p
)
233 if (p
->fixup
!= NULL
)
234 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
236 free_pi_tree (p
->left
);
237 free_pi_tree (p
->right
);
239 if (iomode
== IO_INPUT
)
241 XDELETEVEC (p
->u
.rsym
.true_name
);
242 XDELETEVEC (p
->u
.rsym
.module
);
243 XDELETEVEC (p
->u
.rsym
.binding_label
);
250 /* Compare pointers when searching by pointer. Used when writing a
254 compare_pointers (void *_sn1
, void *_sn2
)
256 pointer_info
*sn1
, *sn2
;
258 sn1
= (pointer_info
*) _sn1
;
259 sn2
= (pointer_info
*) _sn2
;
261 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
263 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
270 /* Compare integers when searching by integer. Used when reading a
274 compare_integers (void *_sn1
, void *_sn2
)
276 pointer_info
*sn1
, *sn2
;
278 sn1
= (pointer_info
*) _sn1
;
279 sn2
= (pointer_info
*) _sn2
;
281 if (sn1
->integer
< sn2
->integer
)
283 if (sn1
->integer
> sn2
->integer
)
290 /* Initialize the pointer_info tree. */
299 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
301 /* Pointer 0 is the NULL pointer. */
302 p
= gfc_get_pointer_info ();
307 gfc_insert_bbt (&pi_root
, p
, compare
);
309 /* Pointer 1 is the current namespace. */
310 p
= gfc_get_pointer_info ();
311 p
->u
.pointer
= gfc_current_ns
;
313 p
->type
= P_NAMESPACE
;
315 gfc_insert_bbt (&pi_root
, p
, compare
);
321 /* During module writing, call here with a pointer to something,
322 returning the pointer_info node. */
324 static pointer_info
*
325 find_pointer (void *gp
)
332 if (p
->u
.pointer
== gp
)
334 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
341 /* Given a pointer while writing, returns the pointer_info tree node,
342 creating it if it doesn't exist. */
344 static pointer_info
*
345 get_pointer (void *gp
)
349 p
= find_pointer (gp
);
353 /* Pointer doesn't have an integer. Give it one. */
354 p
= gfc_get_pointer_info ();
357 p
->integer
= symbol_number
++;
359 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
365 /* Given an integer during reading, find it in the pointer_info tree,
366 creating the node if not found. */
368 static pointer_info
*
369 get_integer (int integer
)
379 c
= compare_integers (&t
, p
);
383 p
= (c
< 0) ? p
->left
: p
->right
;
389 p
= gfc_get_pointer_info ();
390 p
->integer
= integer
;
393 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
399 /* Resolve any fixups using a known pointer. */
402 resolve_fixups (fixup_t
*f
, void *gp
)
415 /* Convert a string such that it starts with a lower-case character. Used
416 to convert the symtree name of a derived-type to the symbol name or to
417 the name of the associated generic function. */
420 dt_lower_string (const char *name
)
422 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
423 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
425 return gfc_get_string (name
);
429 /* Convert a string such that it starts with an upper-case character. Used to
430 return the symtree-name for a derived type; the symbol name itself and the
431 symtree/symbol name of the associated generic function start with a lower-
435 dt_upper_string (const char *name
)
437 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
438 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
440 return gfc_get_string (name
);
443 /* Call here during module reading when we know what pointer to
444 associate with an integer. Any fixups that exist are resolved at
448 associate_integer_pointer (pointer_info
*p
, void *gp
)
450 if (p
->u
.pointer
!= NULL
)
451 gfc_internal_error ("associate_integer_pointer(): Already associated");
455 resolve_fixups (p
->fixup
, gp
);
461 /* During module reading, given an integer and a pointer to a pointer,
462 either store the pointer from an already-known value or create a
463 fixup structure in order to store things later. Returns zero if
464 the reference has been actually stored, or nonzero if the reference
465 must be fixed later (i.e., associate_integer_pointer must be called
466 sometime later. Returns the pointer_info structure. */
468 static pointer_info
*
469 add_fixup (int integer
, void *gp
)
475 p
= get_integer (integer
);
477 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
480 *cp
= (char *) p
->u
.pointer
;
489 f
->pointer
= (void **) gp
;
496 /*****************************************************************/
498 /* Parser related subroutines */
500 /* Free the rename list left behind by a USE statement. */
503 free_rename (gfc_use_rename
*list
)
505 gfc_use_rename
*next
;
507 for (; list
; list
= next
)
515 /* Match a USE statement. */
520 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
521 gfc_use_rename
*tail
= NULL
, *new_use
;
522 interface_type type
, type2
;
525 gfc_use_list
*use_list
;
527 use_list
= gfc_get_use_list ();
529 if (gfc_match (" , ") == MATCH_YES
)
531 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
533 if (!gfc_notify_std (GFC_STD_F2003
, "module "
534 "nature in USE statement at %C"))
537 if (strcmp (module_nature
, "intrinsic") == 0)
538 use_list
->intrinsic
= true;
541 if (strcmp (module_nature
, "non_intrinsic") == 0)
542 use_list
->non_intrinsic
= true;
545 gfc_error ("Module nature in USE statement at %C shall "
546 "be either INTRINSIC or NON_INTRINSIC");
553 /* Help output a better error message than "Unclassifiable
555 gfc_match (" %n", module_nature
);
556 if (strcmp (module_nature
, "intrinsic") == 0
557 || strcmp (module_nature
, "non_intrinsic") == 0)
558 gfc_error ("\"::\" was expected after module nature at %C "
559 "but was not found");
566 m
= gfc_match (" ::");
567 if (m
== MATCH_YES
&&
568 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
573 m
= gfc_match ("% ");
582 use_list
->where
= gfc_current_locus
;
584 m
= gfc_match_name (name
);
591 use_list
->module_name
= gfc_get_string (name
);
593 if (gfc_match_eos () == MATCH_YES
)
596 if (gfc_match_char (',') != MATCH_YES
)
599 if (gfc_match (" only :") == MATCH_YES
)
600 use_list
->only_flag
= true;
602 if (gfc_match_eos () == MATCH_YES
)
607 /* Get a new rename struct and add it to the rename list. */
608 new_use
= gfc_get_use_rename ();
609 new_use
->where
= gfc_current_locus
;
612 if (use_list
->rename
== NULL
)
613 use_list
->rename
= new_use
;
615 tail
->next
= new_use
;
618 /* See what kind of interface we're dealing with. Assume it is
620 new_use
->op
= INTRINSIC_NONE
;
621 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
626 case INTERFACE_NAMELESS
:
627 gfc_error ("Missing generic specification in USE statement at %C");
630 case INTERFACE_USER_OP
:
631 case INTERFACE_GENERIC
:
632 m
= gfc_match (" =>");
634 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
635 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
636 "operators in USE statements at %C")))
639 if (type
== INTERFACE_USER_OP
)
640 new_use
->op
= INTRINSIC_USER
;
642 if (use_list
->only_flag
)
645 strcpy (new_use
->use_name
, name
);
648 strcpy (new_use
->local_name
, name
);
649 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
654 if (m
== MATCH_ERROR
)
662 strcpy (new_use
->local_name
, name
);
664 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
669 if (m
== MATCH_ERROR
)
673 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
674 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
676 gfc_error ("The name %qs at %C has already been used as "
677 "an external module name.", use_list
->module_name
);
682 case INTERFACE_INTRINSIC_OP
:
690 if (gfc_match_eos () == MATCH_YES
)
692 if (gfc_match_char (',') != MATCH_YES
)
699 gfc_use_list
*last
= module_list
;
702 last
->next
= use_list
;
705 module_list
= use_list
;
710 gfc_syntax_error (ST_USE
);
713 free_rename (use_list
->rename
);
719 /* Match a SUBMODULE statement. */
722 gfc_match_submodule (void)
725 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
726 gfc_use_list
*use_list
;
728 if (!gfc_notify_std (GFC_STD_F2008
, "SUBMODULE declaration at %C"))
731 gfc_new_block
= NULL
;
732 gcc_assert (module_list
== NULL
);
734 if (gfc_match_char ('(') != MATCH_YES
)
739 m
= gfc_match (" %n", name
);
743 use_list
= gfc_get_use_list ();
744 use_list
->module_name
= gfc_get_string (name
);
745 use_list
->where
= gfc_current_locus
;
749 gfc_use_list
*last
= module_list
;
752 last
->next
= use_list
;
755 module_list
= use_list
;
757 if (gfc_match_char (')') == MATCH_YES
)
760 if (gfc_match_char (':') != MATCH_YES
)
764 m
= gfc_match (" %s%t", &gfc_new_block
);
768 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
769 gfc_new_block
->name
, NULL
))
775 gfc_error ("Syntax error in SUBMODULE statement at %C");
780 /* Given a name and a number, inst, return the inst name
781 under which to load this symbol. Returns NULL if this
782 symbol shouldn't be loaded. If inst is zero, returns
783 the number of instances of this name. If interface is
784 true, a user-defined operator is sought, otherwise only
785 non-operators are sought. */
788 find_use_name_n (const char *name
, int *inst
, bool interface
)
791 const char *low_name
= NULL
;
794 /* For derived types. */
795 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
796 low_name
= dt_lower_string (name
);
799 for (u
= gfc_rename_list
; u
; u
= u
->next
)
801 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
802 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
803 || (u
->op
== INTRINSIC_USER
&& !interface
)
804 || (u
->op
!= INTRINSIC_USER
&& interface
))
817 return only_flag
? NULL
: name
;
823 if (u
->local_name
[0] == '\0')
825 return dt_upper_string (u
->local_name
);
828 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
832 /* Given a name, return the name under which to load this symbol.
833 Returns NULL if this symbol shouldn't be loaded. */
836 find_use_name (const char *name
, bool interface
)
839 return find_use_name_n (name
, &i
, interface
);
843 /* Given a real name, return the number of use names associated with it. */
846 number_use_names (const char *name
, bool interface
)
849 find_use_name_n (name
, &i
, interface
);
854 /* Try to find the operator in the current list. */
856 static gfc_use_rename
*
857 find_use_operator (gfc_intrinsic_op op
)
861 for (u
= gfc_rename_list
; u
; u
= u
->next
)
869 /*****************************************************************/
871 /* The next couple of subroutines maintain a tree used to avoid a
872 brute-force search for a combination of true name and module name.
873 While symtree names, the name that a particular symbol is known by
874 can changed with USE statements, we still have to keep track of the
875 true names to generate the correct reference, and also avoid
876 loading the same real symbol twice in a program unit.
878 When we start reading, the true name tree is built and maintained
879 as symbols are read. The tree is searched as we load new symbols
880 to see if it already exists someplace in the namespace. */
882 typedef struct true_name
884 BBT_HEADER (true_name
);
890 static true_name
*true_name_root
;
893 /* Compare two true_name structures. */
896 compare_true_names (void *_t1
, void *_t2
)
901 t1
= (true_name
*) _t1
;
902 t2
= (true_name
*) _t2
;
904 c
= ((t1
->sym
->module
> t2
->sym
->module
)
905 - (t1
->sym
->module
< t2
->sym
->module
));
909 return strcmp (t1
->name
, t2
->name
);
913 /* Given a true name, search the true name tree to see if it exists
914 within the main namespace. */
917 find_true_name (const char *name
, const char *module
)
923 t
.name
= gfc_get_string (name
);
925 sym
.module
= gfc_get_string (module
);
933 c
= compare_true_names ((void *) (&t
), (void *) p
);
937 p
= (c
< 0) ? p
->left
: p
->right
;
944 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
947 add_true_name (gfc_symbol
*sym
)
951 t
= XCNEW (true_name
);
953 if (sym
->attr
.flavor
== FL_DERIVED
)
954 t
->name
= dt_upper_string (sym
->name
);
958 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
962 /* Recursive function to build the initial true name tree by
963 recursively traversing the current namespace. */
966 build_tnt (gfc_symtree
*st
)
972 build_tnt (st
->left
);
973 build_tnt (st
->right
);
975 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
976 name
= dt_upper_string (st
->n
.sym
->name
);
978 name
= st
->n
.sym
->name
;
980 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
983 add_true_name (st
->n
.sym
);
987 /* Initialize the true name tree with the current namespace. */
990 init_true_name_tree (void)
992 true_name_root
= NULL
;
993 build_tnt (gfc_current_ns
->sym_root
);
997 /* Recursively free a true name tree node. */
1000 free_true_name (true_name
*t
)
1004 free_true_name (t
->left
);
1005 free_true_name (t
->right
);
1011 /*****************************************************************/
1013 /* Module reading and writing. */
1015 /* The following are versions similar to the ones in scanner.c, but
1016 for dealing with compressed module files. */
1019 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
1020 bool module
, bool system
)
1023 gfc_directorylist
*p
;
1026 for (p
= list
; p
; p
= p
->next
)
1028 if (module
&& !p
->use_for_modules
)
1031 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
1032 strcpy (fullname
, p
->path
);
1033 strcat (fullname
, name
);
1035 f
= gzopen (fullname
, "r");
1038 if (gfc_cpp_makedep ())
1039 gfc_cpp_add_dep (fullname
, system
);
1049 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
1053 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
1055 f
= gzopen (name
, "r");
1056 if (f
&& gfc_cpp_makedep ())
1057 gfc_cpp_add_dep (name
, false);
1061 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1067 gzopen_intrinsic_module (const char* name
)
1071 if (IS_ABSOLUTE_PATH (name
))
1073 f
= gzopen (name
, "r");
1074 if (f
&& gfc_cpp_makedep ())
1075 gfc_cpp_add_dep (name
, true);
1079 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1087 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1091 static atom_type last_atom
;
1094 /* The name buffer must be at least as long as a symbol name. Right
1095 now it's not clear how we're going to store numeric constants--
1096 probably as a hexadecimal string, since this will allow the exact
1097 number to be preserved (this can't be done by a decimal
1098 representation). Worry about that later. TODO! */
1100 #define MAX_ATOM_SIZE 100
1102 static int atom_int
;
1103 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1106 /* Report problems with a module. Error reporting is not very
1107 elaborate, since this sorts of errors shouldn't really happen.
1108 This subroutine never returns. */
1110 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1113 bad_module (const char *msgid
)
1115 XDELETEVEC (module_content
);
1116 module_content
= NULL
;
1121 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1122 module_name
, module_line
, module_column
, msgid
);
1125 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1126 module_name
, module_line
, module_column
, msgid
);
1129 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1130 module_name
, module_line
, module_column
, msgid
);
1136 /* Set the module's input pointer. */
1139 set_module_locus (module_locus
*m
)
1141 module_column
= m
->column
;
1142 module_line
= m
->line
;
1143 module_pos
= m
->pos
;
1147 /* Get the module's input pointer so that we can restore it later. */
1150 get_module_locus (module_locus
*m
)
1152 m
->column
= module_column
;
1153 m
->line
= module_line
;
1154 m
->pos
= module_pos
;
1158 /* Get the next character in the module, updating our reckoning of
1164 const char c
= module_content
[module_pos
++];
1166 bad_module ("Unexpected EOF");
1168 prev_module_line
= module_line
;
1169 prev_module_column
= module_column
;
1181 /* Unget a character while remembering the line and column. Works for
1182 a single character only. */
1185 module_unget_char (void)
1187 module_line
= prev_module_line
;
1188 module_column
= prev_module_column
;
1192 /* Parse a string constant. The delimiter is guaranteed to be a
1202 atom_string
= XNEWVEC (char, cursz
);
1210 int c2
= module_char ();
1213 module_unget_char ();
1221 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1223 atom_string
[len
] = c
;
1227 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1228 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1232 /* Parse a small integer. */
1235 parse_integer (int c
)
1244 module_unget_char ();
1248 atom_int
= 10 * atom_int
+ c
- '0';
1249 if (atom_int
> 99999999)
1250 bad_module ("Integer overflow");
1272 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1274 module_unget_char ();
1279 if (++len
> GFC_MAX_SYMBOL_LEN
)
1280 bad_module ("Name too long");
1288 /* Read the next atom in the module's input stream. */
1299 while (c
== ' ' || c
== '\r' || c
== '\n');
1324 return ATOM_INTEGER
;
1382 bad_module ("Bad name");
1389 /* Peek at the next atom on the input. */
1400 while (c
== ' ' || c
== '\r' || c
== '\n');
1405 module_unget_char ();
1409 module_unget_char ();
1413 module_unget_char ();
1426 module_unget_char ();
1427 return ATOM_INTEGER
;
1481 module_unget_char ();
1485 bad_module ("Bad name");
1490 /* Read the next atom from the input, requiring that it be a
1494 require_atom (atom_type type
)
1500 column
= module_column
;
1509 p
= _("Expected name");
1512 p
= _("Expected left parenthesis");
1515 p
= _("Expected right parenthesis");
1518 p
= _("Expected integer");
1521 p
= _("Expected string");
1524 gfc_internal_error ("require_atom(): bad atom type required");
1527 module_column
= column
;
1534 /* Given a pointer to an mstring array, require that the current input
1535 be one of the strings in the array. We return the enum value. */
1538 find_enum (const mstring
*m
)
1542 i
= gfc_string2code (m
, atom_name
);
1546 bad_module ("find_enum(): Enum not found");
1552 /* Read a string. The caller is responsible for freeing. */
1558 require_atom (ATOM_STRING
);
1565 /**************** Module output subroutines ***************************/
1567 /* Output a character to a module file. */
1570 write_char (char out
)
1572 if (gzputc (module_fp
, out
) == EOF
)
1573 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1585 /* Write an atom to a module. The line wrapping isn't perfect, but it
1586 should work most of the time. This isn't that big of a deal, since
1587 the file really isn't meant to be read by people anyway. */
1590 write_atom (atom_type atom
, const void *v
)
1594 /* Workaround -Wmaybe-uninitialized false positive during
1595 profiledbootstrap by initializing them. */
1603 p
= (const char *) v
;
1615 i
= *((const int *) v
);
1617 gfc_internal_error ("write_atom(): Writing negative integer");
1619 sprintf (buffer
, "%d", i
);
1624 gfc_internal_error ("write_atom(): Trying to write dab atom");
1628 if(p
== NULL
|| *p
== '\0')
1633 if (atom
!= ATOM_RPAREN
)
1635 if (module_column
+ len
> 72)
1640 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1645 if (atom
== ATOM_STRING
)
1648 while (p
!= NULL
&& *p
)
1650 if (atom
== ATOM_STRING
&& *p
== '\'')
1655 if (atom
== ATOM_STRING
)
1663 /***************** Mid-level I/O subroutines *****************/
1665 /* These subroutines let their caller read or write atoms without
1666 caring about which of the two is actually happening. This lets a
1667 subroutine concentrate on the actual format of the data being
1670 static void mio_expr (gfc_expr
**);
1671 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1672 pointer_info
*mio_interface_rest (gfc_interface
**);
1673 static void mio_symtree_ref (gfc_symtree
**);
1675 /* Read or write an enumerated value. On writing, we return the input
1676 value for the convenience of callers. We avoid using an integer
1677 pointer because enums are sometimes inside bitfields. */
1680 mio_name (int t
, const mstring
*m
)
1682 if (iomode
== IO_OUTPUT
)
1683 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1686 require_atom (ATOM_NAME
);
1693 /* Specialization of mio_name. */
1695 #define DECL_MIO_NAME(TYPE) \
1696 static inline TYPE \
1697 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1699 return (TYPE) mio_name ((int) t, m); \
1701 #define MIO_NAME(TYPE) mio_name_##TYPE
1706 if (iomode
== IO_OUTPUT
)
1707 write_atom (ATOM_LPAREN
, NULL
);
1709 require_atom (ATOM_LPAREN
);
1716 if (iomode
== IO_OUTPUT
)
1717 write_atom (ATOM_RPAREN
, NULL
);
1719 require_atom (ATOM_RPAREN
);
1724 mio_integer (int *ip
)
1726 if (iomode
== IO_OUTPUT
)
1727 write_atom (ATOM_INTEGER
, ip
);
1730 require_atom (ATOM_INTEGER
);
1736 /* Read or write a gfc_intrinsic_op value. */
1739 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1741 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1742 if (iomode
== IO_OUTPUT
)
1744 int converted
= (int) *op
;
1745 write_atom (ATOM_INTEGER
, &converted
);
1749 require_atom (ATOM_INTEGER
);
1750 *op
= (gfc_intrinsic_op
) atom_int
;
1755 /* Read or write a character pointer that points to a string on the heap. */
1758 mio_allocated_string (const char *s
)
1760 if (iomode
== IO_OUTPUT
)
1762 write_atom (ATOM_STRING
, s
);
1767 require_atom (ATOM_STRING
);
1773 /* Functions for quoting and unquoting strings. */
1776 quote_string (const gfc_char_t
*s
, const size_t slength
)
1778 const gfc_char_t
*p
;
1782 /* Calculate the length we'll need: a backslash takes two ("\\"),
1783 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1784 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1788 else if (!gfc_wide_is_printable (*p
))
1794 q
= res
= XCNEWVEC (char, len
+ 1);
1795 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1798 *q
++ = '\\', *q
++ = '\\';
1799 else if (!gfc_wide_is_printable (*p
))
1801 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1802 (unsigned HOST_WIDE_INT
) *p
);
1806 *q
++ = (unsigned char) *p
;
1814 unquote_string (const char *s
)
1820 for (p
= s
, len
= 0; *p
; p
++, len
++)
1827 else if (p
[1] == 'U')
1828 p
+= 9; /* That is a "\U????????". */
1830 gfc_internal_error ("unquote_string(): got bad string");
1833 res
= gfc_get_wide_string (len
+ 1);
1834 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1839 res
[i
] = (unsigned char) *p
;
1840 else if (p
[1] == '\\')
1842 res
[i
] = (unsigned char) '\\';
1847 /* We read the 8-digits hexadecimal constant that follows. */
1852 gcc_assert (p
[1] == 'U');
1853 for (j
= 0; j
< 8; j
++)
1856 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1870 /* Read or write a character pointer that points to a wide string on the
1871 heap, performing quoting/unquoting of nonprintable characters using the
1872 form \U???????? (where each ? is a hexadecimal digit).
1873 Length is the length of the string, only known and used in output mode. */
1875 static const gfc_char_t
*
1876 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1878 if (iomode
== IO_OUTPUT
)
1880 char *quoted
= quote_string (s
, length
);
1881 write_atom (ATOM_STRING
, quoted
);
1887 gfc_char_t
*unquoted
;
1889 require_atom (ATOM_STRING
);
1890 unquoted
= unquote_string (atom_string
);
1897 /* Read or write a string that is in static memory. */
1900 mio_pool_string (const char **stringp
)
1902 /* TODO: one could write the string only once, and refer to it via a
1905 /* As a special case we have to deal with a NULL string. This
1906 happens for the 'module' member of 'gfc_symbol's that are not in a
1907 module. We read / write these as the empty string. */
1908 if (iomode
== IO_OUTPUT
)
1910 const char *p
= *stringp
== NULL
? "" : *stringp
;
1911 write_atom (ATOM_STRING
, p
);
1915 require_atom (ATOM_STRING
);
1916 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1922 /* Read or write a string that is inside of some already-allocated
1926 mio_internal_string (char *string
)
1928 if (iomode
== IO_OUTPUT
)
1929 write_atom (ATOM_STRING
, string
);
1932 require_atom (ATOM_STRING
);
1933 strcpy (string
, atom_string
);
1940 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1941 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1942 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1943 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1944 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1945 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1946 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1947 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1948 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1949 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1950 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
1951 AB_ARRAY_OUTER_DEPENDENCY
, AB_MODULE_PROCEDURE
1955 static const mstring attr_bits
[] =
1957 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1958 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1959 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1960 minit ("DIMENSION", AB_DIMENSION
),
1961 minit ("CODIMENSION", AB_CODIMENSION
),
1962 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1963 minit ("EXTERNAL", AB_EXTERNAL
),
1964 minit ("INTRINSIC", AB_INTRINSIC
),
1965 minit ("OPTIONAL", AB_OPTIONAL
),
1966 minit ("POINTER", AB_POINTER
),
1967 minit ("VOLATILE", AB_VOLATILE
),
1968 minit ("TARGET", AB_TARGET
),
1969 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1970 minit ("DUMMY", AB_DUMMY
),
1971 minit ("RESULT", AB_RESULT
),
1972 minit ("DATA", AB_DATA
),
1973 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1974 minit ("IN_COMMON", AB_IN_COMMON
),
1975 minit ("FUNCTION", AB_FUNCTION
),
1976 minit ("SUBROUTINE", AB_SUBROUTINE
),
1977 minit ("SEQUENCE", AB_SEQUENCE
),
1978 minit ("ELEMENTAL", AB_ELEMENTAL
),
1979 minit ("PURE", AB_PURE
),
1980 minit ("RECURSIVE", AB_RECURSIVE
),
1981 minit ("GENERIC", AB_GENERIC
),
1982 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1983 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1984 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1985 minit ("IS_BIND_C", AB_IS_BIND_C
),
1986 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1987 minit ("IS_ISO_C", AB_IS_ISO_C
),
1988 minit ("VALUE", AB_VALUE
),
1989 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1990 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1991 minit ("LOCK_COMP", AB_LOCK_COMP
),
1992 minit ("POINTER_COMP", AB_POINTER_COMP
),
1993 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1994 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1995 minit ("ZERO_COMP", AB_ZERO_COMP
),
1996 minit ("PROTECTED", AB_PROTECTED
),
1997 minit ("ABSTRACT", AB_ABSTRACT
),
1998 minit ("IS_CLASS", AB_IS_CLASS
),
1999 minit ("PROCEDURE", AB_PROCEDURE
),
2000 minit ("PROC_POINTER", AB_PROC_POINTER
),
2001 minit ("VTYPE", AB_VTYPE
),
2002 minit ("VTAB", AB_VTAB
),
2003 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
2004 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
2005 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
2006 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
2007 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
2008 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE
),
2012 /* For binding attributes. */
2013 static const mstring binding_passing
[] =
2016 minit ("NOPASS", 1),
2019 static const mstring binding_overriding
[] =
2021 minit ("OVERRIDABLE", 0),
2022 minit ("NON_OVERRIDABLE", 1),
2023 minit ("DEFERRED", 2),
2026 static const mstring binding_generic
[] =
2028 minit ("SPECIFIC", 0),
2029 minit ("GENERIC", 1),
2032 static const mstring binding_ppc
[] =
2034 minit ("NO_PPC", 0),
2039 /* Specialization of mio_name. */
2040 DECL_MIO_NAME (ab_attribute
)
2041 DECL_MIO_NAME (ar_type
)
2042 DECL_MIO_NAME (array_type
)
2044 DECL_MIO_NAME (expr_t
)
2045 DECL_MIO_NAME (gfc_access
)
2046 DECL_MIO_NAME (gfc_intrinsic_op
)
2047 DECL_MIO_NAME (ifsrc
)
2048 DECL_MIO_NAME (save_state
)
2049 DECL_MIO_NAME (procedure_type
)
2050 DECL_MIO_NAME (ref_type
)
2051 DECL_MIO_NAME (sym_flavor
)
2052 DECL_MIO_NAME (sym_intent
)
2053 #undef DECL_MIO_NAME
2055 /* Symbol attributes are stored in list with the first three elements
2056 being the enumerated fields, while the remaining elements (if any)
2057 indicate the individual attribute bits. The access field is not
2058 saved-- it controls what symbols are exported when a module is
2062 mio_symbol_attribute (symbol_attribute
*attr
)
2065 unsigned ext_attr
,extension_level
;
2069 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2070 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2071 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2072 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2073 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2075 ext_attr
= attr
->ext_attr
;
2076 mio_integer ((int *) &ext_attr
);
2077 attr
->ext_attr
= ext_attr
;
2079 extension_level
= attr
->extension
;
2080 mio_integer ((int *) &extension_level
);
2081 attr
->extension
= extension_level
;
2083 if (iomode
== IO_OUTPUT
)
2085 if (attr
->allocatable
)
2086 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2087 if (attr
->artificial
)
2088 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2089 if (attr
->asynchronous
)
2090 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2091 if (attr
->dimension
)
2092 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2093 if (attr
->codimension
)
2094 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2095 if (attr
->contiguous
)
2096 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2098 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2099 if (attr
->intrinsic
)
2100 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2102 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2104 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2105 if (attr
->class_pointer
)
2106 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2107 if (attr
->is_protected
)
2108 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2110 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2111 if (attr
->volatile_
)
2112 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2114 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2115 if (attr
->threadprivate
)
2116 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2118 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2120 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2121 /* We deliberately don't preserve the "entry" flag. */
2124 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2125 if (attr
->in_namelist
)
2126 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2127 if (attr
->in_common
)
2128 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2131 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2132 if (attr
->subroutine
)
2133 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2135 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2137 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2140 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2141 if (attr
->elemental
)
2142 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2144 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2145 if (attr
->implicit_pure
)
2146 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2147 if (attr
->unlimited_polymorphic
)
2148 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2149 if (attr
->recursive
)
2150 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2151 if (attr
->always_explicit
)
2152 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2153 if (attr
->cray_pointer
)
2154 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2155 if (attr
->cray_pointee
)
2156 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2157 if (attr
->is_bind_c
)
2158 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2159 if (attr
->is_c_interop
)
2160 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2162 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2163 if (attr
->alloc_comp
)
2164 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2165 if (attr
->pointer_comp
)
2166 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2167 if (attr
->proc_pointer_comp
)
2168 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2169 if (attr
->private_comp
)
2170 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2171 if (attr
->coarray_comp
)
2172 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2173 if (attr
->lock_comp
)
2174 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2175 if (attr
->zero_comp
)
2176 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2178 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2179 if (attr
->procedure
)
2180 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2181 if (attr
->proc_pointer
)
2182 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2184 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2186 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2187 if (attr
->omp_declare_target
)
2188 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2189 if (attr
->array_outer_dependency
)
2190 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2191 if (attr
->module_procedure
)
2192 MIO_NAME (ab_attribute
) (AB_MODULE_PROCEDURE
, attr_bits
);
2202 if (t
== ATOM_RPAREN
)
2205 bad_module ("Expected attribute bit name");
2207 switch ((ab_attribute
) find_enum (attr_bits
))
2209 case AB_ALLOCATABLE
:
2210 attr
->allocatable
= 1;
2213 attr
->artificial
= 1;
2215 case AB_ASYNCHRONOUS
:
2216 attr
->asynchronous
= 1;
2219 attr
->dimension
= 1;
2221 case AB_CODIMENSION
:
2222 attr
->codimension
= 1;
2225 attr
->contiguous
= 1;
2231 attr
->intrinsic
= 1;
2239 case AB_CLASS_POINTER
:
2240 attr
->class_pointer
= 1;
2243 attr
->is_protected
= 1;
2249 attr
->volatile_
= 1;
2254 case AB_THREADPRIVATE
:
2255 attr
->threadprivate
= 1;
2266 case AB_IN_NAMELIST
:
2267 attr
->in_namelist
= 1;
2270 attr
->in_common
= 1;
2276 attr
->subroutine
= 1;
2288 attr
->elemental
= 1;
2293 case AB_IMPLICIT_PURE
:
2294 attr
->implicit_pure
= 1;
2296 case AB_UNLIMITED_POLY
:
2297 attr
->unlimited_polymorphic
= 1;
2300 attr
->recursive
= 1;
2302 case AB_ALWAYS_EXPLICIT
:
2303 attr
->always_explicit
= 1;
2305 case AB_CRAY_POINTER
:
2306 attr
->cray_pointer
= 1;
2308 case AB_CRAY_POINTEE
:
2309 attr
->cray_pointee
= 1;
2312 attr
->is_bind_c
= 1;
2314 case AB_IS_C_INTEROP
:
2315 attr
->is_c_interop
= 1;
2321 attr
->alloc_comp
= 1;
2323 case AB_COARRAY_COMP
:
2324 attr
->coarray_comp
= 1;
2327 attr
->lock_comp
= 1;
2329 case AB_POINTER_COMP
:
2330 attr
->pointer_comp
= 1;
2332 case AB_PROC_POINTER_COMP
:
2333 attr
->proc_pointer_comp
= 1;
2335 case AB_PRIVATE_COMP
:
2336 attr
->private_comp
= 1;
2339 attr
->zero_comp
= 1;
2345 attr
->procedure
= 1;
2347 case AB_PROC_POINTER
:
2348 attr
->proc_pointer
= 1;
2356 case AB_OMP_DECLARE_TARGET
:
2357 attr
->omp_declare_target
= 1;
2359 case AB_ARRAY_OUTER_DEPENDENCY
:
2360 attr
->array_outer_dependency
=1;
2362 case AB_MODULE_PROCEDURE
:
2363 attr
->module_procedure
=1;
2371 static const mstring bt_types
[] = {
2372 minit ("INTEGER", BT_INTEGER
),
2373 minit ("REAL", BT_REAL
),
2374 minit ("COMPLEX", BT_COMPLEX
),
2375 minit ("LOGICAL", BT_LOGICAL
),
2376 minit ("CHARACTER", BT_CHARACTER
),
2377 minit ("DERIVED", BT_DERIVED
),
2378 minit ("CLASS", BT_CLASS
),
2379 minit ("PROCEDURE", BT_PROCEDURE
),
2380 minit ("UNKNOWN", BT_UNKNOWN
),
2381 minit ("VOID", BT_VOID
),
2382 minit ("ASSUMED", BT_ASSUMED
),
2388 mio_charlen (gfc_charlen
**clp
)
2394 if (iomode
== IO_OUTPUT
)
2398 mio_expr (&cl
->length
);
2402 if (peek_atom () != ATOM_RPAREN
)
2404 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2405 mio_expr (&cl
->length
);
2414 /* See if a name is a generated name. */
2417 check_unique_name (const char *name
)
2419 return *name
== '@';
2424 mio_typespec (gfc_typespec
*ts
)
2428 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2430 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2431 mio_integer (&ts
->kind
);
2433 mio_symbol_ref (&ts
->u
.derived
);
2435 mio_symbol_ref (&ts
->interface
);
2437 /* Add info for C interop and is_iso_c. */
2438 mio_integer (&ts
->is_c_interop
);
2439 mio_integer (&ts
->is_iso_c
);
2441 /* If the typespec is for an identifier either from iso_c_binding, or
2442 a constant that was initialized to an identifier from it, use the
2443 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2445 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2447 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2449 if (ts
->type
!= BT_CHARACTER
)
2451 /* ts->u.cl is only valid for BT_CHARACTER. */
2456 mio_charlen (&ts
->u
.cl
);
2458 /* So as not to disturb the existing API, use an ATOM_NAME to
2459 transmit deferred characteristic for characters (F2003). */
2460 if (iomode
== IO_OUTPUT
)
2462 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2463 write_atom (ATOM_NAME
, "DEFERRED_CL");
2465 else if (peek_atom () != ATOM_RPAREN
)
2467 if (parse_atom () != ATOM_NAME
)
2468 bad_module ("Expected string");
2476 static const mstring array_spec_types
[] = {
2477 minit ("EXPLICIT", AS_EXPLICIT
),
2478 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2479 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2480 minit ("DEFERRED", AS_DEFERRED
),
2481 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2487 mio_array_spec (gfc_array_spec
**asp
)
2494 if (iomode
== IO_OUTPUT
)
2502 /* mio_integer expects nonnegative values. */
2503 rank
= as
->rank
> 0 ? as
->rank
: 0;
2504 mio_integer (&rank
);
2508 if (peek_atom () == ATOM_RPAREN
)
2514 *asp
= as
= gfc_get_array_spec ();
2515 mio_integer (&as
->rank
);
2518 mio_integer (&as
->corank
);
2519 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2521 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2523 if (iomode
== IO_INPUT
&& as
->corank
)
2524 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2526 if (as
->rank
+ as
->corank
> 0)
2527 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2529 mio_expr (&as
->lower
[i
]);
2530 mio_expr (&as
->upper
[i
]);
2538 /* Given a pointer to an array reference structure (which lives in a
2539 gfc_ref structure), find the corresponding array specification
2540 structure. Storing the pointer in the ref structure doesn't quite
2541 work when loading from a module. Generating code for an array
2542 reference also needs more information than just the array spec. */
2544 static const mstring array_ref_types
[] = {
2545 minit ("FULL", AR_FULL
),
2546 minit ("ELEMENT", AR_ELEMENT
),
2547 minit ("SECTION", AR_SECTION
),
2553 mio_array_ref (gfc_array_ref
*ar
)
2558 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2559 mio_integer (&ar
->dimen
);
2567 for (i
= 0; i
< ar
->dimen
; i
++)
2568 mio_expr (&ar
->start
[i
]);
2573 for (i
= 0; i
< ar
->dimen
; i
++)
2575 mio_expr (&ar
->start
[i
]);
2576 mio_expr (&ar
->end
[i
]);
2577 mio_expr (&ar
->stride
[i
]);
2583 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2586 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2587 we can't call mio_integer directly. Instead loop over each element
2588 and cast it to/from an integer. */
2589 if (iomode
== IO_OUTPUT
)
2591 for (i
= 0; i
< ar
->dimen
; i
++)
2593 int tmp
= (int)ar
->dimen_type
[i
];
2594 write_atom (ATOM_INTEGER
, &tmp
);
2599 for (i
= 0; i
< ar
->dimen
; i
++)
2601 require_atom (ATOM_INTEGER
);
2602 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2606 if (iomode
== IO_INPUT
)
2608 ar
->where
= gfc_current_locus
;
2610 for (i
= 0; i
< ar
->dimen
; i
++)
2611 ar
->c_where
[i
] = gfc_current_locus
;
2618 /* Saves or restores a pointer. The pointer is converted back and
2619 forth from an integer. We return the pointer_info pointer so that
2620 the caller can take additional action based on the pointer type. */
2622 static pointer_info
*
2623 mio_pointer_ref (void *gp
)
2627 if (iomode
== IO_OUTPUT
)
2629 p
= get_pointer (*((char **) gp
));
2630 write_atom (ATOM_INTEGER
, &p
->integer
);
2634 require_atom (ATOM_INTEGER
);
2635 p
= add_fixup (atom_int
, gp
);
2642 /* Save and load references to components that occur within
2643 expressions. We have to describe these references by a number and
2644 by name. The number is necessary for forward references during
2645 reading, and the name is necessary if the symbol already exists in
2646 the namespace and is not loaded again. */
2649 mio_component_ref (gfc_component
**cp
)
2653 p
= mio_pointer_ref (cp
);
2654 if (p
->type
== P_UNKNOWN
)
2655 p
->type
= P_COMPONENT
;
2659 static void mio_namespace_ref (gfc_namespace
**nsp
);
2660 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2661 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2664 mio_component (gfc_component
*c
, int vtype
)
2671 if (iomode
== IO_OUTPUT
)
2673 p
= get_pointer (c
);
2674 mio_integer (&p
->integer
);
2679 p
= get_integer (n
);
2680 associate_integer_pointer (p
, c
);
2683 if (p
->type
== P_UNKNOWN
)
2684 p
->type
= P_COMPONENT
;
2686 mio_pool_string (&c
->name
);
2687 mio_typespec (&c
->ts
);
2688 mio_array_spec (&c
->as
);
2690 mio_symbol_attribute (&c
->attr
);
2691 if (c
->ts
.type
== BT_CLASS
)
2692 c
->attr
.class_ok
= 1;
2693 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2695 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2696 || strcmp (c
->name
, "_hash") == 0)
2697 mio_expr (&c
->initializer
);
2699 if (c
->attr
.proc_pointer
)
2700 mio_typebound_proc (&c
->tb
);
2707 mio_component_list (gfc_component
**cp
, int vtype
)
2709 gfc_component
*c
, *tail
;
2713 if (iomode
== IO_OUTPUT
)
2715 for (c
= *cp
; c
; c
= c
->next
)
2716 mio_component (c
, vtype
);
2725 if (peek_atom () == ATOM_RPAREN
)
2728 c
= gfc_get_component ();
2729 mio_component (c
, vtype
);
2745 mio_actual_arg (gfc_actual_arglist
*a
)
2748 mio_pool_string (&a
->name
);
2749 mio_expr (&a
->expr
);
2755 mio_actual_arglist (gfc_actual_arglist
**ap
)
2757 gfc_actual_arglist
*a
, *tail
;
2761 if (iomode
== IO_OUTPUT
)
2763 for (a
= *ap
; a
; a
= a
->next
)
2773 if (peek_atom () != ATOM_LPAREN
)
2776 a
= gfc_get_actual_arglist ();
2792 /* Read and write formal argument lists. */
2795 mio_formal_arglist (gfc_formal_arglist
**formal
)
2797 gfc_formal_arglist
*f
, *tail
;
2801 if (iomode
== IO_OUTPUT
)
2803 for (f
= *formal
; f
; f
= f
->next
)
2804 mio_symbol_ref (&f
->sym
);
2808 *formal
= tail
= NULL
;
2810 while (peek_atom () != ATOM_RPAREN
)
2812 f
= gfc_get_formal_arglist ();
2813 mio_symbol_ref (&f
->sym
);
2815 if (*formal
== NULL
)
2828 /* Save or restore a reference to a symbol node. */
2831 mio_symbol_ref (gfc_symbol
**symp
)
2835 p
= mio_pointer_ref (symp
);
2836 if (p
->type
== P_UNKNOWN
)
2839 if (iomode
== IO_OUTPUT
)
2841 if (p
->u
.wsym
.state
== UNREFERENCED
)
2842 p
->u
.wsym
.state
= NEEDS_WRITE
;
2846 if (p
->u
.rsym
.state
== UNUSED
)
2847 p
->u
.rsym
.state
= NEEDED
;
2853 /* Save or restore a reference to a symtree node. */
2856 mio_symtree_ref (gfc_symtree
**stp
)
2861 if (iomode
== IO_OUTPUT
)
2862 mio_symbol_ref (&(*stp
)->n
.sym
);
2865 require_atom (ATOM_INTEGER
);
2866 p
= get_integer (atom_int
);
2868 /* An unused equivalence member; make a symbol and a symtree
2870 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2872 /* Since this is not used, it must have a unique name. */
2873 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2875 /* Make the symbol. */
2876 if (p
->u
.rsym
.sym
== NULL
)
2878 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2880 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2883 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2884 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2885 p
->u
.rsym
.referenced
= 1;
2887 /* If the symbol is PRIVATE and in COMMON, load_commons will
2888 generate a fixup symbol, which must be associated. */
2890 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2894 if (p
->type
== P_UNKNOWN
)
2897 if (p
->u
.rsym
.state
== UNUSED
)
2898 p
->u
.rsym
.state
= NEEDED
;
2900 if (p
->u
.rsym
.symtree
!= NULL
)
2902 *stp
= p
->u
.rsym
.symtree
;
2906 f
= XCNEW (fixup_t
);
2908 f
->next
= p
->u
.rsym
.stfixup
;
2909 p
->u
.rsym
.stfixup
= f
;
2911 f
->pointer
= (void **) stp
;
2918 mio_iterator (gfc_iterator
**ip
)
2924 if (iomode
== IO_OUTPUT
)
2931 if (peek_atom () == ATOM_RPAREN
)
2937 *ip
= gfc_get_iterator ();
2942 mio_expr (&iter
->var
);
2943 mio_expr (&iter
->start
);
2944 mio_expr (&iter
->end
);
2945 mio_expr (&iter
->step
);
2953 mio_constructor (gfc_constructor_base
*cp
)
2959 if (iomode
== IO_OUTPUT
)
2961 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2964 mio_expr (&c
->expr
);
2965 mio_iterator (&c
->iterator
);
2971 while (peek_atom () != ATOM_RPAREN
)
2973 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2976 mio_expr (&c
->expr
);
2977 mio_iterator (&c
->iterator
);
2986 static const mstring ref_types
[] = {
2987 minit ("ARRAY", REF_ARRAY
),
2988 minit ("COMPONENT", REF_COMPONENT
),
2989 minit ("SUBSTRING", REF_SUBSTRING
),
2995 mio_ref (gfc_ref
**rp
)
3002 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
3007 mio_array_ref (&r
->u
.ar
);
3011 mio_symbol_ref (&r
->u
.c
.sym
);
3012 mio_component_ref (&r
->u
.c
.component
);
3016 mio_expr (&r
->u
.ss
.start
);
3017 mio_expr (&r
->u
.ss
.end
);
3018 mio_charlen (&r
->u
.ss
.length
);
3027 mio_ref_list (gfc_ref
**rp
)
3029 gfc_ref
*ref
, *head
, *tail
;
3033 if (iomode
== IO_OUTPUT
)
3035 for (ref
= *rp
; ref
; ref
= ref
->next
)
3042 while (peek_atom () != ATOM_RPAREN
)
3045 head
= tail
= gfc_get_ref ();
3048 tail
->next
= gfc_get_ref ();
3062 /* Read and write an integer value. */
3065 mio_gmp_integer (mpz_t
*integer
)
3069 if (iomode
== IO_INPUT
)
3071 if (parse_atom () != ATOM_STRING
)
3072 bad_module ("Expected integer string");
3074 mpz_init (*integer
);
3075 if (mpz_set_str (*integer
, atom_string
, 10))
3076 bad_module ("Error converting integer");
3082 p
= mpz_get_str (NULL
, 10, *integer
);
3083 write_atom (ATOM_STRING
, p
);
3090 mio_gmp_real (mpfr_t
*real
)
3095 if (iomode
== IO_INPUT
)
3097 if (parse_atom () != ATOM_STRING
)
3098 bad_module ("Expected real string");
3101 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3106 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3108 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3110 write_atom (ATOM_STRING
, p
);
3115 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3117 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3119 /* Fix negative numbers. */
3120 if (atom_string
[2] == '-')
3122 atom_string
[0] = '-';
3123 atom_string
[1] = '0';
3124 atom_string
[2] = '.';
3127 write_atom (ATOM_STRING
, atom_string
);
3135 /* Save and restore the shape of an array constructor. */
3138 mio_shape (mpz_t
**pshape
, int rank
)
3144 /* A NULL shape is represented by (). */
3147 if (iomode
== IO_OUTPUT
)
3159 if (t
== ATOM_RPAREN
)
3166 shape
= gfc_get_shape (rank
);
3170 for (n
= 0; n
< rank
; n
++)
3171 mio_gmp_integer (&shape
[n
]);
3177 static const mstring expr_types
[] = {
3178 minit ("OP", EXPR_OP
),
3179 minit ("FUNCTION", EXPR_FUNCTION
),
3180 minit ("CONSTANT", EXPR_CONSTANT
),
3181 minit ("VARIABLE", EXPR_VARIABLE
),
3182 minit ("SUBSTRING", EXPR_SUBSTRING
),
3183 minit ("STRUCTURE", EXPR_STRUCTURE
),
3184 minit ("ARRAY", EXPR_ARRAY
),
3185 minit ("NULL", EXPR_NULL
),
3186 minit ("COMPCALL", EXPR_COMPCALL
),
3190 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3191 generic operators, not in expressions. INTRINSIC_USER is also
3192 replaced by the correct function name by the time we see it. */
3194 static const mstring intrinsics
[] =
3196 minit ("UPLUS", INTRINSIC_UPLUS
),
3197 minit ("UMINUS", INTRINSIC_UMINUS
),
3198 minit ("PLUS", INTRINSIC_PLUS
),
3199 minit ("MINUS", INTRINSIC_MINUS
),
3200 minit ("TIMES", INTRINSIC_TIMES
),
3201 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3202 minit ("POWER", INTRINSIC_POWER
),
3203 minit ("CONCAT", INTRINSIC_CONCAT
),
3204 minit ("AND", INTRINSIC_AND
),
3205 minit ("OR", INTRINSIC_OR
),
3206 minit ("EQV", INTRINSIC_EQV
),
3207 minit ("NEQV", INTRINSIC_NEQV
),
3208 minit ("EQ_SIGN", INTRINSIC_EQ
),
3209 minit ("EQ", INTRINSIC_EQ_OS
),
3210 minit ("NE_SIGN", INTRINSIC_NE
),
3211 minit ("NE", INTRINSIC_NE_OS
),
3212 minit ("GT_SIGN", INTRINSIC_GT
),
3213 minit ("GT", INTRINSIC_GT_OS
),
3214 minit ("GE_SIGN", INTRINSIC_GE
),
3215 minit ("GE", INTRINSIC_GE_OS
),
3216 minit ("LT_SIGN", INTRINSIC_LT
),
3217 minit ("LT", INTRINSIC_LT_OS
),
3218 minit ("LE_SIGN", INTRINSIC_LE
),
3219 minit ("LE", INTRINSIC_LE_OS
),
3220 minit ("NOT", INTRINSIC_NOT
),
3221 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3222 minit ("USER", INTRINSIC_USER
),
3227 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3230 fix_mio_expr (gfc_expr
*e
)
3232 gfc_symtree
*ns_st
= NULL
;
3235 if (iomode
!= IO_OUTPUT
)
3240 /* If this is a symtree for a symbol that came from a contained module
3241 namespace, it has a unique name and we should look in the current
3242 namespace to see if the required, non-contained symbol is available
3243 yet. If so, the latter should be written. */
3244 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3246 const char *name
= e
->symtree
->n
.sym
->name
;
3247 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3248 name
= dt_upper_string (name
);
3249 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3252 /* On the other hand, if the existing symbol is the module name or the
3253 new symbol is a dummy argument, do not do the promotion. */
3254 if (ns_st
&& ns_st
->n
.sym
3255 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3256 && !e
->symtree
->n
.sym
->attr
.dummy
)
3259 else if (e
->expr_type
== EXPR_FUNCTION
3260 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3264 /* In some circumstances, a function used in an initialization
3265 expression, in one use associated module, can fail to be
3266 coupled to its symtree when used in a specification
3267 expression in another module. */
3268 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3269 : e
->value
.function
.isym
->name
;
3270 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3275 /* This is probably a reference to a private procedure from another
3276 module. To prevent a segfault, make a generic with no specific
3277 instances. If this module is used, without the required
3278 specific coming from somewhere, the appropriate error message
3280 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3281 sym
->attr
.flavor
= FL_PROCEDURE
;
3282 sym
->attr
.generic
= 1;
3283 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3284 gfc_commit_symbol (sym
);
3289 /* Read and write expressions. The form "()" is allowed to indicate a
3293 mio_expr (gfc_expr
**ep
)
3301 if (iomode
== IO_OUTPUT
)
3310 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3315 if (t
== ATOM_RPAREN
)
3322 bad_module ("Expected expression type");
3324 e
= *ep
= gfc_get_expr ();
3325 e
->where
= gfc_current_locus
;
3326 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3329 mio_typespec (&e
->ts
);
3330 mio_integer (&e
->rank
);
3334 switch (e
->expr_type
)
3338 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3340 switch (e
->value
.op
.op
)
3342 case INTRINSIC_UPLUS
:
3343 case INTRINSIC_UMINUS
:
3345 case INTRINSIC_PARENTHESES
:
3346 mio_expr (&e
->value
.op
.op1
);
3349 case INTRINSIC_PLUS
:
3350 case INTRINSIC_MINUS
:
3351 case INTRINSIC_TIMES
:
3352 case INTRINSIC_DIVIDE
:
3353 case INTRINSIC_POWER
:
3354 case INTRINSIC_CONCAT
:
3358 case INTRINSIC_NEQV
:
3360 case INTRINSIC_EQ_OS
:
3362 case INTRINSIC_NE_OS
:
3364 case INTRINSIC_GT_OS
:
3366 case INTRINSIC_GE_OS
:
3368 case INTRINSIC_LT_OS
:
3370 case INTRINSIC_LE_OS
:
3371 mio_expr (&e
->value
.op
.op1
);
3372 mio_expr (&e
->value
.op
.op2
);
3375 case INTRINSIC_USER
:
3376 /* INTRINSIC_USER should not appear in resolved expressions,
3377 though for UDRs we need to stream unresolved ones. */
3378 if (iomode
== IO_OUTPUT
)
3379 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3382 char *name
= read_string ();
3383 const char *uop_name
= find_use_name (name
, true);
3384 if (uop_name
== NULL
)
3386 size_t len
= strlen (name
);
3387 char *name2
= XCNEWVEC (char, len
+ 2);
3388 memcpy (name2
, name
, len
);
3390 name2
[len
+ 1] = '\0';
3392 uop_name
= name
= name2
;
3394 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3397 mio_expr (&e
->value
.op
.op1
);
3398 mio_expr (&e
->value
.op
.op2
);
3402 bad_module ("Bad operator");
3408 mio_symtree_ref (&e
->symtree
);
3409 mio_actual_arglist (&e
->value
.function
.actual
);
3411 if (iomode
== IO_OUTPUT
)
3413 e
->value
.function
.name
3414 = mio_allocated_string (e
->value
.function
.name
);
3415 if (e
->value
.function
.esym
)
3419 else if (e
->value
.function
.isym
== NULL
)
3423 mio_integer (&flag
);
3427 mio_symbol_ref (&e
->value
.function
.esym
);
3430 mio_ref_list (&e
->ref
);
3435 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3440 require_atom (ATOM_STRING
);
3441 if (atom_string
[0] == '\0')
3442 e
->value
.function
.name
= NULL
;
3444 e
->value
.function
.name
= gfc_get_string (atom_string
);
3447 mio_integer (&flag
);
3451 mio_symbol_ref (&e
->value
.function
.esym
);
3454 mio_ref_list (&e
->ref
);
3459 require_atom (ATOM_STRING
);
3460 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3468 mio_symtree_ref (&e
->symtree
);
3469 mio_ref_list (&e
->ref
);
3472 case EXPR_SUBSTRING
:
3473 e
->value
.character
.string
3474 = CONST_CAST (gfc_char_t
*,
3475 mio_allocated_wide_string (e
->value
.character
.string
,
3476 e
->value
.character
.length
));
3477 mio_ref_list (&e
->ref
);
3480 case EXPR_STRUCTURE
:
3482 mio_constructor (&e
->value
.constructor
);
3483 mio_shape (&e
->shape
, e
->rank
);
3490 mio_gmp_integer (&e
->value
.integer
);
3494 gfc_set_model_kind (e
->ts
.kind
);
3495 mio_gmp_real (&e
->value
.real
);
3499 gfc_set_model_kind (e
->ts
.kind
);
3500 mio_gmp_real (&mpc_realref (e
->value
.complex));
3501 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3505 mio_integer (&e
->value
.logical
);
3509 mio_integer (&e
->value
.character
.length
);
3510 e
->value
.character
.string
3511 = CONST_CAST (gfc_char_t
*,
3512 mio_allocated_wide_string (e
->value
.character
.string
,
3513 e
->value
.character
.length
));
3517 bad_module ("Bad type in constant expression");
3535 /* Read and write namelists. */
3538 mio_namelist (gfc_symbol
*sym
)
3540 gfc_namelist
*n
, *m
;
3541 const char *check_name
;
3545 if (iomode
== IO_OUTPUT
)
3547 for (n
= sym
->namelist
; n
; n
= n
->next
)
3548 mio_symbol_ref (&n
->sym
);
3552 /* This departure from the standard is flagged as an error.
3553 It does, in fact, work correctly. TODO: Allow it
3555 if (sym
->attr
.flavor
== FL_NAMELIST
)
3557 check_name
= find_use_name (sym
->name
, false);
3558 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3559 gfc_error ("Namelist %s cannot be renamed by USE "
3560 "association to %s", sym
->name
, check_name
);
3564 while (peek_atom () != ATOM_RPAREN
)
3566 n
= gfc_get_namelist ();
3567 mio_symbol_ref (&n
->sym
);
3569 if (sym
->namelist
== NULL
)
3576 sym
->namelist_tail
= m
;
3583 /* Save/restore lists of gfc_interface structures. When loading an
3584 interface, we are really appending to the existing list of
3585 interfaces. Checking for duplicate and ambiguous interfaces has to
3586 be done later when all symbols have been loaded. */
3589 mio_interface_rest (gfc_interface
**ip
)
3591 gfc_interface
*tail
, *p
;
3592 pointer_info
*pi
= NULL
;
3594 if (iomode
== IO_OUTPUT
)
3597 for (p
= *ip
; p
; p
= p
->next
)
3598 mio_symbol_ref (&p
->sym
);
3613 if (peek_atom () == ATOM_RPAREN
)
3616 p
= gfc_get_interface ();
3617 p
->where
= gfc_current_locus
;
3618 pi
= mio_symbol_ref (&p
->sym
);
3634 /* Save/restore a nameless operator interface. */
3637 mio_interface (gfc_interface
**ip
)
3640 mio_interface_rest (ip
);
3644 /* Save/restore a named operator interface. */
3647 mio_symbol_interface (const char **name
, const char **module
,
3651 mio_pool_string (name
);
3652 mio_pool_string (module
);
3653 mio_interface_rest (ip
);
3658 mio_namespace_ref (gfc_namespace
**nsp
)
3663 p
= mio_pointer_ref (nsp
);
3665 if (p
->type
== P_UNKNOWN
)
3666 p
->type
= P_NAMESPACE
;
3668 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3670 ns
= (gfc_namespace
*) p
->u
.pointer
;
3673 ns
= gfc_get_namespace (NULL
, 0);
3674 associate_integer_pointer (p
, ns
);
3682 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3684 static gfc_namespace
* current_f2k_derived
;
3687 mio_typebound_proc (gfc_typebound_proc
** proc
)
3690 int overriding_flag
;
3692 if (iomode
== IO_INPUT
)
3694 *proc
= gfc_get_typebound_proc (NULL
);
3695 (*proc
)->where
= gfc_current_locus
;
3701 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3703 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3704 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3705 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3706 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3707 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3708 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3709 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3711 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3712 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3713 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3715 mio_pool_string (&((*proc
)->pass_arg
));
3717 flag
= (int) (*proc
)->pass_arg_num
;
3718 mio_integer (&flag
);
3719 (*proc
)->pass_arg_num
= (unsigned) flag
;
3721 if ((*proc
)->is_generic
)
3728 if (iomode
== IO_OUTPUT
)
3729 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3731 iop
= (int) g
->is_operator
;
3733 mio_allocated_string (g
->specific_st
->name
);
3737 (*proc
)->u
.generic
= NULL
;
3738 while (peek_atom () != ATOM_RPAREN
)
3740 gfc_symtree
** sym_root
;
3742 g
= gfc_get_tbp_generic ();
3746 g
->is_operator
= (bool) iop
;
3748 require_atom (ATOM_STRING
);
3749 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3750 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3753 g
->next
= (*proc
)->u
.generic
;
3754 (*proc
)->u
.generic
= g
;
3760 else if (!(*proc
)->ppc
)
3761 mio_symtree_ref (&(*proc
)->u
.specific
);
3766 /* Walker-callback function for this purpose. */
3768 mio_typebound_symtree (gfc_symtree
* st
)
3770 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3773 if (iomode
== IO_OUTPUT
)
3776 mio_allocated_string (st
->name
);
3778 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3780 mio_typebound_proc (&st
->n
.tb
);
3784 /* IO a full symtree (in all depth). */
3786 mio_full_typebound_tree (gfc_symtree
** root
)
3790 if (iomode
== IO_OUTPUT
)
3791 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3794 while (peek_atom () == ATOM_LPAREN
)
3800 require_atom (ATOM_STRING
);
3801 st
= gfc_get_tbp_symtree (root
, atom_string
);
3804 mio_typebound_symtree (st
);
3812 mio_finalizer (gfc_finalizer
**f
)
3814 if (iomode
== IO_OUTPUT
)
3817 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3818 mio_symtree_ref (&(*f
)->proc_tree
);
3822 *f
= gfc_get_finalizer ();
3823 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3826 mio_symtree_ref (&(*f
)->proc_tree
);
3827 (*f
)->proc_sym
= NULL
;
3832 mio_f2k_derived (gfc_namespace
*f2k
)
3834 current_f2k_derived
= f2k
;
3836 /* Handle the list of finalizer procedures. */
3838 if (iomode
== IO_OUTPUT
)
3841 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3846 f2k
->finalizers
= NULL
;
3847 while (peek_atom () != ATOM_RPAREN
)
3849 gfc_finalizer
*cur
= NULL
;
3850 mio_finalizer (&cur
);
3851 cur
->next
= f2k
->finalizers
;
3852 f2k
->finalizers
= cur
;
3857 /* Handle type-bound procedures. */
3858 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3860 /* Type-bound user operators. */
3861 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3863 /* Type-bound intrinsic operators. */
3865 if (iomode
== IO_OUTPUT
)
3868 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3870 gfc_intrinsic_op realop
;
3872 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3876 realop
= (gfc_intrinsic_op
) op
;
3877 mio_intrinsic_op (&realop
);
3878 mio_typebound_proc (&f2k
->tb_op
[op
]);
3883 while (peek_atom () != ATOM_RPAREN
)
3885 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3888 mio_intrinsic_op (&op
);
3889 mio_typebound_proc (&f2k
->tb_op
[op
]);
3896 mio_full_f2k_derived (gfc_symbol
*sym
)
3900 if (iomode
== IO_OUTPUT
)
3902 if (sym
->f2k_derived
)
3903 mio_f2k_derived (sym
->f2k_derived
);
3907 if (peek_atom () != ATOM_RPAREN
)
3909 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3910 mio_f2k_derived (sym
->f2k_derived
);
3913 gcc_assert (!sym
->f2k_derived
);
3919 static const mstring omp_declare_simd_clauses
[] =
3921 minit ("INBRANCH", 0),
3922 minit ("NOTINBRANCH", 1),
3923 minit ("SIMDLEN", 2),
3924 minit ("UNIFORM", 3),
3925 minit ("LINEAR", 4),
3926 minit ("ALIGNED", 5),
3930 /* Handle !$omp declare simd. */
3933 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
3935 if (iomode
== IO_OUTPUT
)
3940 else if (peek_atom () != ATOM_LPAREN
)
3943 gfc_omp_declare_simd
*ods
= *odsp
;
3946 if (iomode
== IO_OUTPUT
)
3948 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
3951 gfc_omp_namelist
*n
;
3953 if (ods
->clauses
->inbranch
)
3954 mio_name (0, omp_declare_simd_clauses
);
3955 if (ods
->clauses
->notinbranch
)
3956 mio_name (1, omp_declare_simd_clauses
);
3957 if (ods
->clauses
->simdlen_expr
)
3959 mio_name (2, omp_declare_simd_clauses
);
3960 mio_expr (&ods
->clauses
->simdlen_expr
);
3962 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
3964 mio_name (3, omp_declare_simd_clauses
);
3965 mio_symbol_ref (&n
->sym
);
3967 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
3969 mio_name (4, omp_declare_simd_clauses
);
3970 mio_symbol_ref (&n
->sym
);
3971 mio_expr (&n
->expr
);
3973 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3975 mio_name (5, omp_declare_simd_clauses
);
3976 mio_symbol_ref (&n
->sym
);
3977 mio_expr (&n
->expr
);
3983 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
3985 require_atom (ATOM_NAME
);
3986 *odsp
= ods
= gfc_get_omp_declare_simd ();
3987 ods
->where
= gfc_current_locus
;
3988 ods
->proc_name
= ns
->proc_name
;
3989 if (peek_atom () == ATOM_NAME
)
3991 ods
->clauses
= gfc_get_omp_clauses ();
3992 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
3993 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
3994 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
3996 while (peek_atom () == ATOM_NAME
)
3998 gfc_omp_namelist
*n
;
3999 int t
= mio_name (0, omp_declare_simd_clauses
);
4003 case 0: ods
->clauses
->inbranch
= true; break;
4004 case 1: ods
->clauses
->notinbranch
= true; break;
4005 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
4009 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
4010 ptrs
[t
- 3] = &n
->next
;
4011 mio_symbol_ref (&n
->sym
);
4013 mio_expr (&n
->expr
);
4019 mio_omp_declare_simd (ns
, &ods
->next
);
4025 static const mstring omp_declare_reduction_stmt
[] =
4027 minit ("ASSIGN", 0),
4034 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
4035 gfc_namespace
*ns
, bool is_initializer
)
4037 if (iomode
== IO_OUTPUT
)
4039 if ((*sym1
)->module
== NULL
)
4041 (*sym1
)->module
= module_name
;
4042 (*sym2
)->module
= module_name
;
4044 mio_symbol_ref (sym1
);
4045 mio_symbol_ref (sym2
);
4046 if (ns
->code
->op
== EXEC_ASSIGN
)
4048 mio_name (0, omp_declare_reduction_stmt
);
4049 mio_expr (&ns
->code
->expr1
);
4050 mio_expr (&ns
->code
->expr2
);
4055 mio_name (1, omp_declare_reduction_stmt
);
4056 mio_symtree_ref (&ns
->code
->symtree
);
4057 mio_actual_arglist (&ns
->code
->ext
.actual
);
4059 flag
= ns
->code
->resolved_isym
!= NULL
;
4060 mio_integer (&flag
);
4062 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4064 mio_symbol_ref (&ns
->code
->resolved_sym
);
4069 pointer_info
*p1
= mio_symbol_ref (sym1
);
4070 pointer_info
*p2
= mio_symbol_ref (sym2
);
4072 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4073 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4074 /* Add hidden symbols to the symtree. */
4075 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4076 q
->u
.pointer
= (void *) ns
;
4077 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4079 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
4080 associate_integer_pointer (p1
, sym
);
4081 sym
->attr
.omp_udr_artificial_var
= 1;
4082 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4083 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4085 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
4086 associate_integer_pointer (p2
, sym
);
4087 sym
->attr
.omp_udr_artificial_var
= 1;
4088 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4090 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4091 mio_expr (&ns
->code
->expr1
);
4092 mio_expr (&ns
->code
->expr2
);
4097 ns
->code
= gfc_get_code (EXEC_CALL
);
4098 mio_symtree_ref (&ns
->code
->symtree
);
4099 mio_actual_arglist (&ns
->code
->ext
.actual
);
4101 mio_integer (&flag
);
4104 require_atom (ATOM_STRING
);
4105 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4109 mio_symbol_ref (&ns
->code
->resolved_sym
);
4111 ns
->code
->loc
= gfc_current_locus
;
4117 /* Unlike most other routines, the address of the symbol node is already
4118 fixed on input and the name/module has already been filled in.
4119 If you update the symbol format here, don't forget to update read_module
4120 as well (look for "seek to the symbol's component list"). */
4123 mio_symbol (gfc_symbol
*sym
)
4125 int intmod
= INTMOD_NONE
;
4129 mio_symbol_attribute (&sym
->attr
);
4131 /* Note that components are always saved, even if they are supposed
4132 to be private. Component access is checked during searching. */
4133 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4134 if (sym
->components
!= NULL
)
4135 sym
->component_access
4136 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4138 mio_typespec (&sym
->ts
);
4139 if (sym
->ts
.type
== BT_CLASS
)
4140 sym
->attr
.class_ok
= 1;
4142 if (iomode
== IO_OUTPUT
)
4143 mio_namespace_ref (&sym
->formal_ns
);
4146 mio_namespace_ref (&sym
->formal_ns
);
4148 sym
->formal_ns
->proc_name
= sym
;
4151 /* Save/restore common block links. */
4152 mio_symbol_ref (&sym
->common_next
);
4154 mio_formal_arglist (&sym
->formal
);
4156 if (sym
->attr
.flavor
== FL_PARAMETER
)
4157 mio_expr (&sym
->value
);
4159 mio_array_spec (&sym
->as
);
4161 mio_symbol_ref (&sym
->result
);
4163 if (sym
->attr
.cray_pointee
)
4164 mio_symbol_ref (&sym
->cp_pointer
);
4166 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4167 mio_full_f2k_derived (sym
);
4171 /* Add the fields that say whether this is from an intrinsic module,
4172 and if so, what symbol it is within the module. */
4173 /* mio_integer (&(sym->from_intmod)); */
4174 if (iomode
== IO_OUTPUT
)
4176 intmod
= sym
->from_intmod
;
4177 mio_integer (&intmod
);
4181 mio_integer (&intmod
);
4183 sym
->from_intmod
= current_intmod
;
4185 sym
->from_intmod
= (intmod_id
) intmod
;
4188 mio_integer (&(sym
->intmod_sym_id
));
4190 if (sym
->attr
.flavor
== FL_DERIVED
)
4191 mio_integer (&(sym
->hash_value
));
4194 && sym
->formal_ns
->proc_name
== sym
4195 && sym
->formal_ns
->entries
== NULL
)
4196 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4202 /************************* Top level subroutines *************************/
4204 /* Given a root symtree node and a symbol, try to find a symtree that
4205 references the symbol that is not a unique name. */
4207 static gfc_symtree
*
4208 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4210 gfc_symtree
*s
= NULL
;
4215 s
= find_symtree_for_symbol (st
->right
, sym
);
4218 s
= find_symtree_for_symbol (st
->left
, sym
);
4222 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4229 /* A recursive function to look for a specific symbol by name and by
4230 module. Whilst several symtrees might point to one symbol, its
4231 is sufficient for the purposes here than one exist. Note that
4232 generic interfaces are distinguished as are symbols that have been
4233 renamed in another module. */
4234 static gfc_symtree
*
4235 find_symbol (gfc_symtree
*st
, const char *name
,
4236 const char *module
, int generic
)
4239 gfc_symtree
*retval
, *s
;
4241 if (st
== NULL
|| st
->n
.sym
== NULL
)
4244 c
= strcmp (name
, st
->n
.sym
->name
);
4245 if (c
== 0 && st
->n
.sym
->module
4246 && strcmp (module
, st
->n
.sym
->module
) == 0
4247 && !check_unique_name (st
->name
))
4249 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4251 /* Detect symbols that are renamed by use association in another
4252 module by the absence of a symtree and null attr.use_rename,
4253 since the latter is not transmitted in the module file. */
4254 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4255 || (generic
&& st
->n
.sym
->attr
.generic
))
4256 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4260 retval
= find_symbol (st
->left
, name
, module
, generic
);
4263 retval
= find_symbol (st
->right
, name
, module
, generic
);
4269 /* Skip a list between balanced left and right parens.
4270 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4271 have been already parsed by hand, and the remaining of the content is to be
4272 skipped here. The default value is 0 (balanced parens). */
4275 skip_list (int nest_level
= 0)
4282 switch (parse_atom ())
4305 /* Load operator interfaces from the module. Interfaces are unusual
4306 in that they attach themselves to existing symbols. */
4309 load_operator_interfaces (void)
4312 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4314 pointer_info
*pi
= NULL
;
4319 while (peek_atom () != ATOM_RPAREN
)
4323 mio_internal_string (name
);
4324 mio_internal_string (module
);
4326 n
= number_use_names (name
, true);
4329 for (i
= 1; i
<= n
; i
++)
4331 /* Decide if we need to load this one or not. */
4332 p
= find_use_name_n (name
, &i
, true);
4336 while (parse_atom () != ATOM_RPAREN
);
4342 uop
= gfc_get_uop (p
);
4343 pi
= mio_interface_rest (&uop
->op
);
4347 if (gfc_find_uop (p
, NULL
))
4349 uop
= gfc_get_uop (p
);
4350 uop
->op
= gfc_get_interface ();
4351 uop
->op
->where
= gfc_current_locus
;
4352 add_fixup (pi
->integer
, &uop
->op
->sym
);
4361 /* Load interfaces from the module. Interfaces are unusual in that
4362 they attach themselves to existing symbols. */
4365 load_generic_interfaces (void)
4368 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4370 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4372 bool ambiguous_set
= false;
4376 while (peek_atom () != ATOM_RPAREN
)
4380 mio_internal_string (name
);
4381 mio_internal_string (module
);
4383 n
= number_use_names (name
, false);
4384 renamed
= n
? 1 : 0;
4387 for (i
= 1; i
<= n
; i
++)
4390 /* Decide if we need to load this one or not. */
4391 p
= find_use_name_n (name
, &i
, false);
4393 st
= find_symbol (gfc_current_ns
->sym_root
,
4394 name
, module_name
, 1);
4396 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4398 /* Skip the specific names for these cases. */
4399 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4404 /* If the symbol exists already and is being USEd without being
4405 in an ONLY clause, do not load a new symtree(11.3.2). */
4406 if (!only_flag
&& st
)
4414 if (strcmp (st
->name
, p
) != 0)
4416 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4422 /* Since we haven't found a valid generic interface, we had
4426 gfc_get_symbol (p
, NULL
, &sym
);
4427 sym
->name
= gfc_get_string (name
);
4428 sym
->module
= module_name
;
4429 sym
->attr
.flavor
= FL_PROCEDURE
;
4430 sym
->attr
.generic
= 1;
4431 sym
->attr
.use_assoc
= 1;
4436 /* Unless sym is a generic interface, this reference
4439 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4443 if (st
&& !sym
->attr
.generic
4446 && strcmp (module
, sym
->module
))
4448 ambiguous_set
= true;
4453 sym
->attr
.use_only
= only_flag
;
4454 sym
->attr
.use_rename
= renamed
;
4458 mio_interface_rest (&sym
->generic
);
4459 generic
= sym
->generic
;
4461 else if (!sym
->generic
)
4463 sym
->generic
= generic
;
4464 sym
->attr
.generic_copy
= 1;
4467 /* If a procedure that is not generic has generic interfaces
4468 that include itself, it is generic! We need to take care
4469 to retain symbols ambiguous that were already so. */
4470 if (sym
->attr
.use_assoc
4471 && !sym
->attr
.generic
4472 && sym
->attr
.flavor
== FL_PROCEDURE
)
4474 for (gen
= generic
; gen
; gen
= gen
->next
)
4476 if (gen
->sym
== sym
)
4478 sym
->attr
.generic
= 1;
4493 /* Load common blocks. */
4498 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4503 while (peek_atom () != ATOM_RPAREN
)
4508 mio_internal_string (name
);
4510 p
= gfc_get_common (name
, 1);
4512 mio_symbol_ref (&p
->head
);
4513 mio_integer (&flags
);
4517 p
->threadprivate
= 1;
4520 /* Get whether this was a bind(c) common or not. */
4521 mio_integer (&p
->is_bind_c
);
4522 /* Get the binding label. */
4523 label
= read_string ();
4525 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4535 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4536 so that unused variables are not loaded and so that the expression can
4542 gfc_equiv
*head
, *tail
, *end
, *eq
, *equiv
;
4546 in_load_equiv
= true;
4548 end
= gfc_current_ns
->equiv
;
4549 while (end
!= NULL
&& end
->next
!= NULL
)
4552 while (peek_atom () != ATOM_RPAREN
) {
4556 while(peek_atom () != ATOM_RPAREN
)
4559 head
= tail
= gfc_get_equiv ();
4562 tail
->eq
= gfc_get_equiv ();
4566 mio_pool_string (&tail
->module
);
4567 mio_expr (&tail
->expr
);
4570 /* Check for duplicate equivalences being loaded from different modules */
4572 for (equiv
= gfc_current_ns
->equiv
; equiv
; equiv
= equiv
->next
)
4574 if (equiv
->module
&& head
->module
4575 && strcmp (equiv
->module
, head
->module
) == 0)
4584 for (eq
= head
; eq
; eq
= head
)
4587 gfc_free_expr (eq
->expr
);
4593 gfc_current_ns
->equiv
= head
;
4604 in_load_equiv
= false;
4608 /* This function loads OpenMP user defined reductions. */
4610 load_omp_udrs (void)
4613 while (peek_atom () != ATOM_RPAREN
)
4615 const char *name
, *newname
;
4619 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4622 mio_pool_string (&name
);
4624 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4626 const char *p
= name
+ sizeof ("operator ") - 1;
4627 if (strcmp (p
, "+") == 0)
4628 rop
= OMP_REDUCTION_PLUS
;
4629 else if (strcmp (p
, "*") == 0)
4630 rop
= OMP_REDUCTION_TIMES
;
4631 else if (strcmp (p
, "-") == 0)
4632 rop
= OMP_REDUCTION_MINUS
;
4633 else if (strcmp (p
, ".and.") == 0)
4634 rop
= OMP_REDUCTION_AND
;
4635 else if (strcmp (p
, ".or.") == 0)
4636 rop
= OMP_REDUCTION_OR
;
4637 else if (strcmp (p
, ".eqv.") == 0)
4638 rop
= OMP_REDUCTION_EQV
;
4639 else if (strcmp (p
, ".neqv.") == 0)
4640 rop
= OMP_REDUCTION_NEQV
;
4643 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4645 size_t len
= strlen (name
+ 1);
4646 altname
= XALLOCAVEC (char, len
);
4647 gcc_assert (name
[len
] == '.');
4648 memcpy (altname
, name
+ 1, len
- 1);
4649 altname
[len
- 1] = '\0';
4652 if (rop
== OMP_REDUCTION_USER
)
4653 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4654 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4656 if (newname
== NULL
)
4661 if (altname
&& newname
!= altname
)
4663 size_t len
= strlen (newname
);
4664 altname
= XALLOCAVEC (char, len
+ 3);
4666 memcpy (altname
+ 1, newname
, len
);
4667 altname
[len
+ 1] = '.';
4668 altname
[len
+ 2] = '\0';
4669 name
= gfc_get_string (altname
);
4671 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4672 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4675 require_atom (ATOM_INTEGER
);
4676 pointer_info
*p
= get_integer (atom_int
);
4677 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4679 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4681 p
->u
.rsym
.module
, &gfc_current_locus
);
4682 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4684 udr
->omp_out
->module
, &udr
->where
);
4689 udr
= gfc_get_omp_udr ();
4693 udr
->where
= gfc_current_locus
;
4694 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4695 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4696 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4698 if (peek_atom () != ATOM_RPAREN
)
4700 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4701 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4702 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4703 udr
->initializer_ns
, true);
4707 udr
->next
= st
->n
.omp_udr
;
4708 st
->n
.omp_udr
= udr
;
4712 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4713 st
->n
.omp_udr
= udr
;
4721 /* Recursive function to traverse the pointer_info tree and load a
4722 needed symbol. We return nonzero if we load a symbol and stop the
4723 traversal, because the act of loading can alter the tree. */
4726 load_needed (pointer_info
*p
)
4737 rv
|= load_needed (p
->left
);
4738 rv
|= load_needed (p
->right
);
4740 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4743 p
->u
.rsym
.state
= USED
;
4745 set_module_locus (&p
->u
.rsym
.where
);
4747 sym
= p
->u
.rsym
.sym
;
4750 q
= get_integer (p
->u
.rsym
.ns
);
4752 ns
= (gfc_namespace
*) q
->u
.pointer
;
4755 /* Create an interface namespace if necessary. These are
4756 the namespaces that hold the formal parameters of module
4759 ns
= gfc_get_namespace (NULL
, 0);
4760 associate_integer_pointer (q
, ns
);
4763 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4764 doesn't go pear-shaped if the symbol is used. */
4766 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4769 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4770 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4771 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4772 if (p
->u
.rsym
.binding_label
)
4773 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4774 (p
->u
.rsym
.binding_label
));
4776 associate_integer_pointer (p
, sym
);
4780 sym
->attr
.use_assoc
= 1;
4782 /* Mark as only or rename for later diagnosis for explicitly imported
4783 but not used warnings; don't mark internal symbols such as __vtab,
4784 __def_init etc. Only mark them if they have been explicitly loaded. */
4786 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4790 /* Search the use/rename list for the variable; if the variable is
4792 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4794 if (strcmp (u
->use_name
, sym
->name
) == 0)
4796 sym
->attr
.use_only
= 1;
4802 if (p
->u
.rsym
.renamed
)
4803 sym
->attr
.use_rename
= 1;
4809 /* Recursive function for cleaning up things after a module has been read. */
4812 read_cleanup (pointer_info
*p
)
4820 read_cleanup (p
->left
);
4821 read_cleanup (p
->right
);
4823 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4826 /* Add hidden symbols to the symtree. */
4827 q
= get_integer (p
->u
.rsym
.ns
);
4828 ns
= (gfc_namespace
*) q
->u
.pointer
;
4830 if (!p
->u
.rsym
.sym
->attr
.vtype
4831 && !p
->u
.rsym
.sym
->attr
.vtab
)
4832 st
= gfc_get_unique_symtree (ns
);
4835 /* There is no reason to use 'unique_symtrees' for vtabs or
4836 vtypes - their name is fine for a symtree and reduces the
4837 namespace pollution. */
4838 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4840 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4843 st
->n
.sym
= p
->u
.rsym
.sym
;
4846 /* Fixup any symtree references. */
4847 p
->u
.rsym
.symtree
= st
;
4848 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4849 p
->u
.rsym
.stfixup
= NULL
;
4852 /* Free unused symbols. */
4853 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4854 gfc_free_symbol (p
->u
.rsym
.sym
);
4858 /* It is not quite enough to check for ambiguity in the symbols by
4859 the loaded symbol and the new symbol not being identical. */
4861 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
4865 symbol_attribute attr
;
4868 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
4870 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4871 "current program unit", st
->name
, module_name
);
4876 rsym
= info
->u
.rsym
.sym
;
4880 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4883 /* If the existing symbol is generic from a different module and
4884 the new symbol is generic there can be no ambiguity. */
4885 if (st_sym
->attr
.generic
4887 && st_sym
->module
!= module_name
)
4889 /* The new symbol's attributes have not yet been read. Since
4890 we need attr.generic, read it directly. */
4891 get_module_locus (&locus
);
4892 set_module_locus (&info
->u
.rsym
.where
);
4895 mio_symbol_attribute (&attr
);
4896 set_module_locus (&locus
);
4905 /* Read a module file. */
4910 module_locus operator_interfaces
, user_operators
, omp_udrs
;
4912 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4914 /* Workaround -Wmaybe-uninitialized false positive during
4915 profiledbootstrap by initializing them. */
4916 int ambiguous
= 0, j
, nuse
, symbol
= 0;
4917 pointer_info
*info
, *q
;
4918 gfc_use_rename
*u
= NULL
;
4922 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4925 get_module_locus (&user_operators
);
4929 /* Skip commons and equivalences for now. */
4933 /* Skip OpenMP UDRs. */
4934 get_module_locus (&omp_udrs
);
4939 /* Create the fixup nodes for all the symbols. */
4941 while (peek_atom () != ATOM_RPAREN
)
4944 require_atom (ATOM_INTEGER
);
4945 info
= get_integer (atom_int
);
4947 info
->type
= P_SYMBOL
;
4948 info
->u
.rsym
.state
= UNUSED
;
4950 info
->u
.rsym
.true_name
= read_string ();
4951 info
->u
.rsym
.module
= read_string ();
4952 bind_label
= read_string ();
4953 if (strlen (bind_label
))
4954 info
->u
.rsym
.binding_label
= bind_label
;
4956 XDELETEVEC (bind_label
);
4958 require_atom (ATOM_INTEGER
);
4959 info
->u
.rsym
.ns
= atom_int
;
4961 get_module_locus (&info
->u
.rsym
.where
);
4963 /* See if the symbol has already been loaded by a previous module.
4964 If so, we reference the existing symbol and prevent it from
4965 being loaded again. This should not happen if the symbol being
4966 read is an index for an assumed shape dummy array (ns != 1). */
4968 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4971 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4977 info
->u
.rsym
.state
= USED
;
4978 info
->u
.rsym
.sym
= sym
;
4979 /* The current symbol has already been loaded, so we can avoid loading
4980 it again. However, if it is a derived type, some of its components
4981 can be used in expressions in the module. To avoid the module loading
4982 failing, we need to associate the module's component pointer indexes
4983 with the existing symbol's component pointers. */
4984 if (sym
->attr
.flavor
== FL_DERIVED
)
4988 /* First seek to the symbol's component list. */
4989 mio_lparen (); /* symbol opening. */
4990 skip_list (); /* skip symbol attribute. */
4992 mio_lparen (); /* component list opening. */
4993 for (c
= sym
->components
; c
; c
= c
->next
)
4996 const char *comp_name
;
4999 mio_lparen (); /* component opening. */
5001 p
= get_integer (n
);
5002 if (p
->u
.pointer
== NULL
)
5003 associate_integer_pointer (p
, c
);
5004 mio_pool_string (&comp_name
);
5005 gcc_assert (comp_name
== c
->name
);
5006 skip_list (1); /* component end. */
5008 mio_rparen (); /* component list closing. */
5010 skip_list (1); /* symbol end. */
5015 /* Some symbols do not have a namespace (eg. formal arguments),
5016 so the automatic "unique symtree" mechanism must be suppressed
5017 by marking them as referenced. */
5018 q
= get_integer (info
->u
.rsym
.ns
);
5019 if (q
->u
.pointer
== NULL
)
5021 info
->u
.rsym
.referenced
= 1;
5025 /* If possible recycle the symtree that references the symbol.
5026 If a symtree is not found and the module does not import one,
5027 a unique-name symtree is found by read_cleanup. */
5028 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
5031 info
->u
.rsym
.symtree
= st
;
5032 info
->u
.rsym
.referenced
= 1;
5038 /* Parse the symtree lists. This lets us mark which symbols need to
5039 be loaded. Renaming is also done at this point by replacing the
5044 while (peek_atom () != ATOM_RPAREN
)
5046 mio_internal_string (name
);
5047 mio_integer (&ambiguous
);
5048 mio_integer (&symbol
);
5050 info
= get_integer (symbol
);
5052 /* See how many use names there are. If none, go through the start
5053 of the loop at least once. */
5054 nuse
= number_use_names (name
, false);
5055 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5060 for (j
= 1; j
<= nuse
; j
++)
5062 /* Get the jth local name for this symbol. */
5063 p
= find_use_name_n (name
, &j
, false);
5065 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5068 /* Exception: Always import vtabs & vtypes. */
5069 if (p
== NULL
&& name
[0] == '_'
5070 && (strncmp (name
, "__vtab_", 5) == 0
5071 || strncmp (name
, "__vtype_", 6) == 0))
5074 /* Skip symtree nodes not in an ONLY clause, unless there
5075 is an existing symtree loaded from another USE statement. */
5078 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5080 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5081 && st
->n
.sym
->module
!= NULL
5082 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5084 info
->u
.rsym
.symtree
= st
;
5085 info
->u
.rsym
.sym
= st
->n
.sym
;
5090 /* If a symbol of the same name and module exists already,
5091 this symbol, which is not in an ONLY clause, must not be
5092 added to the namespace(11.3.2). Note that find_symbol
5093 only returns the first occurrence that it finds. */
5094 if (!only_flag
&& !info
->u
.rsym
.renamed
5095 && strcmp (name
, module_name
) != 0
5096 && find_symbol (gfc_current_ns
->sym_root
, name
,
5100 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5104 /* Check for ambiguous symbols. */
5105 if (check_for_ambiguous (st
, info
))
5108 info
->u
.rsym
.symtree
= st
;
5112 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5114 /* Create a symtree node in the current namespace for this
5116 st
= check_unique_name (p
)
5117 ? gfc_get_unique_symtree (gfc_current_ns
)
5118 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5119 st
->ambiguous
= ambiguous
;
5121 sym
= info
->u
.rsym
.sym
;
5123 /* Create a symbol node if it doesn't already exist. */
5126 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5128 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
5129 sym
= info
->u
.rsym
.sym
;
5130 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5132 if (info
->u
.rsym
.binding_label
)
5133 sym
->binding_label
=
5134 IDENTIFIER_POINTER (get_identifier
5135 (info
->u
.rsym
.binding_label
));
5141 if (strcmp (name
, p
) != 0)
5142 sym
->attr
.use_rename
= 1;
5145 || (strncmp (name
, "__vtab_", 5) != 0
5146 && strncmp (name
, "__vtype_", 6) != 0))
5147 sym
->attr
.use_only
= only_flag
;
5149 /* Store the symtree pointing to this symbol. */
5150 info
->u
.rsym
.symtree
= st
;
5152 if (info
->u
.rsym
.state
== UNUSED
)
5153 info
->u
.rsym
.state
= NEEDED
;
5154 info
->u
.rsym
.referenced
= 1;
5161 /* Load intrinsic operator interfaces. */
5162 set_module_locus (&operator_interfaces
);
5165 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5167 if (i
== INTRINSIC_USER
)
5172 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5183 mio_interface (&gfc_current_ns
->op
[i
]);
5184 if (u
&& !gfc_current_ns
->op
[i
])
5190 /* Load generic and user operator interfaces. These must follow the
5191 loading of symtree because otherwise symbols can be marked as
5194 set_module_locus (&user_operators
);
5196 load_operator_interfaces ();
5197 load_generic_interfaces ();
5202 /* Load OpenMP user defined reductions. */
5203 set_module_locus (&omp_udrs
);
5206 /* At this point, we read those symbols that are needed but haven't
5207 been loaded yet. If one symbol requires another, the other gets
5208 marked as NEEDED if its previous state was UNUSED. */
5210 while (load_needed (pi_root
));
5212 /* Make sure all elements of the rename-list were found in the module. */
5214 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5219 if (u
->op
== INTRINSIC_NONE
)
5221 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5222 u
->use_name
, &u
->where
, module_name
);
5226 if (u
->op
== INTRINSIC_USER
)
5228 gfc_error ("User operator %qs referenced at %L not found "
5229 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5233 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5234 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5238 /* Clean up symbol nodes that were never loaded, create references
5239 to hidden symbols. */
5241 read_cleanup (pi_root
);
5245 /* Given an access type that is specific to an entity and the default
5246 access, return nonzero if the entity is publicly accessible. If the
5247 element is declared as PUBLIC, then it is public; if declared
5248 PRIVATE, then private, and otherwise it is public unless the default
5249 access in this context has been declared PRIVATE. */
5252 check_access (gfc_access specific_access
, gfc_access default_access
)
5254 if (specific_access
== ACCESS_PUBLIC
)
5256 if (specific_access
== ACCESS_PRIVATE
)
5259 if (flag_module_private
)
5260 return default_access
== ACCESS_PUBLIC
;
5262 return default_access
!= ACCESS_PRIVATE
;
5267 gfc_check_symbol_access (gfc_symbol
*sym
)
5269 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5272 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5276 /* A structure to remember which commons we've already written. */
5278 struct written_common
5280 BBT_HEADER(written_common
);
5281 const char *name
, *label
;
5284 static struct written_common
*written_commons
= NULL
;
5286 /* Comparison function used for balancing the binary tree. */
5289 compare_written_commons (void *a1
, void *b1
)
5291 const char *aname
= ((struct written_common
*) a1
)->name
;
5292 const char *alabel
= ((struct written_common
*) a1
)->label
;
5293 const char *bname
= ((struct written_common
*) b1
)->name
;
5294 const char *blabel
= ((struct written_common
*) b1
)->label
;
5295 int c
= strcmp (aname
, bname
);
5297 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5300 /* Free a list of written commons. */
5303 free_written_common (struct written_common
*w
)
5309 free_written_common (w
->left
);
5311 free_written_common (w
->right
);
5316 /* Write a common block to the module -- recursive helper function. */
5319 write_common_0 (gfc_symtree
*st
, bool this_module
)
5325 struct written_common
*w
;
5326 bool write_me
= true;
5331 write_common_0 (st
->left
, this_module
);
5333 /* We will write out the binding label, or "" if no label given. */
5334 name
= st
->n
.common
->name
;
5336 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5338 /* Check if we've already output this common. */
5339 w
= written_commons
;
5342 int c
= strcmp (name
, w
->name
);
5343 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5347 w
= (c
< 0) ? w
->left
: w
->right
;
5350 if (this_module
&& p
->use_assoc
)
5355 /* Write the common to the module. */
5357 mio_pool_string (&name
);
5359 mio_symbol_ref (&p
->head
);
5360 flags
= p
->saved
? 1 : 0;
5361 if (p
->threadprivate
)
5363 mio_integer (&flags
);
5365 /* Write out whether the common block is bind(c) or not. */
5366 mio_integer (&(p
->is_bind_c
));
5368 mio_pool_string (&label
);
5371 /* Record that we have written this common. */
5372 w
= XCNEW (struct written_common
);
5375 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5378 write_common_0 (st
->right
, this_module
);
5382 /* Write a common, by initializing the list of written commons, calling
5383 the recursive function write_common_0() and cleaning up afterwards. */
5386 write_common (gfc_symtree
*st
)
5388 written_commons
= NULL
;
5389 write_common_0 (st
, true);
5390 write_common_0 (st
, false);
5391 free_written_common (written_commons
);
5392 written_commons
= NULL
;
5396 /* Write the blank common block to the module. */
5399 write_blank_common (void)
5401 const char * name
= BLANK_COMMON_NAME
;
5403 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5404 this, but it hasn't been checked. Just making it so for now. */
5407 if (gfc_current_ns
->blank_common
.head
== NULL
)
5412 mio_pool_string (&name
);
5414 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5415 saved
= gfc_current_ns
->blank_common
.saved
;
5416 mio_integer (&saved
);
5418 /* Write out whether the common block is bind(c) or not. */
5419 mio_integer (&is_bind_c
);
5421 /* Write out an empty binding label. */
5422 write_atom (ATOM_STRING
, "");
5428 /* Write equivalences to the module. */
5437 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5441 for (e
= eq
; e
; e
= e
->eq
)
5443 if (e
->module
== NULL
)
5444 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5445 mio_allocated_string (e
->module
);
5446 mio_expr (&e
->expr
);
5455 /* Write a symbol to the module. */
5458 write_symbol (int n
, gfc_symbol
*sym
)
5462 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5463 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5467 if (sym
->attr
.flavor
== FL_DERIVED
)
5470 name
= dt_upper_string (sym
->name
);
5471 mio_pool_string (&name
);
5474 mio_pool_string (&sym
->name
);
5476 mio_pool_string (&sym
->module
);
5477 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5479 label
= sym
->binding_label
;
5480 mio_pool_string (&label
);
5483 write_atom (ATOM_STRING
, "");
5485 mio_pointer_ref (&sym
->ns
);
5492 /* Recursive traversal function to write the initial set of symbols to
5493 the module. We check to see if the symbol should be written
5494 according to the access specification. */
5497 write_symbol0 (gfc_symtree
*st
)
5501 bool dont_write
= false;
5506 write_symbol0 (st
->left
);
5509 if (sym
->module
== NULL
)
5510 sym
->module
= module_name
;
5512 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5513 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5516 if (!gfc_check_symbol_access (sym
))
5521 p
= get_pointer (sym
);
5522 if (p
->type
== P_UNKNOWN
)
5525 if (p
->u
.wsym
.state
!= WRITTEN
)
5527 write_symbol (p
->integer
, sym
);
5528 p
->u
.wsym
.state
= WRITTEN
;
5532 write_symbol0 (st
->right
);
5537 write_omp_udr (gfc_omp_udr
*udr
)
5541 case OMP_REDUCTION_USER
:
5542 /* Non-operators can't be used outside of the module. */
5543 if (udr
->name
[0] != '.')
5548 size_t len
= strlen (udr
->name
+ 1);
5549 char *name
= XALLOCAVEC (char, len
);
5550 memcpy (name
, udr
->name
, len
- 1);
5551 name
[len
- 1] = '\0';
5552 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5553 /* If corresponding user operator is private, don't write
5557 gfc_user_op
*uop
= st
->n
.uop
;
5558 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5563 case OMP_REDUCTION_PLUS
:
5564 case OMP_REDUCTION_MINUS
:
5565 case OMP_REDUCTION_TIMES
:
5566 case OMP_REDUCTION_AND
:
5567 case OMP_REDUCTION_OR
:
5568 case OMP_REDUCTION_EQV
:
5569 case OMP_REDUCTION_NEQV
:
5570 /* If corresponding operator is private, don't write the UDR. */
5571 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5572 gfc_current_ns
->default_access
))
5578 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5580 /* If derived type is private, don't write the UDR. */
5581 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5586 mio_pool_string (&udr
->name
);
5587 mio_typespec (&udr
->ts
);
5588 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5589 if (udr
->initializer_ns
)
5590 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5591 udr
->initializer_ns
, true);
5597 write_omp_udrs (gfc_symtree
*st
)
5602 write_omp_udrs (st
->left
);
5604 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5605 write_omp_udr (udr
);
5606 write_omp_udrs (st
->right
);
5610 /* Type for the temporary tree used when writing secondary symbols. */
5612 struct sorted_pointer_info
5614 BBT_HEADER (sorted_pointer_info
);
5619 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5621 /* Recursively traverse the temporary tree, free its contents. */
5624 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5629 free_sorted_pointer_info_tree (p
->left
);
5630 free_sorted_pointer_info_tree (p
->right
);
5635 /* Comparison function for the temporary tree. */
5638 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5640 sorted_pointer_info
*spi1
, *spi2
;
5641 spi1
= (sorted_pointer_info
*)_spi1
;
5642 spi2
= (sorted_pointer_info
*)_spi2
;
5644 if (spi1
->p
->integer
< spi2
->p
->integer
)
5646 if (spi1
->p
->integer
> spi2
->p
->integer
)
5652 /* Finds the symbols that need to be written and collects them in the
5653 sorted_pi tree so that they can be traversed in an order
5654 independent of memory addresses. */
5657 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5662 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5664 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5667 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5670 find_symbols_to_write (tree
, p
->left
);
5671 find_symbols_to_write (tree
, p
->right
);
5675 /* Recursive function that traverses the tree of symbols that need to be
5676 written and writes them in order. */
5679 write_symbol1_recursion (sorted_pointer_info
*sp
)
5684 write_symbol1_recursion (sp
->left
);
5686 pointer_info
*p1
= sp
->p
;
5687 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5689 p1
->u
.wsym
.state
= WRITTEN
;
5690 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5691 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5693 write_symbol1_recursion (sp
->right
);
5697 /* Write the secondary set of symbols to the module file. These are
5698 symbols that were not public yet are needed by the public symbols
5699 or another dependent symbol. The act of writing a symbol can add
5700 symbols to the pointer_info tree, so we return nonzero if a symbol
5701 was written and pass that information upwards. The caller will
5702 then call this function again until nothing was written. It uses
5703 the utility functions and a temporary tree to ensure a reproducible
5704 ordering of the symbol output and thus the module file. */
5707 write_symbol1 (pointer_info
*p
)
5712 /* Put symbols that need to be written into a tree sorted on the
5715 sorted_pointer_info
*spi_root
= NULL
;
5716 find_symbols_to_write (&spi_root
, p
);
5718 /* No symbols to write, return. */
5722 /* Otherwise, write and free the tree again. */
5723 write_symbol1_recursion (spi_root
);
5724 free_sorted_pointer_info_tree (spi_root
);
5730 /* Write operator interfaces associated with a symbol. */
5733 write_operator (gfc_user_op
*uop
)
5735 static char nullstring
[] = "";
5736 const char *p
= nullstring
;
5738 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5741 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5745 /* Write generic interfaces from the namespace sym_root. */
5748 write_generic (gfc_symtree
*st
)
5755 write_generic (st
->left
);
5758 if (sym
&& !check_unique_name (st
->name
)
5759 && sym
->generic
&& gfc_check_symbol_access (sym
))
5762 sym
->module
= module_name
;
5764 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5767 write_generic (st
->right
);
5772 write_symtree (gfc_symtree
*st
)
5779 /* A symbol in an interface body must not be visible in the
5781 if (sym
->ns
!= gfc_current_ns
5782 && sym
->ns
->proc_name
5783 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5786 if (!gfc_check_symbol_access (sym
)
5787 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5788 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5791 if (check_unique_name (st
->name
))
5794 p
= find_pointer (sym
);
5796 gfc_internal_error ("write_symtree(): Symbol not written");
5798 mio_pool_string (&st
->name
);
5799 mio_integer (&st
->ambiguous
);
5800 mio_integer (&p
->integer
);
5809 /* Write the operator interfaces. */
5812 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5814 if (i
== INTRINSIC_USER
)
5817 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5818 gfc_current_ns
->default_access
)
5819 ? &gfc_current_ns
->op
[i
] : NULL
);
5827 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5833 write_generic (gfc_current_ns
->sym_root
);
5839 write_blank_common ();
5840 write_common (gfc_current_ns
->common_root
);
5852 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5857 /* Write symbol information. First we traverse all symbols in the
5858 primary namespace, writing those that need to be written.
5859 Sometimes writing one symbol will cause another to need to be
5860 written. A list of these symbols ends up on the write stack, and
5861 we end by popping the bottom of the stack and writing the symbol
5862 until the stack is empty. */
5866 write_symbol0 (gfc_current_ns
->sym_root
);
5867 while (write_symbol1 (pi_root
))
5876 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5881 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5882 true on success, false on failure. */
5885 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5891 /* Open the file in binary mode. */
5892 if ((file
= fopen (filename
, "rb")) == NULL
)
5895 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5896 file. See RFC 1952. */
5897 if (fseek (file
, -8, SEEK_END
) != 0)
5903 /* Read the CRC32. */
5904 if (fread (buf
, 1, 4, file
) != 4)
5910 /* Close the file. */
5913 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
5914 + ((buf
[3] & 0xFF) << 24);
5917 /* For debugging, the CRC value printed in hexadecimal should match
5918 the CRC printed by "zcat -l -v filename".
5919 printf("CRC of file %s is %x\n", filename, val); */
5925 /* Given module, dump it to disk. If there was an error while
5926 processing the module, dump_flag will be set to zero and we delete
5927 the module file, even if it was already there. */
5930 gfc_dump_module (const char *name
, int dump_flag
)
5933 char *filename
, *filename_tmp
;
5936 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5937 if (gfc_option
.module_dir
!= NULL
)
5939 n
+= strlen (gfc_option
.module_dir
);
5940 filename
= (char *) alloca (n
);
5941 strcpy (filename
, gfc_option
.module_dir
);
5942 strcat (filename
, name
);
5946 filename
= (char *) alloca (n
);
5947 strcpy (filename
, name
);
5949 strcat (filename
, MODULE_EXTENSION
);
5951 /* Name of the temporary file used to write the module. */
5952 filename_tmp
= (char *) alloca (n
+ 1);
5953 strcpy (filename_tmp
, filename
);
5954 strcat (filename_tmp
, "0");
5956 /* There was an error while processing the module. We delete the
5957 module file, even if it was already there. */
5964 if (gfc_cpp_makedep ())
5965 gfc_cpp_add_target (filename
);
5967 /* Write the module to the temporary file. */
5968 module_fp
= gzopen (filename_tmp
, "w");
5969 if (module_fp
== NULL
)
5970 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
5971 filename_tmp
, xstrerror (errno
));
5973 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
5974 MOD_VERSION
, gfc_source_file
);
5976 /* Write the module itself. */
5978 module_name
= gfc_get_string (name
);
5984 free_pi_tree (pi_root
);
5989 if (gzclose (module_fp
))
5990 gfc_fatal_error ("Error writing module file %qs for writing: %s",
5991 filename_tmp
, xstrerror (errno
));
5993 /* Read the CRC32 from the gzip trailers of the module files and
5995 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
5996 || !read_crc32_from_module_file (filename
, &crc_old
)
5999 /* Module file have changed, replace the old one. */
6000 if (remove (filename
) && errno
!= ENOENT
)
6001 gfc_fatal_error ("Can't delete module file %qs: %s", filename
,
6003 if (rename (filename_tmp
, filename
))
6004 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6005 filename_tmp
, filename
, xstrerror (errno
));
6009 if (remove (filename_tmp
))
6010 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6011 filename_tmp
, xstrerror (errno
));
6017 create_intrinsic_function (const char *name
, int id
,
6018 const char *modname
, intmod_id module
,
6019 bool subroutine
, gfc_symbol
*result_type
)
6021 gfc_intrinsic_sym
*isym
;
6022 gfc_symtree
*tmp_symtree
;
6025 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6028 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6030 gfc_error ("Symbol %qs already declared", name
);
6033 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6034 sym
= tmp_symtree
->n
.sym
;
6038 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6039 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6040 sym
->attr
.subroutine
= 1;
6044 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6045 isym
= gfc_intrinsic_function_by_id (isym_id
);
6047 sym
->attr
.function
= 1;
6050 sym
->ts
.type
= BT_DERIVED
;
6051 sym
->ts
.u
.derived
= result_type
;
6052 sym
->ts
.is_c_interop
= 1;
6053 isym
->ts
.f90_type
= BT_VOID
;
6054 isym
->ts
.type
= BT_DERIVED
;
6055 isym
->ts
.f90_type
= BT_VOID
;
6056 isym
->ts
.u
.derived
= result_type
;
6057 isym
->ts
.is_c_interop
= 1;
6062 sym
->attr
.flavor
= FL_PROCEDURE
;
6063 sym
->attr
.intrinsic
= 1;
6065 sym
->module
= gfc_get_string (modname
);
6066 sym
->attr
.use_assoc
= 1;
6067 sym
->from_intmod
= module
;
6068 sym
->intmod_sym_id
= id
;
6072 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6073 the current namespace for all named constants, pointer types, and
6074 procedures in the module unless the only clause was used or a rename
6075 list was provided. */
6078 import_iso_c_binding_module (void)
6080 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6081 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6082 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6083 const char *iso_c_module_name
= "__iso_c_binding";
6086 bool want_c_ptr
= false, want_c_funptr
= false;
6088 /* Look only in the current namespace. */
6089 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6091 if (mod_symtree
== NULL
)
6093 /* symtree doesn't already exist in current namespace. */
6094 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6097 if (mod_symtree
!= NULL
)
6098 mod_sym
= mod_symtree
->n
.sym
;
6100 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6101 "create symbol for %s", iso_c_module_name
);
6103 mod_sym
->attr
.flavor
= FL_MODULE
;
6104 mod_sym
->attr
.intrinsic
= 1;
6105 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6106 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6109 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6110 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6112 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6114 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6117 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6120 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6122 want_c_funptr
= true;
6123 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6125 want_c_funptr
= true;
6126 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6129 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6130 (iso_c_binding_symbol
)
6132 u
->local_name
[0] ? u
->local_name
6136 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6140 = generate_isocbinding_symbol (iso_c_module_name
,
6141 (iso_c_binding_symbol
)
6143 u
->local_name
[0] ? u
->local_name
6149 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6150 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6151 (iso_c_binding_symbol
)
6153 NULL
, NULL
, only_flag
);
6154 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6155 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6156 (iso_c_binding_symbol
)
6158 NULL
, NULL
, only_flag
);
6160 /* Generate the symbols for the named constants representing
6161 the kinds for intrinsic data types. */
6162 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6165 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6166 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6175 #define NAMED_FUNCTION(a,b,c,d) \
6177 not_in_std = (gfc_option.allow_std & d) == 0; \
6180 #define NAMED_SUBROUTINE(a,b,c,d) \
6182 not_in_std = (gfc_option.allow_std & d) == 0; \
6185 #define NAMED_INTCST(a,b,c,d) \
6187 not_in_std = (gfc_option.allow_std & d) == 0; \
6190 #define NAMED_REALCST(a,b,c,d) \
6192 not_in_std = (gfc_option.allow_std & d) == 0; \
6195 #define NAMED_CMPXCST(a,b,c,d) \
6197 not_in_std = (gfc_option.allow_std & d) == 0; \
6200 #include "iso-c-binding.def"
6208 gfc_error ("The symbol %qs, referenced at %L, is not "
6209 "in the selected standard", name
, &u
->where
);
6215 #define NAMED_FUNCTION(a,b,c,d) \
6217 if (a == ISOCBINDING_LOC) \
6218 return_type = c_ptr->n.sym; \
6219 else if (a == ISOCBINDING_FUNLOC) \
6220 return_type = c_funptr->n.sym; \
6222 return_type = NULL; \
6223 create_intrinsic_function (u->local_name[0] \
6224 ? u->local_name : u->use_name, \
6225 a, iso_c_module_name, \
6226 INTMOD_ISO_C_BINDING, false, \
6229 #define NAMED_SUBROUTINE(a,b,c,d) \
6231 create_intrinsic_function (u->local_name[0] ? u->local_name \
6233 a, iso_c_module_name, \
6234 INTMOD_ISO_C_BINDING, true, NULL); \
6236 #include "iso-c-binding.def"
6238 case ISOCBINDING_PTR
:
6239 case ISOCBINDING_FUNPTR
:
6240 /* Already handled above. */
6243 if (i
== ISOCBINDING_NULL_PTR
)
6244 tmp_symtree
= c_ptr
;
6245 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6246 tmp_symtree
= c_funptr
;
6249 generate_isocbinding_symbol (iso_c_module_name
,
6250 (iso_c_binding_symbol
) i
,
6252 ? u
->local_name
: u
->use_name
,
6253 tmp_symtree
, false);
6257 if (!found
&& !only_flag
)
6259 /* Skip, if the symbol is not in the enabled standard. */
6262 #define NAMED_FUNCTION(a,b,c,d) \
6264 if ((gfc_option.allow_std & d) == 0) \
6267 #define NAMED_SUBROUTINE(a,b,c,d) \
6269 if ((gfc_option.allow_std & d) == 0) \
6272 #define NAMED_INTCST(a,b,c,d) \
6274 if ((gfc_option.allow_std & d) == 0) \
6277 #define NAMED_REALCST(a,b,c,d) \
6279 if ((gfc_option.allow_std & d) == 0) \
6282 #define NAMED_CMPXCST(a,b,c,d) \
6284 if ((gfc_option.allow_std & d) == 0) \
6287 #include "iso-c-binding.def"
6289 ; /* Not GFC_STD_* versioned. */
6294 #define NAMED_FUNCTION(a,b,c,d) \
6296 if (a == ISOCBINDING_LOC) \
6297 return_type = c_ptr->n.sym; \
6298 else if (a == ISOCBINDING_FUNLOC) \
6299 return_type = c_funptr->n.sym; \
6301 return_type = NULL; \
6302 create_intrinsic_function (b, a, iso_c_module_name, \
6303 INTMOD_ISO_C_BINDING, false, \
6306 #define NAMED_SUBROUTINE(a,b,c,d) \
6308 create_intrinsic_function (b, a, iso_c_module_name, \
6309 INTMOD_ISO_C_BINDING, true, NULL); \
6311 #include "iso-c-binding.def"
6313 case ISOCBINDING_PTR
:
6314 case ISOCBINDING_FUNPTR
:
6315 /* Already handled above. */
6318 if (i
== ISOCBINDING_NULL_PTR
)
6319 tmp_symtree
= c_ptr
;
6320 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6321 tmp_symtree
= c_funptr
;
6324 generate_isocbinding_symbol (iso_c_module_name
,
6325 (iso_c_binding_symbol
) i
, NULL
,
6326 tmp_symtree
, false);
6331 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6336 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6337 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6342 /* Add an integer named constant from a given module. */
6345 create_int_parameter (const char *name
, int value
, const char *modname
,
6346 intmod_id module
, int id
)
6348 gfc_symtree
*tmp_symtree
;
6351 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6352 if (tmp_symtree
!= NULL
)
6354 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6357 gfc_error ("Symbol %qs already declared", name
);
6360 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6361 sym
= tmp_symtree
->n
.sym
;
6363 sym
->module
= gfc_get_string (modname
);
6364 sym
->attr
.flavor
= FL_PARAMETER
;
6365 sym
->ts
.type
= BT_INTEGER
;
6366 sym
->ts
.kind
= gfc_default_integer_kind
;
6367 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6368 sym
->attr
.use_assoc
= 1;
6369 sym
->from_intmod
= module
;
6370 sym
->intmod_sym_id
= id
;
6374 /* Value is already contained by the array constructor, but not
6378 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6379 const char *modname
, intmod_id module
, int id
)
6381 gfc_symtree
*tmp_symtree
;
6384 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6385 if (tmp_symtree
!= NULL
)
6387 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6390 gfc_error ("Symbol %qs already declared", name
);
6393 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6394 sym
= tmp_symtree
->n
.sym
;
6396 sym
->module
= gfc_get_string (modname
);
6397 sym
->attr
.flavor
= FL_PARAMETER
;
6398 sym
->ts
.type
= BT_INTEGER
;
6399 sym
->ts
.kind
= gfc_default_integer_kind
;
6400 sym
->attr
.use_assoc
= 1;
6401 sym
->from_intmod
= module
;
6402 sym
->intmod_sym_id
= id
;
6403 sym
->attr
.dimension
= 1;
6404 sym
->as
= gfc_get_array_spec ();
6406 sym
->as
->type
= AS_EXPLICIT
;
6407 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6408 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6411 sym
->value
->shape
= gfc_get_shape (1);
6412 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6416 /* Add an derived type for a given module. */
6419 create_derived_type (const char *name
, const char *modname
,
6420 intmod_id module
, int id
)
6422 gfc_symtree
*tmp_symtree
;
6423 gfc_symbol
*sym
, *dt_sym
;
6424 gfc_interface
*intr
, *head
;
6426 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6427 if (tmp_symtree
!= NULL
)
6429 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6432 gfc_error ("Symbol %qs already declared", name
);
6435 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6436 sym
= tmp_symtree
->n
.sym
;
6437 sym
->module
= gfc_get_string (modname
);
6438 sym
->from_intmod
= module
;
6439 sym
->intmod_sym_id
= id
;
6440 sym
->attr
.flavor
= FL_PROCEDURE
;
6441 sym
->attr
.function
= 1;
6442 sym
->attr
.generic
= 1;
6444 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6445 gfc_current_ns
, &tmp_symtree
, false);
6446 dt_sym
= tmp_symtree
->n
.sym
;
6447 dt_sym
->name
= gfc_get_string (sym
->name
);
6448 dt_sym
->attr
.flavor
= FL_DERIVED
;
6449 dt_sym
->attr
.private_comp
= 1;
6450 dt_sym
->attr
.zero_comp
= 1;
6451 dt_sym
->attr
.use_assoc
= 1;
6452 dt_sym
->module
= gfc_get_string (modname
);
6453 dt_sym
->from_intmod
= module
;
6454 dt_sym
->intmod_sym_id
= id
;
6456 head
= sym
->generic
;
6457 intr
= gfc_get_interface ();
6459 intr
->where
= gfc_current_locus
;
6461 sym
->generic
= intr
;
6462 sym
->attr
.if_source
= IFSRC_DECL
;
6466 /* Read the contents of the module file into a temporary buffer. */
6469 read_module_to_tmpbuf ()
6471 /* We don't know the uncompressed size, so enlarge the buffer as
6477 module_content
= XNEWVEC (char, cursz
);
6481 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6486 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6487 rsize
= cursz
- len
;
6490 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6491 module_content
[len
] = '\0';
6497 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6500 use_iso_fortran_env_module (void)
6502 static char mod
[] = "iso_fortran_env";
6504 gfc_symbol
*mod_sym
;
6505 gfc_symtree
*mod_symtree
;
6509 intmod_sym symbol
[] = {
6510 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6511 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6512 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6513 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6514 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6515 #include "iso-fortran-env.def"
6516 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6519 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6520 #include "iso-fortran-env.def"
6522 /* Generate the symbol for the module itself. */
6523 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6524 if (mod_symtree
== NULL
)
6526 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6527 gcc_assert (mod_symtree
);
6528 mod_sym
= mod_symtree
->n
.sym
;
6530 mod_sym
->attr
.flavor
= FL_MODULE
;
6531 mod_sym
->attr
.intrinsic
= 1;
6532 mod_sym
->module
= gfc_get_string (mod
);
6533 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6536 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6537 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6538 "non-intrinsic module name used previously", mod
);
6540 /* Generate the symbols for the module integer named constants. */
6542 for (i
= 0; symbol
[i
].name
; i
++)
6545 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6547 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6552 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
6553 "referenced at %L, is not in the selected "
6554 "standard", symbol
[i
].name
, &u
->where
))
6557 if ((flag_default_integer
|| flag_default_real
)
6558 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6559 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6560 "constant from intrinsic module "
6561 "ISO_FORTRAN_ENV at %L is incompatible with "
6562 "option %qs", &u
->where
,
6563 flag_default_integer
6564 ? "-fdefault-integer-8"
6565 : "-fdefault-real-8");
6566 switch (symbol
[i
].id
)
6568 #define NAMED_INTCST(a,b,c,d) \
6570 #include "iso-fortran-env.def"
6571 create_int_parameter (u
->local_name
[0] ? u
->local_name
6573 symbol
[i
].value
, mod
,
6574 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6577 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6579 expr = gfc_get_array_expr (BT_INTEGER, \
6580 gfc_default_integer_kind,\
6582 for (j = 0; KINDS[j].kind != 0; j++) \
6583 gfc_constructor_append_expr (&expr->value.constructor, \
6584 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6585 KINDS[j].kind), NULL); \
6586 create_int_parameter_array (u->local_name[0] ? u->local_name \
6589 INTMOD_ISO_FORTRAN_ENV, \
6592 #include "iso-fortran-env.def"
6594 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6596 #include "iso-fortran-env.def"
6597 create_derived_type (u
->local_name
[0] ? u
->local_name
6599 mod
, INTMOD_ISO_FORTRAN_ENV
,
6603 #define NAMED_FUNCTION(a,b,c,d) \
6605 #include "iso-fortran-env.def"
6606 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6609 INTMOD_ISO_FORTRAN_ENV
, false,
6619 if (!found
&& !only_flag
)
6621 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6624 if ((flag_default_integer
|| flag_default_real
)
6625 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6627 "Use of the NUMERIC_STORAGE_SIZE named constant "
6628 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6629 "incompatible with option %s",
6630 flag_default_integer
6631 ? "-fdefault-integer-8" : "-fdefault-real-8");
6633 switch (symbol
[i
].id
)
6635 #define NAMED_INTCST(a,b,c,d) \
6637 #include "iso-fortran-env.def"
6638 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6639 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6642 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6644 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6646 for (j = 0; KINDS[j].kind != 0; j++) \
6647 gfc_constructor_append_expr (&expr->value.constructor, \
6648 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6649 KINDS[j].kind), NULL); \
6650 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6651 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6653 #include "iso-fortran-env.def"
6655 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6657 #include "iso-fortran-env.def"
6658 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6662 #define NAMED_FUNCTION(a,b,c,d) \
6664 #include "iso-fortran-env.def"
6665 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6666 INTMOD_ISO_FORTRAN_ENV
, false,
6676 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6681 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6682 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6687 /* Process a USE directive. */
6690 gfc_use_module (gfc_use_list
*module
)
6695 gfc_symtree
*mod_symtree
;
6696 gfc_use_list
*use_stmt
;
6697 locus old_locus
= gfc_current_locus
;
6699 gfc_current_locus
= module
->where
;
6700 module_name
= module
->module_name
;
6701 gfc_rename_list
= module
->rename
;
6702 only_flag
= module
->only_flag
;
6703 current_intmod
= INTMOD_NONE
;
6706 gfc_warning_now (OPT_Wuse_without_only
,
6707 "USE statement at %C has no ONLY qualifier");
6709 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6711 strcpy (filename
, module_name
);
6712 strcat (filename
, MODULE_EXTENSION
);
6714 /* First, try to find an non-intrinsic module, unless the USE statement
6715 specified that the module is intrinsic. */
6717 if (!module
->intrinsic
)
6718 module_fp
= gzopen_included_file (filename
, true, true);
6720 /* Then, see if it's an intrinsic one, unless the USE statement
6721 specified that the module is non-intrinsic. */
6722 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6724 if (strcmp (module_name
, "iso_fortran_env") == 0
6725 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6726 "intrinsic module at %C"))
6728 use_iso_fortran_env_module ();
6729 free_rename (module
->rename
);
6730 module
->rename
= NULL
;
6731 gfc_current_locus
= old_locus
;
6732 module
->intrinsic
= true;
6736 if (strcmp (module_name
, "iso_c_binding") == 0
6737 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6739 import_iso_c_binding_module();
6740 free_rename (module
->rename
);
6741 module
->rename
= NULL
;
6742 gfc_current_locus
= old_locus
;
6743 module
->intrinsic
= true;
6747 module_fp
= gzopen_intrinsic_module (filename
);
6749 if (module_fp
== NULL
&& module
->intrinsic
)
6750 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6753 /* Check for the IEEE modules, so we can mark their symbols
6754 accordingly when we read them. */
6755 if (strcmp (module_name
, "ieee_features") == 0
6756 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
6758 current_intmod
= INTMOD_IEEE_FEATURES
;
6760 else if (strcmp (module_name
, "ieee_exceptions") == 0
6761 && gfc_notify_std (GFC_STD_F2003
,
6762 "IEEE_EXCEPTIONS module at %C"))
6764 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
6766 else if (strcmp (module_name
, "ieee_arithmetic") == 0
6767 && gfc_notify_std (GFC_STD_F2003
,
6768 "IEEE_ARITHMETIC module at %C"))
6770 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
6774 if (module_fp
== NULL
)
6775 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6776 filename
, xstrerror (errno
));
6778 /* Check that we haven't already USEd an intrinsic module with the
6781 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6782 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6783 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6784 "intrinsic module name used previously", module_name
);
6791 read_module_to_tmpbuf ();
6792 gzclose (module_fp
);
6794 /* Skip the first line of the module, after checking that this is
6795 a gfortran module file. */
6801 bad_module ("Unexpected end of module");
6804 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6805 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6806 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6807 " module file", filename
);
6810 if (strcmp (atom_name
, " version") != 0
6811 || module_char () != ' '
6812 || parse_atom () != ATOM_STRING
6813 || strcmp (atom_string
, MOD_VERSION
))
6814 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6815 " because it was created by a different"
6816 " version of GNU Fortran", filename
);
6825 /* Make sure we're not reading the same module that we may be building. */
6826 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6827 if ((p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
)
6828 && strcmp (p
->sym
->name
, module_name
) == 0)
6829 gfc_fatal_error ("Can't USE the same %smodule we're building!",
6830 p
->state
== COMP_SUBMODULE
? "sub" : "");
6833 init_true_name_tree ();
6837 free_true_name (true_name_root
);
6838 true_name_root
= NULL
;
6840 free_pi_tree (pi_root
);
6843 XDELETEVEC (module_content
);
6844 module_content
= NULL
;
6846 use_stmt
= gfc_get_use_list ();
6847 *use_stmt
= *module
;
6848 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6849 gfc_current_ns
->use_stmts
= use_stmt
;
6851 gfc_current_locus
= old_locus
;
6855 /* Remove duplicated intrinsic operators from the rename list. */
6858 rename_list_remove_duplicate (gfc_use_rename
*list
)
6860 gfc_use_rename
*seek
, *last
;
6862 for (; list
; list
= list
->next
)
6863 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6866 for (seek
= list
->next
; seek
; seek
= last
->next
)
6868 if (list
->op
== seek
->op
)
6870 last
->next
= seek
->next
;
6880 /* Process all USE directives. */
6883 gfc_use_modules (void)
6885 gfc_use_list
*next
, *seek
, *last
;
6887 for (next
= module_list
; next
; next
= next
->next
)
6889 bool non_intrinsic
= next
->non_intrinsic
;
6890 bool intrinsic
= next
->intrinsic
;
6891 bool neither
= !non_intrinsic
&& !intrinsic
;
6893 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6895 if (next
->module_name
!= seek
->module_name
)
6898 if (seek
->non_intrinsic
)
6899 non_intrinsic
= true;
6900 else if (seek
->intrinsic
)
6906 if (intrinsic
&& neither
&& !non_intrinsic
)
6911 filename
= XALLOCAVEC (char,
6912 strlen (next
->module_name
)
6913 + strlen (MODULE_EXTENSION
) + 1);
6914 strcpy (filename
, next
->module_name
);
6915 strcat (filename
, MODULE_EXTENSION
);
6916 fp
= gfc_open_included_file (filename
, true, true);
6919 non_intrinsic
= true;
6925 for (seek
= next
->next
; seek
; seek
= last
->next
)
6927 if (next
->module_name
!= seek
->module_name
)
6933 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6934 || (next
->intrinsic
&& seek
->intrinsic
)
6937 if (!seek
->only_flag
)
6938 next
->only_flag
= false;
6941 gfc_use_rename
*r
= seek
->rename
;
6944 r
->next
= next
->rename
;
6945 next
->rename
= seek
->rename
;
6947 last
->next
= seek
->next
;
6955 for (; module_list
; module_list
= next
)
6957 next
= module_list
->next
;
6958 rename_list_remove_duplicate (module_list
->rename
);
6959 gfc_use_module (module_list
);
6962 gfc_rename_list
= NULL
;
6967 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6970 for (; use_stmts
; use_stmts
= next
)
6972 gfc_use_rename
*next_rename
;
6974 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6976 next_rename
= use_stmts
->rename
->next
;
6977 free (use_stmts
->rename
);
6979 next
= use_stmts
->next
;
6986 gfc_module_init_2 (void)
6988 last_atom
= ATOM_LPAREN
;
6989 gfc_rename_list
= NULL
;
6995 gfc_module_done_2 (void)
6997 free_rename (gfc_rename_list
);
6998 gfc_rename_list
= NULL
;