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"
84 #include "stringpool.h"
88 #define MODULE_EXTENSION ".mod"
90 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
92 #define MOD_VERSION "14"
95 /* Structure that describes a position within a module file. */
104 /* Structure for list of symbols of intrinsic modules. */
117 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
121 /* The fixup structure lists pointers to pointers that have to
122 be updated when a pointer value becomes known. */
124 typedef struct fixup_t
127 struct fixup_t
*next
;
132 /* Structure for holding extra info needed for pointers being read. */
148 typedef struct pointer_info
150 BBT_HEADER (pointer_info
);
154 /* The first component of each member of the union is the pointer
161 void *pointer
; /* Member for doing pointer searches. */
166 char *true_name
, *module
, *binding_label
;
168 gfc_symtree
*symtree
;
169 enum gfc_rsym_state state
;
170 int ns
, referenced
, renamed
;
178 enum gfc_wsym_state state
;
187 #define gfc_get_pointer_info() XCNEW (pointer_info)
190 /* Local variables */
192 /* The gzFile for the module we're reading or writing. */
193 static gzFile module_fp
;
196 /* The name of the module we're reading (USE'ing) or writing. */
197 static const char *module_name
;
198 static gfc_use_list
*module_list
;
200 /* If we're reading an intrinsic module, this is its ID. */
201 static intmod_id current_intmod
;
203 /* Content of module. */
204 static char* module_content
;
206 static long module_pos
;
207 static int module_line
, module_column
, only_flag
;
208 static int prev_module_line
, prev_module_column
;
211 { IO_INPUT
, IO_OUTPUT
}
214 static gfc_use_rename
*gfc_rename_list
;
215 static pointer_info
*pi_root
;
216 static int symbol_number
; /* Counter for assigning symbol numbers */
218 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
219 static bool in_load_equiv
;
223 /*****************************************************************/
225 /* Pointer/integer conversion. Pointers between structures are stored
226 as integers in the module file. The next couple of subroutines
227 handle this translation for reading and writing. */
229 /* Recursively free the tree of pointer structures. */
232 free_pi_tree (pointer_info
*p
)
237 if (p
->fixup
!= NULL
)
238 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
240 free_pi_tree (p
->left
);
241 free_pi_tree (p
->right
);
243 if (iomode
== IO_INPUT
)
245 XDELETEVEC (p
->u
.rsym
.true_name
);
246 XDELETEVEC (p
->u
.rsym
.module
);
247 XDELETEVEC (p
->u
.rsym
.binding_label
);
254 /* Compare pointers when searching by pointer. Used when writing a
258 compare_pointers (void *_sn1
, void *_sn2
)
260 pointer_info
*sn1
, *sn2
;
262 sn1
= (pointer_info
*) _sn1
;
263 sn2
= (pointer_info
*) _sn2
;
265 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
267 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
274 /* Compare integers when searching by integer. Used when reading a
278 compare_integers (void *_sn1
, void *_sn2
)
280 pointer_info
*sn1
, *sn2
;
282 sn1
= (pointer_info
*) _sn1
;
283 sn2
= (pointer_info
*) _sn2
;
285 if (sn1
->integer
< sn2
->integer
)
287 if (sn1
->integer
> sn2
->integer
)
294 /* Initialize the pointer_info tree. */
303 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
305 /* Pointer 0 is the NULL pointer. */
306 p
= gfc_get_pointer_info ();
311 gfc_insert_bbt (&pi_root
, p
, compare
);
313 /* Pointer 1 is the current namespace. */
314 p
= gfc_get_pointer_info ();
315 p
->u
.pointer
= gfc_current_ns
;
317 p
->type
= P_NAMESPACE
;
319 gfc_insert_bbt (&pi_root
, p
, compare
);
325 /* During module writing, call here with a pointer to something,
326 returning the pointer_info node. */
328 static pointer_info
*
329 find_pointer (void *gp
)
336 if (p
->u
.pointer
== gp
)
338 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
345 /* Given a pointer while writing, returns the pointer_info tree node,
346 creating it if it doesn't exist. */
348 static pointer_info
*
349 get_pointer (void *gp
)
353 p
= find_pointer (gp
);
357 /* Pointer doesn't have an integer. Give it one. */
358 p
= gfc_get_pointer_info ();
361 p
->integer
= symbol_number
++;
363 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
369 /* Given an integer during reading, find it in the pointer_info tree,
370 creating the node if not found. */
372 static pointer_info
*
373 get_integer (int integer
)
383 c
= compare_integers (&t
, p
);
387 p
= (c
< 0) ? p
->left
: p
->right
;
393 p
= gfc_get_pointer_info ();
394 p
->integer
= integer
;
397 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
403 /* Resolve any fixups using a known pointer. */
406 resolve_fixups (fixup_t
*f
, void *gp
)
419 /* Convert a string such that it starts with a lower-case character. Used
420 to convert the symtree name of a derived-type to the symbol name or to
421 the name of the associated generic function. */
424 dt_lower_string (const char *name
)
426 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
427 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
429 return gfc_get_string (name
);
433 /* Convert a string such that it starts with an upper-case character. Used to
434 return the symtree-name for a derived type; the symbol name itself and the
435 symtree/symbol name of the associated generic function start with a lower-
439 dt_upper_string (const char *name
)
441 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
442 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
444 return gfc_get_string (name
);
447 /* Call here during module reading when we know what pointer to
448 associate with an integer. Any fixups that exist are resolved at
452 associate_integer_pointer (pointer_info
*p
, void *gp
)
454 if (p
->u
.pointer
!= NULL
)
455 gfc_internal_error ("associate_integer_pointer(): Already associated");
459 resolve_fixups (p
->fixup
, gp
);
465 /* During module reading, given an integer and a pointer to a pointer,
466 either store the pointer from an already-known value or create a
467 fixup structure in order to store things later. Returns zero if
468 the reference has been actually stored, or nonzero if the reference
469 must be fixed later (i.e., associate_integer_pointer must be called
470 sometime later. Returns the pointer_info structure. */
472 static pointer_info
*
473 add_fixup (int integer
, void *gp
)
479 p
= get_integer (integer
);
481 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
484 *cp
= (char *) p
->u
.pointer
;
493 f
->pointer
= (void **) gp
;
500 /*****************************************************************/
502 /* Parser related subroutines */
504 /* Free the rename list left behind by a USE statement. */
507 free_rename (gfc_use_rename
*list
)
509 gfc_use_rename
*next
;
511 for (; list
; list
= next
)
519 /* Match a USE statement. */
524 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
525 gfc_use_rename
*tail
= NULL
, *new_use
;
526 interface_type type
, type2
;
529 gfc_use_list
*use_list
;
531 use_list
= gfc_get_use_list ();
533 if (gfc_match (" , ") == MATCH_YES
)
535 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
537 if (!gfc_notify_std (GFC_STD_F2003
, "module "
538 "nature in USE statement at %C"))
541 if (strcmp (module_nature
, "intrinsic") == 0)
542 use_list
->intrinsic
= true;
545 if (strcmp (module_nature
, "non_intrinsic") == 0)
546 use_list
->non_intrinsic
= true;
549 gfc_error ("Module nature in USE statement at %C shall "
550 "be either INTRINSIC or NON_INTRINSIC");
557 /* Help output a better error message than "Unclassifiable
559 gfc_match (" %n", module_nature
);
560 if (strcmp (module_nature
, "intrinsic") == 0
561 || strcmp (module_nature
, "non_intrinsic") == 0)
562 gfc_error ("\"::\" was expected after module nature at %C "
563 "but was not found");
570 m
= gfc_match (" ::");
571 if (m
== MATCH_YES
&&
572 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
577 m
= gfc_match ("% ");
586 use_list
->where
= gfc_current_locus
;
588 m
= gfc_match_name (name
);
595 use_list
->module_name
= gfc_get_string (name
);
597 if (gfc_match_eos () == MATCH_YES
)
600 if (gfc_match_char (',') != MATCH_YES
)
603 if (gfc_match (" only :") == MATCH_YES
)
604 use_list
->only_flag
= true;
606 if (gfc_match_eos () == MATCH_YES
)
611 /* Get a new rename struct and add it to the rename list. */
612 new_use
= gfc_get_use_rename ();
613 new_use
->where
= gfc_current_locus
;
616 if (use_list
->rename
== NULL
)
617 use_list
->rename
= new_use
;
619 tail
->next
= new_use
;
622 /* See what kind of interface we're dealing with. Assume it is
624 new_use
->op
= INTRINSIC_NONE
;
625 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
630 case INTERFACE_NAMELESS
:
631 gfc_error ("Missing generic specification in USE statement at %C");
634 case INTERFACE_USER_OP
:
635 case INTERFACE_GENERIC
:
636 m
= gfc_match (" =>");
638 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
639 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
640 "operators in USE statements at %C")))
643 if (type
== INTERFACE_USER_OP
)
644 new_use
->op
= INTRINSIC_USER
;
646 if (use_list
->only_flag
)
649 strcpy (new_use
->use_name
, name
);
652 strcpy (new_use
->local_name
, name
);
653 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
658 if (m
== MATCH_ERROR
)
666 strcpy (new_use
->local_name
, name
);
668 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
673 if (m
== MATCH_ERROR
)
677 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
678 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
680 gfc_error ("The name %qs at %C has already been used as "
681 "an external module name.", use_list
->module_name
);
686 case INTERFACE_INTRINSIC_OP
:
694 if (gfc_match_eos () == MATCH_YES
)
696 if (gfc_match_char (',') != MATCH_YES
)
703 gfc_use_list
*last
= module_list
;
706 last
->next
= use_list
;
709 module_list
= use_list
;
714 gfc_syntax_error (ST_USE
);
717 free_rename (use_list
->rename
);
723 /* Given a name and a number, inst, return the inst name
724 under which to load this symbol. Returns NULL if this
725 symbol shouldn't be loaded. If inst is zero, returns
726 the number of instances of this name. If interface is
727 true, a user-defined operator is sought, otherwise only
728 non-operators are sought. */
731 find_use_name_n (const char *name
, int *inst
, bool interface
)
734 const char *low_name
= NULL
;
737 /* For derived types. */
738 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
739 low_name
= dt_lower_string (name
);
742 for (u
= gfc_rename_list
; u
; u
= u
->next
)
744 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
745 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
746 || (u
->op
== INTRINSIC_USER
&& !interface
)
747 || (u
->op
!= INTRINSIC_USER
&& interface
))
760 return only_flag
? NULL
: name
;
766 if (u
->local_name
[0] == '\0')
768 return dt_upper_string (u
->local_name
);
771 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
775 /* Given a name, return the name under which to load this symbol.
776 Returns NULL if this symbol shouldn't be loaded. */
779 find_use_name (const char *name
, bool interface
)
782 return find_use_name_n (name
, &i
, interface
);
786 /* Given a real name, return the number of use names associated with it. */
789 number_use_names (const char *name
, bool interface
)
792 find_use_name_n (name
, &i
, interface
);
797 /* Try to find the operator in the current list. */
799 static gfc_use_rename
*
800 find_use_operator (gfc_intrinsic_op op
)
804 for (u
= gfc_rename_list
; u
; u
= u
->next
)
812 /*****************************************************************/
814 /* The next couple of subroutines maintain a tree used to avoid a
815 brute-force search for a combination of true name and module name.
816 While symtree names, the name that a particular symbol is known by
817 can changed with USE statements, we still have to keep track of the
818 true names to generate the correct reference, and also avoid
819 loading the same real symbol twice in a program unit.
821 When we start reading, the true name tree is built and maintained
822 as symbols are read. The tree is searched as we load new symbols
823 to see if it already exists someplace in the namespace. */
825 typedef struct true_name
827 BBT_HEADER (true_name
);
833 static true_name
*true_name_root
;
836 /* Compare two true_name structures. */
839 compare_true_names (void *_t1
, void *_t2
)
844 t1
= (true_name
*) _t1
;
845 t2
= (true_name
*) _t2
;
847 c
= ((t1
->sym
->module
> t2
->sym
->module
)
848 - (t1
->sym
->module
< t2
->sym
->module
));
852 return strcmp (t1
->name
, t2
->name
);
856 /* Given a true name, search the true name tree to see if it exists
857 within the main namespace. */
860 find_true_name (const char *name
, const char *module
)
866 t
.name
= gfc_get_string (name
);
868 sym
.module
= gfc_get_string (module
);
876 c
= compare_true_names ((void *) (&t
), (void *) p
);
880 p
= (c
< 0) ? p
->left
: p
->right
;
887 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
890 add_true_name (gfc_symbol
*sym
)
894 t
= XCNEW (true_name
);
896 if (sym
->attr
.flavor
== FL_DERIVED
)
897 t
->name
= dt_upper_string (sym
->name
);
901 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
905 /* Recursive function to build the initial true name tree by
906 recursively traversing the current namespace. */
909 build_tnt (gfc_symtree
*st
)
915 build_tnt (st
->left
);
916 build_tnt (st
->right
);
918 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
919 name
= dt_upper_string (st
->n
.sym
->name
);
921 name
= st
->n
.sym
->name
;
923 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
926 add_true_name (st
->n
.sym
);
930 /* Initialize the true name tree with the current namespace. */
933 init_true_name_tree (void)
935 true_name_root
= NULL
;
936 build_tnt (gfc_current_ns
->sym_root
);
940 /* Recursively free a true name tree node. */
943 free_true_name (true_name
*t
)
947 free_true_name (t
->left
);
948 free_true_name (t
->right
);
954 /*****************************************************************/
956 /* Module reading and writing. */
958 /* The following are versions similar to the ones in scanner.c, but
959 for dealing with compressed module files. */
962 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
963 bool module
, bool system
)
966 gfc_directorylist
*p
;
969 for (p
= list
; p
; p
= p
->next
)
971 if (module
&& !p
->use_for_modules
)
974 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
975 strcpy (fullname
, p
->path
);
976 strcat (fullname
, name
);
978 f
= gzopen (fullname
, "r");
981 if (gfc_cpp_makedep ())
982 gfc_cpp_add_dep (fullname
, system
);
992 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
996 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
998 f
= gzopen (name
, "r");
999 if (f
&& gfc_cpp_makedep ())
1000 gfc_cpp_add_dep (name
, false);
1004 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1010 gzopen_intrinsic_module (const char* name
)
1014 if (IS_ABSOLUTE_PATH (name
))
1016 f
= gzopen (name
, "r");
1017 if (f
&& gfc_cpp_makedep ())
1018 gfc_cpp_add_dep (name
, true);
1022 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1030 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1034 static atom_type last_atom
;
1037 /* The name buffer must be at least as long as a symbol name. Right
1038 now it's not clear how we're going to store numeric constants--
1039 probably as a hexadecimal string, since this will allow the exact
1040 number to be preserved (this can't be done by a decimal
1041 representation). Worry about that later. TODO! */
1043 #define MAX_ATOM_SIZE 100
1045 static int atom_int
;
1046 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1049 /* Report problems with a module. Error reporting is not very
1050 elaborate, since this sorts of errors shouldn't really happen.
1051 This subroutine never returns. */
1053 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1056 bad_module (const char *msgid
)
1058 XDELETEVEC (module_content
);
1059 module_content
= NULL
;
1064 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1065 module_name
, module_line
, module_column
, msgid
);
1068 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1069 module_name
, module_line
, module_column
, msgid
);
1072 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1073 module_name
, module_line
, module_column
, msgid
);
1079 /* Set the module's input pointer. */
1082 set_module_locus (module_locus
*m
)
1084 module_column
= m
->column
;
1085 module_line
= m
->line
;
1086 module_pos
= m
->pos
;
1090 /* Get the module's input pointer so that we can restore it later. */
1093 get_module_locus (module_locus
*m
)
1095 m
->column
= module_column
;
1096 m
->line
= module_line
;
1097 m
->pos
= module_pos
;
1101 /* Get the next character in the module, updating our reckoning of
1107 const char c
= module_content
[module_pos
++];
1109 bad_module ("Unexpected EOF");
1111 prev_module_line
= module_line
;
1112 prev_module_column
= module_column
;
1124 /* Unget a character while remembering the line and column. Works for
1125 a single character only. */
1128 module_unget_char (void)
1130 module_line
= prev_module_line
;
1131 module_column
= prev_module_column
;
1135 /* Parse a string constant. The delimiter is guaranteed to be a
1145 atom_string
= XNEWVEC (char, cursz
);
1153 int c2
= module_char ();
1156 module_unget_char ();
1164 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1166 atom_string
[len
] = c
;
1170 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1171 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1175 /* Parse a small integer. */
1178 parse_integer (int c
)
1187 module_unget_char ();
1191 atom_int
= 10 * atom_int
+ c
- '0';
1192 if (atom_int
> 99999999)
1193 bad_module ("Integer overflow");
1215 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1217 module_unget_char ();
1222 if (++len
> GFC_MAX_SYMBOL_LEN
)
1223 bad_module ("Name too long");
1231 /* Read the next atom in the module's input stream. */
1242 while (c
== ' ' || c
== '\r' || c
== '\n');
1267 return ATOM_INTEGER
;
1325 bad_module ("Bad name");
1332 /* Peek at the next atom on the input. */
1343 while (c
== ' ' || c
== '\r' || c
== '\n');
1348 module_unget_char ();
1352 module_unget_char ();
1356 module_unget_char ();
1369 module_unget_char ();
1370 return ATOM_INTEGER
;
1424 module_unget_char ();
1428 bad_module ("Bad name");
1433 /* Read the next atom from the input, requiring that it be a
1437 require_atom (atom_type type
)
1443 column
= module_column
;
1452 p
= _("Expected name");
1455 p
= _("Expected left parenthesis");
1458 p
= _("Expected right parenthesis");
1461 p
= _("Expected integer");
1464 p
= _("Expected string");
1467 gfc_internal_error ("require_atom(): bad atom type required");
1470 module_column
= column
;
1477 /* Given a pointer to an mstring array, require that the current input
1478 be one of the strings in the array. We return the enum value. */
1481 find_enum (const mstring
*m
)
1485 i
= gfc_string2code (m
, atom_name
);
1489 bad_module ("find_enum(): Enum not found");
1495 /* Read a string. The caller is responsible for freeing. */
1501 require_atom (ATOM_STRING
);
1508 /**************** Module output subroutines ***************************/
1510 /* Output a character to a module file. */
1513 write_char (char out
)
1515 if (gzputc (module_fp
, out
) == EOF
)
1516 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1528 /* Write an atom to a module. The line wrapping isn't perfect, but it
1529 should work most of the time. This isn't that big of a deal, since
1530 the file really isn't meant to be read by people anyway. */
1533 write_atom (atom_type atom
, const void *v
)
1537 /* Workaround -Wmaybe-uninitialized false positive during
1538 profiledbootstrap by initializing them. */
1546 p
= (const char *) v
;
1558 i
= *((const int *) v
);
1560 gfc_internal_error ("write_atom(): Writing negative integer");
1562 sprintf (buffer
, "%d", i
);
1567 gfc_internal_error ("write_atom(): Trying to write dab atom");
1571 if(p
== NULL
|| *p
== '\0')
1576 if (atom
!= ATOM_RPAREN
)
1578 if (module_column
+ len
> 72)
1583 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1588 if (atom
== ATOM_STRING
)
1591 while (p
!= NULL
&& *p
)
1593 if (atom
== ATOM_STRING
&& *p
== '\'')
1598 if (atom
== ATOM_STRING
)
1606 /***************** Mid-level I/O subroutines *****************/
1608 /* These subroutines let their caller read or write atoms without
1609 caring about which of the two is actually happening. This lets a
1610 subroutine concentrate on the actual format of the data being
1613 static void mio_expr (gfc_expr
**);
1614 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1615 pointer_info
*mio_interface_rest (gfc_interface
**);
1616 static void mio_symtree_ref (gfc_symtree
**);
1618 /* Read or write an enumerated value. On writing, we return the input
1619 value for the convenience of callers. We avoid using an integer
1620 pointer because enums are sometimes inside bitfields. */
1623 mio_name (int t
, const mstring
*m
)
1625 if (iomode
== IO_OUTPUT
)
1626 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1629 require_atom (ATOM_NAME
);
1636 /* Specialization of mio_name. */
1638 #define DECL_MIO_NAME(TYPE) \
1639 static inline TYPE \
1640 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1642 return (TYPE) mio_name ((int) t, m); \
1644 #define MIO_NAME(TYPE) mio_name_##TYPE
1649 if (iomode
== IO_OUTPUT
)
1650 write_atom (ATOM_LPAREN
, NULL
);
1652 require_atom (ATOM_LPAREN
);
1659 if (iomode
== IO_OUTPUT
)
1660 write_atom (ATOM_RPAREN
, NULL
);
1662 require_atom (ATOM_RPAREN
);
1667 mio_integer (int *ip
)
1669 if (iomode
== IO_OUTPUT
)
1670 write_atom (ATOM_INTEGER
, ip
);
1673 require_atom (ATOM_INTEGER
);
1679 /* Read or write a gfc_intrinsic_op value. */
1682 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1684 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1685 if (iomode
== IO_OUTPUT
)
1687 int converted
= (int) *op
;
1688 write_atom (ATOM_INTEGER
, &converted
);
1692 require_atom (ATOM_INTEGER
);
1693 *op
= (gfc_intrinsic_op
) atom_int
;
1698 /* Read or write a character pointer that points to a string on the heap. */
1701 mio_allocated_string (const char *s
)
1703 if (iomode
== IO_OUTPUT
)
1705 write_atom (ATOM_STRING
, s
);
1710 require_atom (ATOM_STRING
);
1716 /* Functions for quoting and unquoting strings. */
1719 quote_string (const gfc_char_t
*s
, const size_t slength
)
1721 const gfc_char_t
*p
;
1725 /* Calculate the length we'll need: a backslash takes two ("\\"),
1726 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1727 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1731 else if (!gfc_wide_is_printable (*p
))
1737 q
= res
= XCNEWVEC (char, len
+ 1);
1738 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1741 *q
++ = '\\', *q
++ = '\\';
1742 else if (!gfc_wide_is_printable (*p
))
1744 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1745 (unsigned HOST_WIDE_INT
) *p
);
1749 *q
++ = (unsigned char) *p
;
1757 unquote_string (const char *s
)
1763 for (p
= s
, len
= 0; *p
; p
++, len
++)
1770 else if (p
[1] == 'U')
1771 p
+= 9; /* That is a "\U????????". */
1773 gfc_internal_error ("unquote_string(): got bad string");
1776 res
= gfc_get_wide_string (len
+ 1);
1777 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1782 res
[i
] = (unsigned char) *p
;
1783 else if (p
[1] == '\\')
1785 res
[i
] = (unsigned char) '\\';
1790 /* We read the 8-digits hexadecimal constant that follows. */
1795 gcc_assert (p
[1] == 'U');
1796 for (j
= 0; j
< 8; j
++)
1799 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1813 /* Read or write a character pointer that points to a wide string on the
1814 heap, performing quoting/unquoting of nonprintable characters using the
1815 form \U???????? (where each ? is a hexadecimal digit).
1816 Length is the length of the string, only known and used in output mode. */
1818 static const gfc_char_t
*
1819 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1821 if (iomode
== IO_OUTPUT
)
1823 char *quoted
= quote_string (s
, length
);
1824 write_atom (ATOM_STRING
, quoted
);
1830 gfc_char_t
*unquoted
;
1832 require_atom (ATOM_STRING
);
1833 unquoted
= unquote_string (atom_string
);
1840 /* Read or write a string that is in static memory. */
1843 mio_pool_string (const char **stringp
)
1845 /* TODO: one could write the string only once, and refer to it via a
1848 /* As a special case we have to deal with a NULL string. This
1849 happens for the 'module' member of 'gfc_symbol's that are not in a
1850 module. We read / write these as the empty string. */
1851 if (iomode
== IO_OUTPUT
)
1853 const char *p
= *stringp
== NULL
? "" : *stringp
;
1854 write_atom (ATOM_STRING
, p
);
1858 require_atom (ATOM_STRING
);
1859 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1865 /* Read or write a string that is inside of some already-allocated
1869 mio_internal_string (char *string
)
1871 if (iomode
== IO_OUTPUT
)
1872 write_atom (ATOM_STRING
, string
);
1875 require_atom (ATOM_STRING
);
1876 strcpy (string
, atom_string
);
1883 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1884 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1885 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1886 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1887 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1888 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1889 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1890 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1891 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1892 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1893 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
, AB_OMP_DECLARE_TARGET
,
1894 AB_ARRAY_OUTER_DEPENDENCY
1898 static const mstring attr_bits
[] =
1900 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1901 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1902 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1903 minit ("DIMENSION", AB_DIMENSION
),
1904 minit ("CODIMENSION", AB_CODIMENSION
),
1905 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1906 minit ("EXTERNAL", AB_EXTERNAL
),
1907 minit ("INTRINSIC", AB_INTRINSIC
),
1908 minit ("OPTIONAL", AB_OPTIONAL
),
1909 minit ("POINTER", AB_POINTER
),
1910 minit ("VOLATILE", AB_VOLATILE
),
1911 minit ("TARGET", AB_TARGET
),
1912 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1913 minit ("DUMMY", AB_DUMMY
),
1914 minit ("RESULT", AB_RESULT
),
1915 minit ("DATA", AB_DATA
),
1916 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1917 minit ("IN_COMMON", AB_IN_COMMON
),
1918 minit ("FUNCTION", AB_FUNCTION
),
1919 minit ("SUBROUTINE", AB_SUBROUTINE
),
1920 minit ("SEQUENCE", AB_SEQUENCE
),
1921 minit ("ELEMENTAL", AB_ELEMENTAL
),
1922 minit ("PURE", AB_PURE
),
1923 minit ("RECURSIVE", AB_RECURSIVE
),
1924 minit ("GENERIC", AB_GENERIC
),
1925 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1926 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1927 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1928 minit ("IS_BIND_C", AB_IS_BIND_C
),
1929 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1930 minit ("IS_ISO_C", AB_IS_ISO_C
),
1931 minit ("VALUE", AB_VALUE
),
1932 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1933 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1934 minit ("LOCK_COMP", AB_LOCK_COMP
),
1935 minit ("POINTER_COMP", AB_POINTER_COMP
),
1936 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1937 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1938 minit ("ZERO_COMP", AB_ZERO_COMP
),
1939 minit ("PROTECTED", AB_PROTECTED
),
1940 minit ("ABSTRACT", AB_ABSTRACT
),
1941 minit ("IS_CLASS", AB_IS_CLASS
),
1942 minit ("PROCEDURE", AB_PROCEDURE
),
1943 minit ("PROC_POINTER", AB_PROC_POINTER
),
1944 minit ("VTYPE", AB_VTYPE
),
1945 minit ("VTAB", AB_VTAB
),
1946 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
1947 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
1948 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
1949 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
1950 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY
),
1954 /* For binding attributes. */
1955 static const mstring binding_passing
[] =
1958 minit ("NOPASS", 1),
1961 static const mstring binding_overriding
[] =
1963 minit ("OVERRIDABLE", 0),
1964 minit ("NON_OVERRIDABLE", 1),
1965 minit ("DEFERRED", 2),
1968 static const mstring binding_generic
[] =
1970 minit ("SPECIFIC", 0),
1971 minit ("GENERIC", 1),
1974 static const mstring binding_ppc
[] =
1976 minit ("NO_PPC", 0),
1981 /* Specialization of mio_name. */
1982 DECL_MIO_NAME (ab_attribute
)
1983 DECL_MIO_NAME (ar_type
)
1984 DECL_MIO_NAME (array_type
)
1986 DECL_MIO_NAME (expr_t
)
1987 DECL_MIO_NAME (gfc_access
)
1988 DECL_MIO_NAME (gfc_intrinsic_op
)
1989 DECL_MIO_NAME (ifsrc
)
1990 DECL_MIO_NAME (save_state
)
1991 DECL_MIO_NAME (procedure_type
)
1992 DECL_MIO_NAME (ref_type
)
1993 DECL_MIO_NAME (sym_flavor
)
1994 DECL_MIO_NAME (sym_intent
)
1995 #undef DECL_MIO_NAME
1997 /* Symbol attributes are stored in list with the first three elements
1998 being the enumerated fields, while the remaining elements (if any)
1999 indicate the individual attribute bits. The access field is not
2000 saved-- it controls what symbols are exported when a module is
2004 mio_symbol_attribute (symbol_attribute
*attr
)
2007 unsigned ext_attr
,extension_level
;
2011 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
2012 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
2013 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
2014 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2015 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2017 ext_attr
= attr
->ext_attr
;
2018 mio_integer ((int *) &ext_attr
);
2019 attr
->ext_attr
= ext_attr
;
2021 extension_level
= attr
->extension
;
2022 mio_integer ((int *) &extension_level
);
2023 attr
->extension
= extension_level
;
2025 if (iomode
== IO_OUTPUT
)
2027 if (attr
->allocatable
)
2028 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2029 if (attr
->artificial
)
2030 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2031 if (attr
->asynchronous
)
2032 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2033 if (attr
->dimension
)
2034 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2035 if (attr
->codimension
)
2036 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2037 if (attr
->contiguous
)
2038 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2040 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2041 if (attr
->intrinsic
)
2042 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2044 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2046 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2047 if (attr
->class_pointer
)
2048 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2049 if (attr
->is_protected
)
2050 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2052 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2053 if (attr
->volatile_
)
2054 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2056 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2057 if (attr
->threadprivate
)
2058 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2060 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2062 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2063 /* We deliberately don't preserve the "entry" flag. */
2066 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2067 if (attr
->in_namelist
)
2068 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2069 if (attr
->in_common
)
2070 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2073 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2074 if (attr
->subroutine
)
2075 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2077 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2079 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2082 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2083 if (attr
->elemental
)
2084 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2086 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2087 if (attr
->implicit_pure
)
2088 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2089 if (attr
->unlimited_polymorphic
)
2090 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2091 if (attr
->recursive
)
2092 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2093 if (attr
->always_explicit
)
2094 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2095 if (attr
->cray_pointer
)
2096 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2097 if (attr
->cray_pointee
)
2098 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2099 if (attr
->is_bind_c
)
2100 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2101 if (attr
->is_c_interop
)
2102 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2104 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2105 if (attr
->alloc_comp
)
2106 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2107 if (attr
->pointer_comp
)
2108 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2109 if (attr
->proc_pointer_comp
)
2110 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2111 if (attr
->private_comp
)
2112 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2113 if (attr
->coarray_comp
)
2114 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2115 if (attr
->lock_comp
)
2116 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2117 if (attr
->zero_comp
)
2118 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2120 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2121 if (attr
->procedure
)
2122 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2123 if (attr
->proc_pointer
)
2124 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2126 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2128 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2129 if (attr
->omp_declare_target
)
2130 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2131 if (attr
->array_outer_dependency
)
2132 MIO_NAME (ab_attribute
) (AB_ARRAY_OUTER_DEPENDENCY
, attr_bits
);
2142 if (t
== ATOM_RPAREN
)
2145 bad_module ("Expected attribute bit name");
2147 switch ((ab_attribute
) find_enum (attr_bits
))
2149 case AB_ALLOCATABLE
:
2150 attr
->allocatable
= 1;
2153 attr
->artificial
= 1;
2155 case AB_ASYNCHRONOUS
:
2156 attr
->asynchronous
= 1;
2159 attr
->dimension
= 1;
2161 case AB_CODIMENSION
:
2162 attr
->codimension
= 1;
2165 attr
->contiguous
= 1;
2171 attr
->intrinsic
= 1;
2179 case AB_CLASS_POINTER
:
2180 attr
->class_pointer
= 1;
2183 attr
->is_protected
= 1;
2189 attr
->volatile_
= 1;
2194 case AB_THREADPRIVATE
:
2195 attr
->threadprivate
= 1;
2206 case AB_IN_NAMELIST
:
2207 attr
->in_namelist
= 1;
2210 attr
->in_common
= 1;
2216 attr
->subroutine
= 1;
2228 attr
->elemental
= 1;
2233 case AB_IMPLICIT_PURE
:
2234 attr
->implicit_pure
= 1;
2236 case AB_UNLIMITED_POLY
:
2237 attr
->unlimited_polymorphic
= 1;
2240 attr
->recursive
= 1;
2242 case AB_ALWAYS_EXPLICIT
:
2243 attr
->always_explicit
= 1;
2245 case AB_CRAY_POINTER
:
2246 attr
->cray_pointer
= 1;
2248 case AB_CRAY_POINTEE
:
2249 attr
->cray_pointee
= 1;
2252 attr
->is_bind_c
= 1;
2254 case AB_IS_C_INTEROP
:
2255 attr
->is_c_interop
= 1;
2261 attr
->alloc_comp
= 1;
2263 case AB_COARRAY_COMP
:
2264 attr
->coarray_comp
= 1;
2267 attr
->lock_comp
= 1;
2269 case AB_POINTER_COMP
:
2270 attr
->pointer_comp
= 1;
2272 case AB_PROC_POINTER_COMP
:
2273 attr
->proc_pointer_comp
= 1;
2275 case AB_PRIVATE_COMP
:
2276 attr
->private_comp
= 1;
2279 attr
->zero_comp
= 1;
2285 attr
->procedure
= 1;
2287 case AB_PROC_POINTER
:
2288 attr
->proc_pointer
= 1;
2296 case AB_OMP_DECLARE_TARGET
:
2297 attr
->omp_declare_target
= 1;
2299 case AB_ARRAY_OUTER_DEPENDENCY
:
2300 attr
->array_outer_dependency
=1;
2308 static const mstring bt_types
[] = {
2309 minit ("INTEGER", BT_INTEGER
),
2310 minit ("REAL", BT_REAL
),
2311 minit ("COMPLEX", BT_COMPLEX
),
2312 minit ("LOGICAL", BT_LOGICAL
),
2313 minit ("CHARACTER", BT_CHARACTER
),
2314 minit ("DERIVED", BT_DERIVED
),
2315 minit ("CLASS", BT_CLASS
),
2316 minit ("PROCEDURE", BT_PROCEDURE
),
2317 minit ("UNKNOWN", BT_UNKNOWN
),
2318 minit ("VOID", BT_VOID
),
2319 minit ("ASSUMED", BT_ASSUMED
),
2325 mio_charlen (gfc_charlen
**clp
)
2331 if (iomode
== IO_OUTPUT
)
2335 mio_expr (&cl
->length
);
2339 if (peek_atom () != ATOM_RPAREN
)
2341 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2342 mio_expr (&cl
->length
);
2351 /* See if a name is a generated name. */
2354 check_unique_name (const char *name
)
2356 return *name
== '@';
2361 mio_typespec (gfc_typespec
*ts
)
2365 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2367 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2368 mio_integer (&ts
->kind
);
2370 mio_symbol_ref (&ts
->u
.derived
);
2372 mio_symbol_ref (&ts
->interface
);
2374 /* Add info for C interop and is_iso_c. */
2375 mio_integer (&ts
->is_c_interop
);
2376 mio_integer (&ts
->is_iso_c
);
2378 /* If the typespec is for an identifier either from iso_c_binding, or
2379 a constant that was initialized to an identifier from it, use the
2380 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2382 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2384 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2386 if (ts
->type
!= BT_CHARACTER
)
2388 /* ts->u.cl is only valid for BT_CHARACTER. */
2393 mio_charlen (&ts
->u
.cl
);
2395 /* So as not to disturb the existing API, use an ATOM_NAME to
2396 transmit deferred characteristic for characters (F2003). */
2397 if (iomode
== IO_OUTPUT
)
2399 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2400 write_atom (ATOM_NAME
, "DEFERRED_CL");
2402 else if (peek_atom () != ATOM_RPAREN
)
2404 if (parse_atom () != ATOM_NAME
)
2405 bad_module ("Expected string");
2413 static const mstring array_spec_types
[] = {
2414 minit ("EXPLICIT", AS_EXPLICIT
),
2415 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2416 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2417 minit ("DEFERRED", AS_DEFERRED
),
2418 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2424 mio_array_spec (gfc_array_spec
**asp
)
2431 if (iomode
== IO_OUTPUT
)
2439 /* mio_integer expects nonnegative values. */
2440 rank
= as
->rank
> 0 ? as
->rank
: 0;
2441 mio_integer (&rank
);
2445 if (peek_atom () == ATOM_RPAREN
)
2451 *asp
= as
= gfc_get_array_spec ();
2452 mio_integer (&as
->rank
);
2455 mio_integer (&as
->corank
);
2456 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2458 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2460 if (iomode
== IO_INPUT
&& as
->corank
)
2461 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2463 if (as
->rank
+ as
->corank
> 0)
2464 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2466 mio_expr (&as
->lower
[i
]);
2467 mio_expr (&as
->upper
[i
]);
2475 /* Given a pointer to an array reference structure (which lives in a
2476 gfc_ref structure), find the corresponding array specification
2477 structure. Storing the pointer in the ref structure doesn't quite
2478 work when loading from a module. Generating code for an array
2479 reference also needs more information than just the array spec. */
2481 static const mstring array_ref_types
[] = {
2482 minit ("FULL", AR_FULL
),
2483 minit ("ELEMENT", AR_ELEMENT
),
2484 minit ("SECTION", AR_SECTION
),
2490 mio_array_ref (gfc_array_ref
*ar
)
2495 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2496 mio_integer (&ar
->dimen
);
2504 for (i
= 0; i
< ar
->dimen
; i
++)
2505 mio_expr (&ar
->start
[i
]);
2510 for (i
= 0; i
< ar
->dimen
; i
++)
2512 mio_expr (&ar
->start
[i
]);
2513 mio_expr (&ar
->end
[i
]);
2514 mio_expr (&ar
->stride
[i
]);
2520 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2523 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2524 we can't call mio_integer directly. Instead loop over each element
2525 and cast it to/from an integer. */
2526 if (iomode
== IO_OUTPUT
)
2528 for (i
= 0; i
< ar
->dimen
; i
++)
2530 int tmp
= (int)ar
->dimen_type
[i
];
2531 write_atom (ATOM_INTEGER
, &tmp
);
2536 for (i
= 0; i
< ar
->dimen
; i
++)
2538 require_atom (ATOM_INTEGER
);
2539 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2543 if (iomode
== IO_INPUT
)
2545 ar
->where
= gfc_current_locus
;
2547 for (i
= 0; i
< ar
->dimen
; i
++)
2548 ar
->c_where
[i
] = gfc_current_locus
;
2555 /* Saves or restores a pointer. The pointer is converted back and
2556 forth from an integer. We return the pointer_info pointer so that
2557 the caller can take additional action based on the pointer type. */
2559 static pointer_info
*
2560 mio_pointer_ref (void *gp
)
2564 if (iomode
== IO_OUTPUT
)
2566 p
= get_pointer (*((char **) gp
));
2567 write_atom (ATOM_INTEGER
, &p
->integer
);
2571 require_atom (ATOM_INTEGER
);
2572 p
= add_fixup (atom_int
, gp
);
2579 /* Save and load references to components that occur within
2580 expressions. We have to describe these references by a number and
2581 by name. The number is necessary for forward references during
2582 reading, and the name is necessary if the symbol already exists in
2583 the namespace and is not loaded again. */
2586 mio_component_ref (gfc_component
**cp
)
2590 p
= mio_pointer_ref (cp
);
2591 if (p
->type
== P_UNKNOWN
)
2592 p
->type
= P_COMPONENT
;
2596 static void mio_namespace_ref (gfc_namespace
**nsp
);
2597 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2598 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2601 mio_component (gfc_component
*c
, int vtype
)
2608 if (iomode
== IO_OUTPUT
)
2610 p
= get_pointer (c
);
2611 mio_integer (&p
->integer
);
2616 p
= get_integer (n
);
2617 associate_integer_pointer (p
, c
);
2620 if (p
->type
== P_UNKNOWN
)
2621 p
->type
= P_COMPONENT
;
2623 mio_pool_string (&c
->name
);
2624 mio_typespec (&c
->ts
);
2625 mio_array_spec (&c
->as
);
2627 mio_symbol_attribute (&c
->attr
);
2628 if (c
->ts
.type
== BT_CLASS
)
2629 c
->attr
.class_ok
= 1;
2630 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2632 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2633 || strcmp (c
->name
, "_hash") == 0)
2634 mio_expr (&c
->initializer
);
2636 if (c
->attr
.proc_pointer
)
2637 mio_typebound_proc (&c
->tb
);
2644 mio_component_list (gfc_component
**cp
, int vtype
)
2646 gfc_component
*c
, *tail
;
2650 if (iomode
== IO_OUTPUT
)
2652 for (c
= *cp
; c
; c
= c
->next
)
2653 mio_component (c
, vtype
);
2662 if (peek_atom () == ATOM_RPAREN
)
2665 c
= gfc_get_component ();
2666 mio_component (c
, vtype
);
2682 mio_actual_arg (gfc_actual_arglist
*a
)
2685 mio_pool_string (&a
->name
);
2686 mio_expr (&a
->expr
);
2692 mio_actual_arglist (gfc_actual_arglist
**ap
)
2694 gfc_actual_arglist
*a
, *tail
;
2698 if (iomode
== IO_OUTPUT
)
2700 for (a
= *ap
; a
; a
= a
->next
)
2710 if (peek_atom () != ATOM_LPAREN
)
2713 a
= gfc_get_actual_arglist ();
2729 /* Read and write formal argument lists. */
2732 mio_formal_arglist (gfc_formal_arglist
**formal
)
2734 gfc_formal_arglist
*f
, *tail
;
2738 if (iomode
== IO_OUTPUT
)
2740 for (f
= *formal
; f
; f
= f
->next
)
2741 mio_symbol_ref (&f
->sym
);
2745 *formal
= tail
= NULL
;
2747 while (peek_atom () != ATOM_RPAREN
)
2749 f
= gfc_get_formal_arglist ();
2750 mio_symbol_ref (&f
->sym
);
2752 if (*formal
== NULL
)
2765 /* Save or restore a reference to a symbol node. */
2768 mio_symbol_ref (gfc_symbol
**symp
)
2772 p
= mio_pointer_ref (symp
);
2773 if (p
->type
== P_UNKNOWN
)
2776 if (iomode
== IO_OUTPUT
)
2778 if (p
->u
.wsym
.state
== UNREFERENCED
)
2779 p
->u
.wsym
.state
= NEEDS_WRITE
;
2783 if (p
->u
.rsym
.state
== UNUSED
)
2784 p
->u
.rsym
.state
= NEEDED
;
2790 /* Save or restore a reference to a symtree node. */
2793 mio_symtree_ref (gfc_symtree
**stp
)
2798 if (iomode
== IO_OUTPUT
)
2799 mio_symbol_ref (&(*stp
)->n
.sym
);
2802 require_atom (ATOM_INTEGER
);
2803 p
= get_integer (atom_int
);
2805 /* An unused equivalence member; make a symbol and a symtree
2807 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2809 /* Since this is not used, it must have a unique name. */
2810 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2812 /* Make the symbol. */
2813 if (p
->u
.rsym
.sym
== NULL
)
2815 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2817 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2820 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2821 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2822 p
->u
.rsym
.referenced
= 1;
2824 /* If the symbol is PRIVATE and in COMMON, load_commons will
2825 generate a fixup symbol, which must be associated. */
2827 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2831 if (p
->type
== P_UNKNOWN
)
2834 if (p
->u
.rsym
.state
== UNUSED
)
2835 p
->u
.rsym
.state
= NEEDED
;
2837 if (p
->u
.rsym
.symtree
!= NULL
)
2839 *stp
= p
->u
.rsym
.symtree
;
2843 f
= XCNEW (fixup_t
);
2845 f
->next
= p
->u
.rsym
.stfixup
;
2846 p
->u
.rsym
.stfixup
= f
;
2848 f
->pointer
= (void **) stp
;
2855 mio_iterator (gfc_iterator
**ip
)
2861 if (iomode
== IO_OUTPUT
)
2868 if (peek_atom () == ATOM_RPAREN
)
2874 *ip
= gfc_get_iterator ();
2879 mio_expr (&iter
->var
);
2880 mio_expr (&iter
->start
);
2881 mio_expr (&iter
->end
);
2882 mio_expr (&iter
->step
);
2890 mio_constructor (gfc_constructor_base
*cp
)
2896 if (iomode
== IO_OUTPUT
)
2898 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2901 mio_expr (&c
->expr
);
2902 mio_iterator (&c
->iterator
);
2908 while (peek_atom () != ATOM_RPAREN
)
2910 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2913 mio_expr (&c
->expr
);
2914 mio_iterator (&c
->iterator
);
2923 static const mstring ref_types
[] = {
2924 minit ("ARRAY", REF_ARRAY
),
2925 minit ("COMPONENT", REF_COMPONENT
),
2926 minit ("SUBSTRING", REF_SUBSTRING
),
2932 mio_ref (gfc_ref
**rp
)
2939 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2944 mio_array_ref (&r
->u
.ar
);
2948 mio_symbol_ref (&r
->u
.c
.sym
);
2949 mio_component_ref (&r
->u
.c
.component
);
2953 mio_expr (&r
->u
.ss
.start
);
2954 mio_expr (&r
->u
.ss
.end
);
2955 mio_charlen (&r
->u
.ss
.length
);
2964 mio_ref_list (gfc_ref
**rp
)
2966 gfc_ref
*ref
, *head
, *tail
;
2970 if (iomode
== IO_OUTPUT
)
2972 for (ref
= *rp
; ref
; ref
= ref
->next
)
2979 while (peek_atom () != ATOM_RPAREN
)
2982 head
= tail
= gfc_get_ref ();
2985 tail
->next
= gfc_get_ref ();
2999 /* Read and write an integer value. */
3002 mio_gmp_integer (mpz_t
*integer
)
3006 if (iomode
== IO_INPUT
)
3008 if (parse_atom () != ATOM_STRING
)
3009 bad_module ("Expected integer string");
3011 mpz_init (*integer
);
3012 if (mpz_set_str (*integer
, atom_string
, 10))
3013 bad_module ("Error converting integer");
3019 p
= mpz_get_str (NULL
, 10, *integer
);
3020 write_atom (ATOM_STRING
, p
);
3027 mio_gmp_real (mpfr_t
*real
)
3032 if (iomode
== IO_INPUT
)
3034 if (parse_atom () != ATOM_STRING
)
3035 bad_module ("Expected real string");
3038 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3043 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3045 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3047 write_atom (ATOM_STRING
, p
);
3052 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3054 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3056 /* Fix negative numbers. */
3057 if (atom_string
[2] == '-')
3059 atom_string
[0] = '-';
3060 atom_string
[1] = '0';
3061 atom_string
[2] = '.';
3064 write_atom (ATOM_STRING
, atom_string
);
3072 /* Save and restore the shape of an array constructor. */
3075 mio_shape (mpz_t
**pshape
, int rank
)
3081 /* A NULL shape is represented by (). */
3084 if (iomode
== IO_OUTPUT
)
3096 if (t
== ATOM_RPAREN
)
3103 shape
= gfc_get_shape (rank
);
3107 for (n
= 0; n
< rank
; n
++)
3108 mio_gmp_integer (&shape
[n
]);
3114 static const mstring expr_types
[] = {
3115 minit ("OP", EXPR_OP
),
3116 minit ("FUNCTION", EXPR_FUNCTION
),
3117 minit ("CONSTANT", EXPR_CONSTANT
),
3118 minit ("VARIABLE", EXPR_VARIABLE
),
3119 minit ("SUBSTRING", EXPR_SUBSTRING
),
3120 minit ("STRUCTURE", EXPR_STRUCTURE
),
3121 minit ("ARRAY", EXPR_ARRAY
),
3122 minit ("NULL", EXPR_NULL
),
3123 minit ("COMPCALL", EXPR_COMPCALL
),
3127 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3128 generic operators, not in expressions. INTRINSIC_USER is also
3129 replaced by the correct function name by the time we see it. */
3131 static const mstring intrinsics
[] =
3133 minit ("UPLUS", INTRINSIC_UPLUS
),
3134 minit ("UMINUS", INTRINSIC_UMINUS
),
3135 minit ("PLUS", INTRINSIC_PLUS
),
3136 minit ("MINUS", INTRINSIC_MINUS
),
3137 minit ("TIMES", INTRINSIC_TIMES
),
3138 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3139 minit ("POWER", INTRINSIC_POWER
),
3140 minit ("CONCAT", INTRINSIC_CONCAT
),
3141 minit ("AND", INTRINSIC_AND
),
3142 minit ("OR", INTRINSIC_OR
),
3143 minit ("EQV", INTRINSIC_EQV
),
3144 minit ("NEQV", INTRINSIC_NEQV
),
3145 minit ("EQ_SIGN", INTRINSIC_EQ
),
3146 minit ("EQ", INTRINSIC_EQ_OS
),
3147 minit ("NE_SIGN", INTRINSIC_NE
),
3148 minit ("NE", INTRINSIC_NE_OS
),
3149 minit ("GT_SIGN", INTRINSIC_GT
),
3150 minit ("GT", INTRINSIC_GT_OS
),
3151 minit ("GE_SIGN", INTRINSIC_GE
),
3152 minit ("GE", INTRINSIC_GE_OS
),
3153 minit ("LT_SIGN", INTRINSIC_LT
),
3154 minit ("LT", INTRINSIC_LT_OS
),
3155 minit ("LE_SIGN", INTRINSIC_LE
),
3156 minit ("LE", INTRINSIC_LE_OS
),
3157 minit ("NOT", INTRINSIC_NOT
),
3158 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3159 minit ("USER", INTRINSIC_USER
),
3164 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3167 fix_mio_expr (gfc_expr
*e
)
3169 gfc_symtree
*ns_st
= NULL
;
3172 if (iomode
!= IO_OUTPUT
)
3177 /* If this is a symtree for a symbol that came from a contained module
3178 namespace, it has a unique name and we should look in the current
3179 namespace to see if the required, non-contained symbol is available
3180 yet. If so, the latter should be written. */
3181 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3183 const char *name
= e
->symtree
->n
.sym
->name
;
3184 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3185 name
= dt_upper_string (name
);
3186 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3189 /* On the other hand, if the existing symbol is the module name or the
3190 new symbol is a dummy argument, do not do the promotion. */
3191 if (ns_st
&& ns_st
->n
.sym
3192 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3193 && !e
->symtree
->n
.sym
->attr
.dummy
)
3196 else if (e
->expr_type
== EXPR_FUNCTION
3197 && (e
->value
.function
.name
|| e
->value
.function
.isym
))
3201 /* In some circumstances, a function used in an initialization
3202 expression, in one use associated module, can fail to be
3203 coupled to its symtree when used in a specification
3204 expression in another module. */
3205 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3206 : e
->value
.function
.isym
->name
;
3207 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3212 /* This is probably a reference to a private procedure from another
3213 module. To prevent a segfault, make a generic with no specific
3214 instances. If this module is used, without the required
3215 specific coming from somewhere, the appropriate error message
3217 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3218 sym
->attr
.flavor
= FL_PROCEDURE
;
3219 sym
->attr
.generic
= 1;
3220 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3221 gfc_commit_symbol (sym
);
3226 /* Read and write expressions. The form "()" is allowed to indicate a
3230 mio_expr (gfc_expr
**ep
)
3238 if (iomode
== IO_OUTPUT
)
3247 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3252 if (t
== ATOM_RPAREN
)
3259 bad_module ("Expected expression type");
3261 e
= *ep
= gfc_get_expr ();
3262 e
->where
= gfc_current_locus
;
3263 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3266 mio_typespec (&e
->ts
);
3267 mio_integer (&e
->rank
);
3271 switch (e
->expr_type
)
3275 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3277 switch (e
->value
.op
.op
)
3279 case INTRINSIC_UPLUS
:
3280 case INTRINSIC_UMINUS
:
3282 case INTRINSIC_PARENTHESES
:
3283 mio_expr (&e
->value
.op
.op1
);
3286 case INTRINSIC_PLUS
:
3287 case INTRINSIC_MINUS
:
3288 case INTRINSIC_TIMES
:
3289 case INTRINSIC_DIVIDE
:
3290 case INTRINSIC_POWER
:
3291 case INTRINSIC_CONCAT
:
3295 case INTRINSIC_NEQV
:
3297 case INTRINSIC_EQ_OS
:
3299 case INTRINSIC_NE_OS
:
3301 case INTRINSIC_GT_OS
:
3303 case INTRINSIC_GE_OS
:
3305 case INTRINSIC_LT_OS
:
3307 case INTRINSIC_LE_OS
:
3308 mio_expr (&e
->value
.op
.op1
);
3309 mio_expr (&e
->value
.op
.op2
);
3312 case INTRINSIC_USER
:
3313 /* INTRINSIC_USER should not appear in resolved expressions,
3314 though for UDRs we need to stream unresolved ones. */
3315 if (iomode
== IO_OUTPUT
)
3316 write_atom (ATOM_STRING
, e
->value
.op
.uop
->name
);
3319 char *name
= read_string ();
3320 const char *uop_name
= find_use_name (name
, true);
3321 if (uop_name
== NULL
)
3323 size_t len
= strlen (name
);
3324 char *name2
= XCNEWVEC (char, len
+ 2);
3325 memcpy (name2
, name
, len
);
3327 name2
[len
+ 1] = '\0';
3329 uop_name
= name
= name2
;
3331 e
->value
.op
.uop
= gfc_get_uop (uop_name
);
3334 mio_expr (&e
->value
.op
.op1
);
3335 mio_expr (&e
->value
.op
.op2
);
3339 bad_module ("Bad operator");
3345 mio_symtree_ref (&e
->symtree
);
3346 mio_actual_arglist (&e
->value
.function
.actual
);
3348 if (iomode
== IO_OUTPUT
)
3350 e
->value
.function
.name
3351 = mio_allocated_string (e
->value
.function
.name
);
3352 if (e
->value
.function
.esym
)
3356 else if (e
->value
.function
.isym
== NULL
)
3360 mio_integer (&flag
);
3364 mio_symbol_ref (&e
->value
.function
.esym
);
3367 mio_ref_list (&e
->ref
);
3372 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3377 require_atom (ATOM_STRING
);
3378 if (atom_string
[0] == '\0')
3379 e
->value
.function
.name
= NULL
;
3381 e
->value
.function
.name
= gfc_get_string (atom_string
);
3384 mio_integer (&flag
);
3388 mio_symbol_ref (&e
->value
.function
.esym
);
3391 mio_ref_list (&e
->ref
);
3396 require_atom (ATOM_STRING
);
3397 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3405 mio_symtree_ref (&e
->symtree
);
3406 mio_ref_list (&e
->ref
);
3409 case EXPR_SUBSTRING
:
3410 e
->value
.character
.string
3411 = CONST_CAST (gfc_char_t
*,
3412 mio_allocated_wide_string (e
->value
.character
.string
,
3413 e
->value
.character
.length
));
3414 mio_ref_list (&e
->ref
);
3417 case EXPR_STRUCTURE
:
3419 mio_constructor (&e
->value
.constructor
);
3420 mio_shape (&e
->shape
, e
->rank
);
3427 mio_gmp_integer (&e
->value
.integer
);
3431 gfc_set_model_kind (e
->ts
.kind
);
3432 mio_gmp_real (&e
->value
.real
);
3436 gfc_set_model_kind (e
->ts
.kind
);
3437 mio_gmp_real (&mpc_realref (e
->value
.complex));
3438 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3442 mio_integer (&e
->value
.logical
);
3446 mio_integer (&e
->value
.character
.length
);
3447 e
->value
.character
.string
3448 = CONST_CAST (gfc_char_t
*,
3449 mio_allocated_wide_string (e
->value
.character
.string
,
3450 e
->value
.character
.length
));
3454 bad_module ("Bad type in constant expression");
3472 /* Read and write namelists. */
3475 mio_namelist (gfc_symbol
*sym
)
3477 gfc_namelist
*n
, *m
;
3478 const char *check_name
;
3482 if (iomode
== IO_OUTPUT
)
3484 for (n
= sym
->namelist
; n
; n
= n
->next
)
3485 mio_symbol_ref (&n
->sym
);
3489 /* This departure from the standard is flagged as an error.
3490 It does, in fact, work correctly. TODO: Allow it
3492 if (sym
->attr
.flavor
== FL_NAMELIST
)
3494 check_name
= find_use_name (sym
->name
, false);
3495 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3496 gfc_error ("Namelist %s cannot be renamed by USE "
3497 "association to %s", sym
->name
, check_name
);
3501 while (peek_atom () != ATOM_RPAREN
)
3503 n
= gfc_get_namelist ();
3504 mio_symbol_ref (&n
->sym
);
3506 if (sym
->namelist
== NULL
)
3513 sym
->namelist_tail
= m
;
3520 /* Save/restore lists of gfc_interface structures. When loading an
3521 interface, we are really appending to the existing list of
3522 interfaces. Checking for duplicate and ambiguous interfaces has to
3523 be done later when all symbols have been loaded. */
3526 mio_interface_rest (gfc_interface
**ip
)
3528 gfc_interface
*tail
, *p
;
3529 pointer_info
*pi
= NULL
;
3531 if (iomode
== IO_OUTPUT
)
3534 for (p
= *ip
; p
; p
= p
->next
)
3535 mio_symbol_ref (&p
->sym
);
3550 if (peek_atom () == ATOM_RPAREN
)
3553 p
= gfc_get_interface ();
3554 p
->where
= gfc_current_locus
;
3555 pi
= mio_symbol_ref (&p
->sym
);
3571 /* Save/restore a nameless operator interface. */
3574 mio_interface (gfc_interface
**ip
)
3577 mio_interface_rest (ip
);
3581 /* Save/restore a named operator interface. */
3584 mio_symbol_interface (const char **name
, const char **module
,
3588 mio_pool_string (name
);
3589 mio_pool_string (module
);
3590 mio_interface_rest (ip
);
3595 mio_namespace_ref (gfc_namespace
**nsp
)
3600 p
= mio_pointer_ref (nsp
);
3602 if (p
->type
== P_UNKNOWN
)
3603 p
->type
= P_NAMESPACE
;
3605 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3607 ns
= (gfc_namespace
*) p
->u
.pointer
;
3610 ns
= gfc_get_namespace (NULL
, 0);
3611 associate_integer_pointer (p
, ns
);
3619 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3621 static gfc_namespace
* current_f2k_derived
;
3624 mio_typebound_proc (gfc_typebound_proc
** proc
)
3627 int overriding_flag
;
3629 if (iomode
== IO_INPUT
)
3631 *proc
= gfc_get_typebound_proc (NULL
);
3632 (*proc
)->where
= gfc_current_locus
;
3638 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3640 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3641 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3642 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3643 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3644 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3645 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3646 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3648 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3649 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3650 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3652 mio_pool_string (&((*proc
)->pass_arg
));
3654 flag
= (int) (*proc
)->pass_arg_num
;
3655 mio_integer (&flag
);
3656 (*proc
)->pass_arg_num
= (unsigned) flag
;
3658 if ((*proc
)->is_generic
)
3665 if (iomode
== IO_OUTPUT
)
3666 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3668 iop
= (int) g
->is_operator
;
3670 mio_allocated_string (g
->specific_st
->name
);
3674 (*proc
)->u
.generic
= NULL
;
3675 while (peek_atom () != ATOM_RPAREN
)
3677 gfc_symtree
** sym_root
;
3679 g
= gfc_get_tbp_generic ();
3683 g
->is_operator
= (bool) iop
;
3685 require_atom (ATOM_STRING
);
3686 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3687 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3690 g
->next
= (*proc
)->u
.generic
;
3691 (*proc
)->u
.generic
= g
;
3697 else if (!(*proc
)->ppc
)
3698 mio_symtree_ref (&(*proc
)->u
.specific
);
3703 /* Walker-callback function for this purpose. */
3705 mio_typebound_symtree (gfc_symtree
* st
)
3707 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3710 if (iomode
== IO_OUTPUT
)
3713 mio_allocated_string (st
->name
);
3715 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3717 mio_typebound_proc (&st
->n
.tb
);
3721 /* IO a full symtree (in all depth). */
3723 mio_full_typebound_tree (gfc_symtree
** root
)
3727 if (iomode
== IO_OUTPUT
)
3728 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3731 while (peek_atom () == ATOM_LPAREN
)
3737 require_atom (ATOM_STRING
);
3738 st
= gfc_get_tbp_symtree (root
, atom_string
);
3741 mio_typebound_symtree (st
);
3749 mio_finalizer (gfc_finalizer
**f
)
3751 if (iomode
== IO_OUTPUT
)
3754 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3755 mio_symtree_ref (&(*f
)->proc_tree
);
3759 *f
= gfc_get_finalizer ();
3760 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3763 mio_symtree_ref (&(*f
)->proc_tree
);
3764 (*f
)->proc_sym
= NULL
;
3769 mio_f2k_derived (gfc_namespace
*f2k
)
3771 current_f2k_derived
= f2k
;
3773 /* Handle the list of finalizer procedures. */
3775 if (iomode
== IO_OUTPUT
)
3778 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3783 f2k
->finalizers
= NULL
;
3784 while (peek_atom () != ATOM_RPAREN
)
3786 gfc_finalizer
*cur
= NULL
;
3787 mio_finalizer (&cur
);
3788 cur
->next
= f2k
->finalizers
;
3789 f2k
->finalizers
= cur
;
3794 /* Handle type-bound procedures. */
3795 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3797 /* Type-bound user operators. */
3798 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3800 /* Type-bound intrinsic operators. */
3802 if (iomode
== IO_OUTPUT
)
3805 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3807 gfc_intrinsic_op realop
;
3809 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3813 realop
= (gfc_intrinsic_op
) op
;
3814 mio_intrinsic_op (&realop
);
3815 mio_typebound_proc (&f2k
->tb_op
[op
]);
3820 while (peek_atom () != ATOM_RPAREN
)
3822 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3825 mio_intrinsic_op (&op
);
3826 mio_typebound_proc (&f2k
->tb_op
[op
]);
3833 mio_full_f2k_derived (gfc_symbol
*sym
)
3837 if (iomode
== IO_OUTPUT
)
3839 if (sym
->f2k_derived
)
3840 mio_f2k_derived (sym
->f2k_derived
);
3844 if (peek_atom () != ATOM_RPAREN
)
3846 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3847 mio_f2k_derived (sym
->f2k_derived
);
3850 gcc_assert (!sym
->f2k_derived
);
3856 static const mstring omp_declare_simd_clauses
[] =
3858 minit ("INBRANCH", 0),
3859 minit ("NOTINBRANCH", 1),
3860 minit ("SIMDLEN", 2),
3861 minit ("UNIFORM", 3),
3862 minit ("LINEAR", 4),
3863 minit ("ALIGNED", 5),
3867 /* Handle !$omp declare simd. */
3870 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
3872 if (iomode
== IO_OUTPUT
)
3877 else if (peek_atom () != ATOM_LPAREN
)
3880 gfc_omp_declare_simd
*ods
= *odsp
;
3883 if (iomode
== IO_OUTPUT
)
3885 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
3888 gfc_omp_namelist
*n
;
3890 if (ods
->clauses
->inbranch
)
3891 mio_name (0, omp_declare_simd_clauses
);
3892 if (ods
->clauses
->notinbranch
)
3893 mio_name (1, omp_declare_simd_clauses
);
3894 if (ods
->clauses
->simdlen_expr
)
3896 mio_name (2, omp_declare_simd_clauses
);
3897 mio_expr (&ods
->clauses
->simdlen_expr
);
3899 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
3901 mio_name (3, omp_declare_simd_clauses
);
3902 mio_symbol_ref (&n
->sym
);
3904 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
3906 mio_name (4, omp_declare_simd_clauses
);
3907 mio_symbol_ref (&n
->sym
);
3908 mio_expr (&n
->expr
);
3910 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3912 mio_name (5, omp_declare_simd_clauses
);
3913 mio_symbol_ref (&n
->sym
);
3914 mio_expr (&n
->expr
);
3920 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
3922 require_atom (ATOM_NAME
);
3923 *odsp
= ods
= gfc_get_omp_declare_simd ();
3924 ods
->where
= gfc_current_locus
;
3925 ods
->proc_name
= ns
->proc_name
;
3926 if (peek_atom () == ATOM_NAME
)
3928 ods
->clauses
= gfc_get_omp_clauses ();
3929 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
3930 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
3931 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
3933 while (peek_atom () == ATOM_NAME
)
3935 gfc_omp_namelist
*n
;
3936 int t
= mio_name (0, omp_declare_simd_clauses
);
3940 case 0: ods
->clauses
->inbranch
= true; break;
3941 case 1: ods
->clauses
->notinbranch
= true; break;
3942 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
3946 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
3947 ptrs
[t
- 3] = &n
->next
;
3948 mio_symbol_ref (&n
->sym
);
3950 mio_expr (&n
->expr
);
3956 mio_omp_declare_simd (ns
, &ods
->next
);
3962 static const mstring omp_declare_reduction_stmt
[] =
3964 minit ("ASSIGN", 0),
3971 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
3972 gfc_namespace
*ns
, bool is_initializer
)
3974 if (iomode
== IO_OUTPUT
)
3976 if ((*sym1
)->module
== NULL
)
3978 (*sym1
)->module
= module_name
;
3979 (*sym2
)->module
= module_name
;
3981 mio_symbol_ref (sym1
);
3982 mio_symbol_ref (sym2
);
3983 if (ns
->code
->op
== EXEC_ASSIGN
)
3985 mio_name (0, omp_declare_reduction_stmt
);
3986 mio_expr (&ns
->code
->expr1
);
3987 mio_expr (&ns
->code
->expr2
);
3992 mio_name (1, omp_declare_reduction_stmt
);
3993 mio_symtree_ref (&ns
->code
->symtree
);
3994 mio_actual_arglist (&ns
->code
->ext
.actual
);
3996 flag
= ns
->code
->resolved_isym
!= NULL
;
3997 mio_integer (&flag
);
3999 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
4001 mio_symbol_ref (&ns
->code
->resolved_sym
);
4006 pointer_info
*p1
= mio_symbol_ref (sym1
);
4007 pointer_info
*p2
= mio_symbol_ref (sym2
);
4009 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
4010 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
4011 /* Add hidden symbols to the symtree. */
4012 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
4013 q
->u
.pointer
= (void *) ns
;
4014 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
4016 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
4017 associate_integer_pointer (p1
, sym
);
4018 sym
->attr
.omp_udr_artificial_var
= 1;
4019 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
4020 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
4022 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
4023 associate_integer_pointer (p2
, sym
);
4024 sym
->attr
.omp_udr_artificial_var
= 1;
4025 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
4027 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
4028 mio_expr (&ns
->code
->expr1
);
4029 mio_expr (&ns
->code
->expr2
);
4034 ns
->code
= gfc_get_code (EXEC_CALL
);
4035 mio_symtree_ref (&ns
->code
->symtree
);
4036 mio_actual_arglist (&ns
->code
->ext
.actual
);
4038 mio_integer (&flag
);
4041 require_atom (ATOM_STRING
);
4042 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
4046 mio_symbol_ref (&ns
->code
->resolved_sym
);
4048 ns
->code
->loc
= gfc_current_locus
;
4054 /* Unlike most other routines, the address of the symbol node is already
4055 fixed on input and the name/module has already been filled in.
4056 If you update the symbol format here, don't forget to update read_module
4057 as well (look for "seek to the symbol's component list"). */
4060 mio_symbol (gfc_symbol
*sym
)
4062 int intmod
= INTMOD_NONE
;
4066 mio_symbol_attribute (&sym
->attr
);
4068 /* Note that components are always saved, even if they are supposed
4069 to be private. Component access is checked during searching. */
4070 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4071 if (sym
->components
!= NULL
)
4072 sym
->component_access
4073 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4075 mio_typespec (&sym
->ts
);
4076 if (sym
->ts
.type
== BT_CLASS
)
4077 sym
->attr
.class_ok
= 1;
4079 if (iomode
== IO_OUTPUT
)
4080 mio_namespace_ref (&sym
->formal_ns
);
4083 mio_namespace_ref (&sym
->formal_ns
);
4085 sym
->formal_ns
->proc_name
= sym
;
4088 /* Save/restore common block links. */
4089 mio_symbol_ref (&sym
->common_next
);
4091 mio_formal_arglist (&sym
->formal
);
4093 if (sym
->attr
.flavor
== FL_PARAMETER
)
4094 mio_expr (&sym
->value
);
4096 mio_array_spec (&sym
->as
);
4098 mio_symbol_ref (&sym
->result
);
4100 if (sym
->attr
.cray_pointee
)
4101 mio_symbol_ref (&sym
->cp_pointer
);
4103 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4104 mio_full_f2k_derived (sym
);
4108 /* Add the fields that say whether this is from an intrinsic module,
4109 and if so, what symbol it is within the module. */
4110 /* mio_integer (&(sym->from_intmod)); */
4111 if (iomode
== IO_OUTPUT
)
4113 intmod
= sym
->from_intmod
;
4114 mio_integer (&intmod
);
4118 mio_integer (&intmod
);
4120 sym
->from_intmod
= current_intmod
;
4122 sym
->from_intmod
= (intmod_id
) intmod
;
4125 mio_integer (&(sym
->intmod_sym_id
));
4127 if (sym
->attr
.flavor
== FL_DERIVED
)
4128 mio_integer (&(sym
->hash_value
));
4131 && sym
->formal_ns
->proc_name
== sym
4132 && sym
->formal_ns
->entries
== NULL
)
4133 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4139 /************************* Top level subroutines *************************/
4141 /* Given a root symtree node and a symbol, try to find a symtree that
4142 references the symbol that is not a unique name. */
4144 static gfc_symtree
*
4145 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4147 gfc_symtree
*s
= NULL
;
4152 s
= find_symtree_for_symbol (st
->right
, sym
);
4155 s
= find_symtree_for_symbol (st
->left
, sym
);
4159 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4166 /* A recursive function to look for a specific symbol by name and by
4167 module. Whilst several symtrees might point to one symbol, its
4168 is sufficient for the purposes here than one exist. Note that
4169 generic interfaces are distinguished as are symbols that have been
4170 renamed in another module. */
4171 static gfc_symtree
*
4172 find_symbol (gfc_symtree
*st
, const char *name
,
4173 const char *module
, int generic
)
4176 gfc_symtree
*retval
, *s
;
4178 if (st
== NULL
|| st
->n
.sym
== NULL
)
4181 c
= strcmp (name
, st
->n
.sym
->name
);
4182 if (c
== 0 && st
->n
.sym
->module
4183 && strcmp (module
, st
->n
.sym
->module
) == 0
4184 && !check_unique_name (st
->name
))
4186 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4188 /* Detect symbols that are renamed by use association in another
4189 module by the absence of a symtree and null attr.use_rename,
4190 since the latter is not transmitted in the module file. */
4191 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4192 || (generic
&& st
->n
.sym
->attr
.generic
))
4193 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4197 retval
= find_symbol (st
->left
, name
, module
, generic
);
4200 retval
= find_symbol (st
->right
, name
, module
, generic
);
4206 /* Skip a list between balanced left and right parens.
4207 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4208 have been already parsed by hand, and the remaining of the content is to be
4209 skipped here. The default value is 0 (balanced parens). */
4212 skip_list (int nest_level
= 0)
4219 switch (parse_atom ())
4242 /* Load operator interfaces from the module. Interfaces are unusual
4243 in that they attach themselves to existing symbols. */
4246 load_operator_interfaces (void)
4249 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4251 pointer_info
*pi
= NULL
;
4256 while (peek_atom () != ATOM_RPAREN
)
4260 mio_internal_string (name
);
4261 mio_internal_string (module
);
4263 n
= number_use_names (name
, true);
4266 for (i
= 1; i
<= n
; i
++)
4268 /* Decide if we need to load this one or not. */
4269 p
= find_use_name_n (name
, &i
, true);
4273 while (parse_atom () != ATOM_RPAREN
);
4279 uop
= gfc_get_uop (p
);
4280 pi
= mio_interface_rest (&uop
->op
);
4284 if (gfc_find_uop (p
, NULL
))
4286 uop
= gfc_get_uop (p
);
4287 uop
->op
= gfc_get_interface ();
4288 uop
->op
->where
= gfc_current_locus
;
4289 add_fixup (pi
->integer
, &uop
->op
->sym
);
4298 /* Load interfaces from the module. Interfaces are unusual in that
4299 they attach themselves to existing symbols. */
4302 load_generic_interfaces (void)
4305 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4307 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4309 bool ambiguous_set
= false;
4313 while (peek_atom () != ATOM_RPAREN
)
4317 mio_internal_string (name
);
4318 mio_internal_string (module
);
4320 n
= number_use_names (name
, false);
4321 renamed
= n
? 1 : 0;
4324 for (i
= 1; i
<= n
; i
++)
4327 /* Decide if we need to load this one or not. */
4328 p
= find_use_name_n (name
, &i
, false);
4330 st
= find_symbol (gfc_current_ns
->sym_root
,
4331 name
, module_name
, 1);
4333 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4335 /* Skip the specific names for these cases. */
4336 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4341 /* If the symbol exists already and is being USEd without being
4342 in an ONLY clause, do not load a new symtree(11.3.2). */
4343 if (!only_flag
&& st
)
4351 if (strcmp (st
->name
, p
) != 0)
4353 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4359 /* Since we haven't found a valid generic interface, we had
4363 gfc_get_symbol (p
, NULL
, &sym
);
4364 sym
->name
= gfc_get_string (name
);
4365 sym
->module
= module_name
;
4366 sym
->attr
.flavor
= FL_PROCEDURE
;
4367 sym
->attr
.generic
= 1;
4368 sym
->attr
.use_assoc
= 1;
4373 /* Unless sym is a generic interface, this reference
4376 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4380 if (st
&& !sym
->attr
.generic
4383 && strcmp (module
, sym
->module
))
4385 ambiguous_set
= true;
4390 sym
->attr
.use_only
= only_flag
;
4391 sym
->attr
.use_rename
= renamed
;
4395 mio_interface_rest (&sym
->generic
);
4396 generic
= sym
->generic
;
4398 else if (!sym
->generic
)
4400 sym
->generic
= generic
;
4401 sym
->attr
.generic_copy
= 1;
4404 /* If a procedure that is not generic has generic interfaces
4405 that include itself, it is generic! We need to take care
4406 to retain symbols ambiguous that were already so. */
4407 if (sym
->attr
.use_assoc
4408 && !sym
->attr
.generic
4409 && sym
->attr
.flavor
== FL_PROCEDURE
)
4411 for (gen
= generic
; gen
; gen
= gen
->next
)
4413 if (gen
->sym
== sym
)
4415 sym
->attr
.generic
= 1;
4430 /* Load common blocks. */
4435 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4440 while (peek_atom () != ATOM_RPAREN
)
4445 mio_internal_string (name
);
4447 p
= gfc_get_common (name
, 1);
4449 mio_symbol_ref (&p
->head
);
4450 mio_integer (&flags
);
4454 p
->threadprivate
= 1;
4457 /* Get whether this was a bind(c) common or not. */
4458 mio_integer (&p
->is_bind_c
);
4459 /* Get the binding label. */
4460 label
= read_string ();
4462 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4472 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4473 so that unused variables are not loaded and so that the expression can
4479 gfc_equiv
*head
, *tail
, *end
, *eq
;
4483 in_load_equiv
= true;
4485 end
= gfc_current_ns
->equiv
;
4486 while (end
!= NULL
&& end
->next
!= NULL
)
4489 while (peek_atom () != ATOM_RPAREN
) {
4493 while(peek_atom () != ATOM_RPAREN
)
4496 head
= tail
= gfc_get_equiv ();
4499 tail
->eq
= gfc_get_equiv ();
4503 mio_pool_string (&tail
->module
);
4504 mio_expr (&tail
->expr
);
4507 /* Unused equivalence members have a unique name. In addition, it
4508 must be checked that the symbols are from the same module. */
4510 for (eq
= head
; eq
; eq
= eq
->eq
)
4512 if (eq
->expr
->symtree
->n
.sym
->module
4513 && head
->expr
->symtree
->n
.sym
->module
4514 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4515 eq
->expr
->symtree
->n
.sym
->module
) == 0
4516 && !check_unique_name (eq
->expr
->symtree
->name
))
4525 for (eq
= head
; eq
; eq
= head
)
4528 gfc_free_expr (eq
->expr
);
4534 gfc_current_ns
->equiv
= head
;
4545 in_load_equiv
= false;
4549 /* This function loads OpenMP user defined reductions. */
4551 load_omp_udrs (void)
4554 while (peek_atom () != ATOM_RPAREN
)
4556 const char *name
, *newname
;
4560 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4563 mio_pool_string (&name
);
4565 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4567 const char *p
= name
+ sizeof ("operator ") - 1;
4568 if (strcmp (p
, "+") == 0)
4569 rop
= OMP_REDUCTION_PLUS
;
4570 else if (strcmp (p
, "*") == 0)
4571 rop
= OMP_REDUCTION_TIMES
;
4572 else if (strcmp (p
, "-") == 0)
4573 rop
= OMP_REDUCTION_MINUS
;
4574 else if (strcmp (p
, ".and.") == 0)
4575 rop
= OMP_REDUCTION_AND
;
4576 else if (strcmp (p
, ".or.") == 0)
4577 rop
= OMP_REDUCTION_OR
;
4578 else if (strcmp (p
, ".eqv.") == 0)
4579 rop
= OMP_REDUCTION_EQV
;
4580 else if (strcmp (p
, ".neqv.") == 0)
4581 rop
= OMP_REDUCTION_NEQV
;
4584 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4586 size_t len
= strlen (name
+ 1);
4587 altname
= XALLOCAVEC (char, len
);
4588 gcc_assert (name
[len
] == '.');
4589 memcpy (altname
, name
+ 1, len
- 1);
4590 altname
[len
- 1] = '\0';
4593 if (rop
== OMP_REDUCTION_USER
)
4594 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4595 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4597 if (newname
== NULL
)
4602 if (altname
&& newname
!= altname
)
4604 size_t len
= strlen (newname
);
4605 altname
= XALLOCAVEC (char, len
+ 3);
4607 memcpy (altname
+ 1, newname
, len
);
4608 altname
[len
+ 1] = '.';
4609 altname
[len
+ 2] = '\0';
4610 name
= gfc_get_string (altname
);
4612 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4613 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4616 require_atom (ATOM_INTEGER
);
4617 pointer_info
*p
= get_integer (atom_int
);
4618 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4620 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4622 p
->u
.rsym
.module
, &gfc_current_locus
);
4623 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4625 udr
->omp_out
->module
, &udr
->where
);
4630 udr
= gfc_get_omp_udr ();
4634 udr
->where
= gfc_current_locus
;
4635 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4636 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4637 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4639 if (peek_atom () != ATOM_RPAREN
)
4641 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4642 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4643 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4644 udr
->initializer_ns
, true);
4648 udr
->next
= st
->n
.omp_udr
;
4649 st
->n
.omp_udr
= udr
;
4653 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4654 st
->n
.omp_udr
= udr
;
4662 /* Recursive function to traverse the pointer_info tree and load a
4663 needed symbol. We return nonzero if we load a symbol and stop the
4664 traversal, because the act of loading can alter the tree. */
4667 load_needed (pointer_info
*p
)
4678 rv
|= load_needed (p
->left
);
4679 rv
|= load_needed (p
->right
);
4681 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4684 p
->u
.rsym
.state
= USED
;
4686 set_module_locus (&p
->u
.rsym
.where
);
4688 sym
= p
->u
.rsym
.sym
;
4691 q
= get_integer (p
->u
.rsym
.ns
);
4693 ns
= (gfc_namespace
*) q
->u
.pointer
;
4696 /* Create an interface namespace if necessary. These are
4697 the namespaces that hold the formal parameters of module
4700 ns
= gfc_get_namespace (NULL
, 0);
4701 associate_integer_pointer (q
, ns
);
4704 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4705 doesn't go pear-shaped if the symbol is used. */
4707 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4710 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4711 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4712 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4713 if (p
->u
.rsym
.binding_label
)
4714 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4715 (p
->u
.rsym
.binding_label
));
4717 associate_integer_pointer (p
, sym
);
4721 sym
->attr
.use_assoc
= 1;
4723 /* Mark as only or rename for later diagnosis for explicitly imported
4724 but not used warnings; don't mark internal symbols such as __vtab,
4725 __def_init etc. Only mark them if they have been explicitly loaded. */
4727 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4731 /* Search the use/rename list for the variable; if the variable is
4733 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4735 if (strcmp (u
->use_name
, sym
->name
) == 0)
4737 sym
->attr
.use_only
= 1;
4743 if (p
->u
.rsym
.renamed
)
4744 sym
->attr
.use_rename
= 1;
4750 /* Recursive function for cleaning up things after a module has been read. */
4753 read_cleanup (pointer_info
*p
)
4761 read_cleanup (p
->left
);
4762 read_cleanup (p
->right
);
4764 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4767 /* Add hidden symbols to the symtree. */
4768 q
= get_integer (p
->u
.rsym
.ns
);
4769 ns
= (gfc_namespace
*) q
->u
.pointer
;
4771 if (!p
->u
.rsym
.sym
->attr
.vtype
4772 && !p
->u
.rsym
.sym
->attr
.vtab
)
4773 st
= gfc_get_unique_symtree (ns
);
4776 /* There is no reason to use 'unique_symtrees' for vtabs or
4777 vtypes - their name is fine for a symtree and reduces the
4778 namespace pollution. */
4779 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4781 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4784 st
->n
.sym
= p
->u
.rsym
.sym
;
4787 /* Fixup any symtree references. */
4788 p
->u
.rsym
.symtree
= st
;
4789 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4790 p
->u
.rsym
.stfixup
= NULL
;
4793 /* Free unused symbols. */
4794 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4795 gfc_free_symbol (p
->u
.rsym
.sym
);
4799 /* It is not quite enough to check for ambiguity in the symbols by
4800 the loaded symbol and the new symbol not being identical. */
4802 check_for_ambiguous (gfc_symtree
*st
, pointer_info
*info
)
4806 symbol_attribute attr
;
4809 if (gfc_current_ns
->proc_name
&& st
->name
== gfc_current_ns
->proc_name
->name
)
4811 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4812 "current program unit", st
->name
, module_name
);
4817 rsym
= info
->u
.rsym
.sym
;
4821 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4824 /* If the existing symbol is generic from a different module and
4825 the new symbol is generic there can be no ambiguity. */
4826 if (st_sym
->attr
.generic
4828 && st_sym
->module
!= module_name
)
4830 /* The new symbol's attributes have not yet been read. Since
4831 we need attr.generic, read it directly. */
4832 get_module_locus (&locus
);
4833 set_module_locus (&info
->u
.rsym
.where
);
4836 mio_symbol_attribute (&attr
);
4837 set_module_locus (&locus
);
4846 /* Read a module file. */
4851 module_locus operator_interfaces
, user_operators
, omp_udrs
;
4853 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4855 /* Workaround -Wmaybe-uninitialized false positive during
4856 profiledbootstrap by initializing them. */
4857 int ambiguous
= 0, j
, nuse
, symbol
= 0;
4858 pointer_info
*info
, *q
;
4859 gfc_use_rename
*u
= NULL
;
4863 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4866 get_module_locus (&user_operators
);
4870 /* Skip commons and equivalences for now. */
4874 /* Skip OpenMP UDRs. */
4875 get_module_locus (&omp_udrs
);
4880 /* Create the fixup nodes for all the symbols. */
4882 while (peek_atom () != ATOM_RPAREN
)
4885 require_atom (ATOM_INTEGER
);
4886 info
= get_integer (atom_int
);
4888 info
->type
= P_SYMBOL
;
4889 info
->u
.rsym
.state
= UNUSED
;
4891 info
->u
.rsym
.true_name
= read_string ();
4892 info
->u
.rsym
.module
= read_string ();
4893 bind_label
= read_string ();
4894 if (strlen (bind_label
))
4895 info
->u
.rsym
.binding_label
= bind_label
;
4897 XDELETEVEC (bind_label
);
4899 require_atom (ATOM_INTEGER
);
4900 info
->u
.rsym
.ns
= atom_int
;
4902 get_module_locus (&info
->u
.rsym
.where
);
4904 /* See if the symbol has already been loaded by a previous module.
4905 If so, we reference the existing symbol and prevent it from
4906 being loaded again. This should not happen if the symbol being
4907 read is an index for an assumed shape dummy array (ns != 1). */
4909 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4912 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4918 info
->u
.rsym
.state
= USED
;
4919 info
->u
.rsym
.sym
= sym
;
4920 /* The current symbol has already been loaded, so we can avoid loading
4921 it again. However, if it is a derived type, some of its components
4922 can be used in expressions in the module. To avoid the module loading
4923 failing, we need to associate the module's component pointer indexes
4924 with the existing symbol's component pointers. */
4925 if (sym
->attr
.flavor
== FL_DERIVED
)
4929 /* First seek to the symbol's component list. */
4930 mio_lparen (); /* symbol opening. */
4931 skip_list (); /* skip symbol attribute. */
4933 mio_lparen (); /* component list opening. */
4934 for (c
= sym
->components
; c
; c
= c
->next
)
4937 const char *comp_name
;
4940 mio_lparen (); /* component opening. */
4942 p
= get_integer (n
);
4943 if (p
->u
.pointer
== NULL
)
4944 associate_integer_pointer (p
, c
);
4945 mio_pool_string (&comp_name
);
4946 gcc_assert (comp_name
== c
->name
);
4947 skip_list (1); /* component end. */
4949 mio_rparen (); /* component list closing. */
4951 skip_list (1); /* symbol end. */
4956 /* Some symbols do not have a namespace (eg. formal arguments),
4957 so the automatic "unique symtree" mechanism must be suppressed
4958 by marking them as referenced. */
4959 q
= get_integer (info
->u
.rsym
.ns
);
4960 if (q
->u
.pointer
== NULL
)
4962 info
->u
.rsym
.referenced
= 1;
4966 /* If possible recycle the symtree that references the symbol.
4967 If a symtree is not found and the module does not import one,
4968 a unique-name symtree is found by read_cleanup. */
4969 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4972 info
->u
.rsym
.symtree
= st
;
4973 info
->u
.rsym
.referenced
= 1;
4979 /* Parse the symtree lists. This lets us mark which symbols need to
4980 be loaded. Renaming is also done at this point by replacing the
4985 while (peek_atom () != ATOM_RPAREN
)
4987 mio_internal_string (name
);
4988 mio_integer (&ambiguous
);
4989 mio_integer (&symbol
);
4991 info
= get_integer (symbol
);
4993 /* See how many use names there are. If none, go through the start
4994 of the loop at least once. */
4995 nuse
= number_use_names (name
, false);
4996 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5001 for (j
= 1; j
<= nuse
; j
++)
5003 /* Get the jth local name for this symbol. */
5004 p
= find_use_name_n (name
, &j
, false);
5006 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5009 /* Exception: Always import vtabs & vtypes. */
5010 if (p
== NULL
&& name
[0] == '_'
5011 && (strncmp (name
, "__vtab_", 5) == 0
5012 || strncmp (name
, "__vtype_", 6) == 0))
5015 /* Skip symtree nodes not in an ONLY clause, unless there
5016 is an existing symtree loaded from another USE statement. */
5019 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5021 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5022 && st
->n
.sym
->module
!= NULL
5023 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5025 info
->u
.rsym
.symtree
= st
;
5026 info
->u
.rsym
.sym
= st
->n
.sym
;
5031 /* If a symbol of the same name and module exists already,
5032 this symbol, which is not in an ONLY clause, must not be
5033 added to the namespace(11.3.2). Note that find_symbol
5034 only returns the first occurrence that it finds. */
5035 if (!only_flag
&& !info
->u
.rsym
.renamed
5036 && strcmp (name
, module_name
) != 0
5037 && find_symbol (gfc_current_ns
->sym_root
, name
,
5041 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5045 /* Check for ambiguous symbols. */
5046 if (check_for_ambiguous (st
, info
))
5049 info
->u
.rsym
.symtree
= st
;
5053 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5055 /* Create a symtree node in the current namespace for this
5057 st
= check_unique_name (p
)
5058 ? gfc_get_unique_symtree (gfc_current_ns
)
5059 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5060 st
->ambiguous
= ambiguous
;
5062 sym
= info
->u
.rsym
.sym
;
5064 /* Create a symbol node if it doesn't already exist. */
5067 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5069 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
5070 sym
= info
->u
.rsym
.sym
;
5071 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5073 if (info
->u
.rsym
.binding_label
)
5074 sym
->binding_label
=
5075 IDENTIFIER_POINTER (get_identifier
5076 (info
->u
.rsym
.binding_label
));
5082 if (strcmp (name
, p
) != 0)
5083 sym
->attr
.use_rename
= 1;
5086 || (strncmp (name
, "__vtab_", 5) != 0
5087 && strncmp (name
, "__vtype_", 6) != 0))
5088 sym
->attr
.use_only
= only_flag
;
5090 /* Store the symtree pointing to this symbol. */
5091 info
->u
.rsym
.symtree
= st
;
5093 if (info
->u
.rsym
.state
== UNUSED
)
5094 info
->u
.rsym
.state
= NEEDED
;
5095 info
->u
.rsym
.referenced
= 1;
5102 /* Load intrinsic operator interfaces. */
5103 set_module_locus (&operator_interfaces
);
5106 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5108 if (i
== INTRINSIC_USER
)
5113 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5124 mio_interface (&gfc_current_ns
->op
[i
]);
5125 if (u
&& !gfc_current_ns
->op
[i
])
5131 /* Load generic and user operator interfaces. These must follow the
5132 loading of symtree because otherwise symbols can be marked as
5135 set_module_locus (&user_operators
);
5137 load_operator_interfaces ();
5138 load_generic_interfaces ();
5143 /* Load OpenMP user defined reductions. */
5144 set_module_locus (&omp_udrs
);
5147 /* At this point, we read those symbols that are needed but haven't
5148 been loaded yet. If one symbol requires another, the other gets
5149 marked as NEEDED if its previous state was UNUSED. */
5151 while (load_needed (pi_root
));
5153 /* Make sure all elements of the rename-list were found in the module. */
5155 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5160 if (u
->op
== INTRINSIC_NONE
)
5162 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5163 u
->use_name
, &u
->where
, module_name
);
5167 if (u
->op
== INTRINSIC_USER
)
5169 gfc_error ("User operator %qs referenced at %L not found "
5170 "in module %qs", u
->use_name
, &u
->where
, module_name
);
5174 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5175 "in module %qs", gfc_op2string (u
->op
), &u
->where
,
5179 /* Clean up symbol nodes that were never loaded, create references
5180 to hidden symbols. */
5182 read_cleanup (pi_root
);
5186 /* Given an access type that is specific to an entity and the default
5187 access, return nonzero if the entity is publicly accessible. If the
5188 element is declared as PUBLIC, then it is public; if declared
5189 PRIVATE, then private, and otherwise it is public unless the default
5190 access in this context has been declared PRIVATE. */
5193 check_access (gfc_access specific_access
, gfc_access default_access
)
5195 if (specific_access
== ACCESS_PUBLIC
)
5197 if (specific_access
== ACCESS_PRIVATE
)
5200 if (flag_module_private
)
5201 return default_access
== ACCESS_PUBLIC
;
5203 return default_access
!= ACCESS_PRIVATE
;
5208 gfc_check_symbol_access (gfc_symbol
*sym
)
5210 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5213 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5217 /* A structure to remember which commons we've already written. */
5219 struct written_common
5221 BBT_HEADER(written_common
);
5222 const char *name
, *label
;
5225 static struct written_common
*written_commons
= NULL
;
5227 /* Comparison function used for balancing the binary tree. */
5230 compare_written_commons (void *a1
, void *b1
)
5232 const char *aname
= ((struct written_common
*) a1
)->name
;
5233 const char *alabel
= ((struct written_common
*) a1
)->label
;
5234 const char *bname
= ((struct written_common
*) b1
)->name
;
5235 const char *blabel
= ((struct written_common
*) b1
)->label
;
5236 int c
= strcmp (aname
, bname
);
5238 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5241 /* Free a list of written commons. */
5244 free_written_common (struct written_common
*w
)
5250 free_written_common (w
->left
);
5252 free_written_common (w
->right
);
5257 /* Write a common block to the module -- recursive helper function. */
5260 write_common_0 (gfc_symtree
*st
, bool this_module
)
5266 struct written_common
*w
;
5267 bool write_me
= true;
5272 write_common_0 (st
->left
, this_module
);
5274 /* We will write out the binding label, or "" if no label given. */
5275 name
= st
->n
.common
->name
;
5277 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5279 /* Check if we've already output this common. */
5280 w
= written_commons
;
5283 int c
= strcmp (name
, w
->name
);
5284 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5288 w
= (c
< 0) ? w
->left
: w
->right
;
5291 if (this_module
&& p
->use_assoc
)
5296 /* Write the common to the module. */
5298 mio_pool_string (&name
);
5300 mio_symbol_ref (&p
->head
);
5301 flags
= p
->saved
? 1 : 0;
5302 if (p
->threadprivate
)
5304 mio_integer (&flags
);
5306 /* Write out whether the common block is bind(c) or not. */
5307 mio_integer (&(p
->is_bind_c
));
5309 mio_pool_string (&label
);
5312 /* Record that we have written this common. */
5313 w
= XCNEW (struct written_common
);
5316 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5319 write_common_0 (st
->right
, this_module
);
5323 /* Write a common, by initializing the list of written commons, calling
5324 the recursive function write_common_0() and cleaning up afterwards. */
5327 write_common (gfc_symtree
*st
)
5329 written_commons
= NULL
;
5330 write_common_0 (st
, true);
5331 write_common_0 (st
, false);
5332 free_written_common (written_commons
);
5333 written_commons
= NULL
;
5337 /* Write the blank common block to the module. */
5340 write_blank_common (void)
5342 const char * name
= BLANK_COMMON_NAME
;
5344 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5345 this, but it hasn't been checked. Just making it so for now. */
5348 if (gfc_current_ns
->blank_common
.head
== NULL
)
5353 mio_pool_string (&name
);
5355 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5356 saved
= gfc_current_ns
->blank_common
.saved
;
5357 mio_integer (&saved
);
5359 /* Write out whether the common block is bind(c) or not. */
5360 mio_integer (&is_bind_c
);
5362 /* Write out an empty binding label. */
5363 write_atom (ATOM_STRING
, "");
5369 /* Write equivalences to the module. */
5378 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5382 for (e
= eq
; e
; e
= e
->eq
)
5384 if (e
->module
== NULL
)
5385 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5386 mio_allocated_string (e
->module
);
5387 mio_expr (&e
->expr
);
5396 /* Write a symbol to the module. */
5399 write_symbol (int n
, gfc_symbol
*sym
)
5403 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5404 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym
->name
);
5408 if (sym
->attr
.flavor
== FL_DERIVED
)
5411 name
= dt_upper_string (sym
->name
);
5412 mio_pool_string (&name
);
5415 mio_pool_string (&sym
->name
);
5417 mio_pool_string (&sym
->module
);
5418 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5420 label
= sym
->binding_label
;
5421 mio_pool_string (&label
);
5424 write_atom (ATOM_STRING
, "");
5426 mio_pointer_ref (&sym
->ns
);
5433 /* Recursive traversal function to write the initial set of symbols to
5434 the module. We check to see if the symbol should be written
5435 according to the access specification. */
5438 write_symbol0 (gfc_symtree
*st
)
5442 bool dont_write
= false;
5447 write_symbol0 (st
->left
);
5450 if (sym
->module
== NULL
)
5451 sym
->module
= module_name
;
5453 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5454 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5457 if (!gfc_check_symbol_access (sym
))
5462 p
= get_pointer (sym
);
5463 if (p
->type
== P_UNKNOWN
)
5466 if (p
->u
.wsym
.state
!= WRITTEN
)
5468 write_symbol (p
->integer
, sym
);
5469 p
->u
.wsym
.state
= WRITTEN
;
5473 write_symbol0 (st
->right
);
5478 write_omp_udr (gfc_omp_udr
*udr
)
5482 case OMP_REDUCTION_USER
:
5483 /* Non-operators can't be used outside of the module. */
5484 if (udr
->name
[0] != '.')
5489 size_t len
= strlen (udr
->name
+ 1);
5490 char *name
= XALLOCAVEC (char, len
);
5491 memcpy (name
, udr
->name
, len
- 1);
5492 name
[len
- 1] = '\0';
5493 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5494 /* If corresponding user operator is private, don't write
5498 gfc_user_op
*uop
= st
->n
.uop
;
5499 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5504 case OMP_REDUCTION_PLUS
:
5505 case OMP_REDUCTION_MINUS
:
5506 case OMP_REDUCTION_TIMES
:
5507 case OMP_REDUCTION_AND
:
5508 case OMP_REDUCTION_OR
:
5509 case OMP_REDUCTION_EQV
:
5510 case OMP_REDUCTION_NEQV
:
5511 /* If corresponding operator is private, don't write the UDR. */
5512 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5513 gfc_current_ns
->default_access
))
5519 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5521 /* If derived type is private, don't write the UDR. */
5522 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5527 mio_pool_string (&udr
->name
);
5528 mio_typespec (&udr
->ts
);
5529 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5530 if (udr
->initializer_ns
)
5531 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5532 udr
->initializer_ns
, true);
5538 write_omp_udrs (gfc_symtree
*st
)
5543 write_omp_udrs (st
->left
);
5545 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5546 write_omp_udr (udr
);
5547 write_omp_udrs (st
->right
);
5551 /* Type for the temporary tree used when writing secondary symbols. */
5553 struct sorted_pointer_info
5555 BBT_HEADER (sorted_pointer_info
);
5560 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5562 /* Recursively traverse the temporary tree, free its contents. */
5565 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5570 free_sorted_pointer_info_tree (p
->left
);
5571 free_sorted_pointer_info_tree (p
->right
);
5576 /* Comparison function for the temporary tree. */
5579 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5581 sorted_pointer_info
*spi1
, *spi2
;
5582 spi1
= (sorted_pointer_info
*)_spi1
;
5583 spi2
= (sorted_pointer_info
*)_spi2
;
5585 if (spi1
->p
->integer
< spi2
->p
->integer
)
5587 if (spi1
->p
->integer
> spi2
->p
->integer
)
5593 /* Finds the symbols that need to be written and collects them in the
5594 sorted_pi tree so that they can be traversed in an order
5595 independent of memory addresses. */
5598 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5603 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5605 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5608 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5611 find_symbols_to_write (tree
, p
->left
);
5612 find_symbols_to_write (tree
, p
->right
);
5616 /* Recursive function that traverses the tree of symbols that need to be
5617 written and writes them in order. */
5620 write_symbol1_recursion (sorted_pointer_info
*sp
)
5625 write_symbol1_recursion (sp
->left
);
5627 pointer_info
*p1
= sp
->p
;
5628 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5630 p1
->u
.wsym
.state
= WRITTEN
;
5631 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5632 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5634 write_symbol1_recursion (sp
->right
);
5638 /* Write the secondary set of symbols to the module file. These are
5639 symbols that were not public yet are needed by the public symbols
5640 or another dependent symbol. The act of writing a symbol can add
5641 symbols to the pointer_info tree, so we return nonzero if a symbol
5642 was written and pass that information upwards. The caller will
5643 then call this function again until nothing was written. It uses
5644 the utility functions and a temporary tree to ensure a reproducible
5645 ordering of the symbol output and thus the module file. */
5648 write_symbol1 (pointer_info
*p
)
5653 /* Put symbols that need to be written into a tree sorted on the
5656 sorted_pointer_info
*spi_root
= NULL
;
5657 find_symbols_to_write (&spi_root
, p
);
5659 /* No symbols to write, return. */
5663 /* Otherwise, write and free the tree again. */
5664 write_symbol1_recursion (spi_root
);
5665 free_sorted_pointer_info_tree (spi_root
);
5671 /* Write operator interfaces associated with a symbol. */
5674 write_operator (gfc_user_op
*uop
)
5676 static char nullstring
[] = "";
5677 const char *p
= nullstring
;
5679 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5682 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5686 /* Write generic interfaces from the namespace sym_root. */
5689 write_generic (gfc_symtree
*st
)
5696 write_generic (st
->left
);
5699 if (sym
&& !check_unique_name (st
->name
)
5700 && sym
->generic
&& gfc_check_symbol_access (sym
))
5703 sym
->module
= module_name
;
5705 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5708 write_generic (st
->right
);
5713 write_symtree (gfc_symtree
*st
)
5720 /* A symbol in an interface body must not be visible in the
5722 if (sym
->ns
!= gfc_current_ns
5723 && sym
->ns
->proc_name
5724 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5727 if (!gfc_check_symbol_access (sym
)
5728 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5729 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5732 if (check_unique_name (st
->name
))
5735 p
= find_pointer (sym
);
5737 gfc_internal_error ("write_symtree(): Symbol not written");
5739 mio_pool_string (&st
->name
);
5740 mio_integer (&st
->ambiguous
);
5741 mio_integer (&p
->integer
);
5750 /* Write the operator interfaces. */
5753 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5755 if (i
== INTRINSIC_USER
)
5758 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5759 gfc_current_ns
->default_access
)
5760 ? &gfc_current_ns
->op
[i
] : NULL
);
5768 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5774 write_generic (gfc_current_ns
->sym_root
);
5780 write_blank_common ();
5781 write_common (gfc_current_ns
->common_root
);
5793 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5798 /* Write symbol information. First we traverse all symbols in the
5799 primary namespace, writing those that need to be written.
5800 Sometimes writing one symbol will cause another to need to be
5801 written. A list of these symbols ends up on the write stack, and
5802 we end by popping the bottom of the stack and writing the symbol
5803 until the stack is empty. */
5807 write_symbol0 (gfc_current_ns
->sym_root
);
5808 while (write_symbol1 (pi_root
))
5817 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5822 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5823 true on success, false on failure. */
5826 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5832 /* Open the file in binary mode. */
5833 if ((file
= fopen (filename
, "rb")) == NULL
)
5836 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5837 file. See RFC 1952. */
5838 if (fseek (file
, -8, SEEK_END
) != 0)
5844 /* Read the CRC32. */
5845 if (fread (buf
, 1, 4, file
) != 4)
5851 /* Close the file. */
5854 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
5855 + ((buf
[3] & 0xFF) << 24);
5858 /* For debugging, the CRC value printed in hexadecimal should match
5859 the CRC printed by "zcat -l -v filename".
5860 printf("CRC of file %s is %x\n", filename, val); */
5866 /* Given module, dump it to disk. If there was an error while
5867 processing the module, dump_flag will be set to zero and we delete
5868 the module file, even if it was already there. */
5871 gfc_dump_module (const char *name
, int dump_flag
)
5874 char *filename
, *filename_tmp
;
5877 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5878 if (gfc_option
.module_dir
!= NULL
)
5880 n
+= strlen (gfc_option
.module_dir
);
5881 filename
= (char *) alloca (n
);
5882 strcpy (filename
, gfc_option
.module_dir
);
5883 strcat (filename
, name
);
5887 filename
= (char *) alloca (n
);
5888 strcpy (filename
, name
);
5890 strcat (filename
, MODULE_EXTENSION
);
5892 /* Name of the temporary file used to write the module. */
5893 filename_tmp
= (char *) alloca (n
+ 1);
5894 strcpy (filename_tmp
, filename
);
5895 strcat (filename_tmp
, "0");
5897 /* There was an error while processing the module. We delete the
5898 module file, even if it was already there. */
5905 if (gfc_cpp_makedep ())
5906 gfc_cpp_add_target (filename
);
5908 /* Write the module to the temporary file. */
5909 module_fp
= gzopen (filename_tmp
, "w");
5910 if (module_fp
== NULL
)
5911 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
5912 filename_tmp
, xstrerror (errno
));
5914 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
5915 MOD_VERSION
, gfc_source_file
);
5917 /* Write the module itself. */
5919 module_name
= gfc_get_string (name
);
5925 free_pi_tree (pi_root
);
5930 if (gzclose (module_fp
))
5931 gfc_fatal_error ("Error writing module file %qs for writing: %s",
5932 filename_tmp
, xstrerror (errno
));
5934 /* Read the CRC32 from the gzip trailers of the module files and
5936 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
5937 || !read_crc32_from_module_file (filename
, &crc_old
)
5940 /* Module file have changed, replace the old one. */
5941 if (remove (filename
) && errno
!= ENOENT
)
5942 gfc_fatal_error ("Can't delete module file %qs: %s", filename
,
5944 if (rename (filename_tmp
, filename
))
5945 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
5946 filename_tmp
, filename
, xstrerror (errno
));
5950 if (remove (filename_tmp
))
5951 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
5952 filename_tmp
, xstrerror (errno
));
5958 create_intrinsic_function (const char *name
, int id
,
5959 const char *modname
, intmod_id module
,
5960 bool subroutine
, gfc_symbol
*result_type
)
5962 gfc_intrinsic_sym
*isym
;
5963 gfc_symtree
*tmp_symtree
;
5966 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5969 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5971 gfc_error ("Symbol %qs already declared", name
);
5974 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5975 sym
= tmp_symtree
->n
.sym
;
5979 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5980 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
5981 sym
->attr
.subroutine
= 1;
5985 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5986 isym
= gfc_intrinsic_function_by_id (isym_id
);
5988 sym
->attr
.function
= 1;
5991 sym
->ts
.type
= BT_DERIVED
;
5992 sym
->ts
.u
.derived
= result_type
;
5993 sym
->ts
.is_c_interop
= 1;
5994 isym
->ts
.f90_type
= BT_VOID
;
5995 isym
->ts
.type
= BT_DERIVED
;
5996 isym
->ts
.f90_type
= BT_VOID
;
5997 isym
->ts
.u
.derived
= result_type
;
5998 isym
->ts
.is_c_interop
= 1;
6003 sym
->attr
.flavor
= FL_PROCEDURE
;
6004 sym
->attr
.intrinsic
= 1;
6006 sym
->module
= gfc_get_string (modname
);
6007 sym
->attr
.use_assoc
= 1;
6008 sym
->from_intmod
= module
;
6009 sym
->intmod_sym_id
= id
;
6013 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6014 the current namespace for all named constants, pointer types, and
6015 procedures in the module unless the only clause was used or a rename
6016 list was provided. */
6019 import_iso_c_binding_module (void)
6021 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6022 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6023 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6024 const char *iso_c_module_name
= "__iso_c_binding";
6027 bool want_c_ptr
= false, want_c_funptr
= false;
6029 /* Look only in the current namespace. */
6030 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6032 if (mod_symtree
== NULL
)
6034 /* symtree doesn't already exist in current namespace. */
6035 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6038 if (mod_symtree
!= NULL
)
6039 mod_sym
= mod_symtree
->n
.sym
;
6041 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6042 "create symbol for %s", iso_c_module_name
);
6044 mod_sym
->attr
.flavor
= FL_MODULE
;
6045 mod_sym
->attr
.intrinsic
= 1;
6046 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6047 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6050 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6051 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6053 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6055 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6058 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6061 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6063 want_c_funptr
= true;
6064 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6066 want_c_funptr
= true;
6067 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6070 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6071 (iso_c_binding_symbol
)
6073 u
->local_name
[0] ? u
->local_name
6077 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6081 = generate_isocbinding_symbol (iso_c_module_name
,
6082 (iso_c_binding_symbol
)
6084 u
->local_name
[0] ? u
->local_name
6090 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6091 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6092 (iso_c_binding_symbol
)
6094 NULL
, NULL
, only_flag
);
6095 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6096 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6097 (iso_c_binding_symbol
)
6099 NULL
, NULL
, only_flag
);
6101 /* Generate the symbols for the named constants representing
6102 the kinds for intrinsic data types. */
6103 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6106 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6107 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6116 #define NAMED_FUNCTION(a,b,c,d) \
6118 not_in_std = (gfc_option.allow_std & d) == 0; \
6121 #define NAMED_SUBROUTINE(a,b,c,d) \
6123 not_in_std = (gfc_option.allow_std & d) == 0; \
6126 #define NAMED_INTCST(a,b,c,d) \
6128 not_in_std = (gfc_option.allow_std & d) == 0; \
6131 #define NAMED_REALCST(a,b,c,d) \
6133 not_in_std = (gfc_option.allow_std & d) == 0; \
6136 #define NAMED_CMPXCST(a,b,c,d) \
6138 not_in_std = (gfc_option.allow_std & d) == 0; \
6141 #include "iso-c-binding.def"
6149 gfc_error ("The symbol %qs, referenced at %L, is not "
6150 "in the selected standard", name
, &u
->where
);
6156 #define NAMED_FUNCTION(a,b,c,d) \
6158 if (a == ISOCBINDING_LOC) \
6159 return_type = c_ptr->n.sym; \
6160 else if (a == ISOCBINDING_FUNLOC) \
6161 return_type = c_funptr->n.sym; \
6163 return_type = NULL; \
6164 create_intrinsic_function (u->local_name[0] \
6165 ? u->local_name : u->use_name, \
6166 a, iso_c_module_name, \
6167 INTMOD_ISO_C_BINDING, false, \
6170 #define NAMED_SUBROUTINE(a,b,c,d) \
6172 create_intrinsic_function (u->local_name[0] ? u->local_name \
6174 a, iso_c_module_name, \
6175 INTMOD_ISO_C_BINDING, true, NULL); \
6177 #include "iso-c-binding.def"
6179 case ISOCBINDING_PTR
:
6180 case ISOCBINDING_FUNPTR
:
6181 /* Already handled above. */
6184 if (i
== ISOCBINDING_NULL_PTR
)
6185 tmp_symtree
= c_ptr
;
6186 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6187 tmp_symtree
= c_funptr
;
6190 generate_isocbinding_symbol (iso_c_module_name
,
6191 (iso_c_binding_symbol
) i
,
6193 ? u
->local_name
: u
->use_name
,
6194 tmp_symtree
, false);
6198 if (!found
&& !only_flag
)
6200 /* Skip, if the symbol is not in the enabled standard. */
6203 #define NAMED_FUNCTION(a,b,c,d) \
6205 if ((gfc_option.allow_std & d) == 0) \
6208 #define NAMED_SUBROUTINE(a,b,c,d) \
6210 if ((gfc_option.allow_std & d) == 0) \
6213 #define NAMED_INTCST(a,b,c,d) \
6215 if ((gfc_option.allow_std & d) == 0) \
6218 #define NAMED_REALCST(a,b,c,d) \
6220 if ((gfc_option.allow_std & d) == 0) \
6223 #define NAMED_CMPXCST(a,b,c,d) \
6225 if ((gfc_option.allow_std & d) == 0) \
6228 #include "iso-c-binding.def"
6230 ; /* Not GFC_STD_* versioned. */
6235 #define NAMED_FUNCTION(a,b,c,d) \
6237 if (a == ISOCBINDING_LOC) \
6238 return_type = c_ptr->n.sym; \
6239 else if (a == ISOCBINDING_FUNLOC) \
6240 return_type = c_funptr->n.sym; \
6242 return_type = NULL; \
6243 create_intrinsic_function (b, a, iso_c_module_name, \
6244 INTMOD_ISO_C_BINDING, false, \
6247 #define NAMED_SUBROUTINE(a,b,c,d) \
6249 create_intrinsic_function (b, a, iso_c_module_name, \
6250 INTMOD_ISO_C_BINDING, true, NULL); \
6252 #include "iso-c-binding.def"
6254 case ISOCBINDING_PTR
:
6255 case ISOCBINDING_FUNPTR
:
6256 /* Already handled above. */
6259 if (i
== ISOCBINDING_NULL_PTR
)
6260 tmp_symtree
= c_ptr
;
6261 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6262 tmp_symtree
= c_funptr
;
6265 generate_isocbinding_symbol (iso_c_module_name
,
6266 (iso_c_binding_symbol
) i
, NULL
,
6267 tmp_symtree
, false);
6272 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6277 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6278 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6283 /* Add an integer named constant from a given module. */
6286 create_int_parameter (const char *name
, int value
, const char *modname
,
6287 intmod_id module
, int id
)
6289 gfc_symtree
*tmp_symtree
;
6292 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6293 if (tmp_symtree
!= NULL
)
6295 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6298 gfc_error ("Symbol %qs already declared", name
);
6301 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6302 sym
= tmp_symtree
->n
.sym
;
6304 sym
->module
= gfc_get_string (modname
);
6305 sym
->attr
.flavor
= FL_PARAMETER
;
6306 sym
->ts
.type
= BT_INTEGER
;
6307 sym
->ts
.kind
= gfc_default_integer_kind
;
6308 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6309 sym
->attr
.use_assoc
= 1;
6310 sym
->from_intmod
= module
;
6311 sym
->intmod_sym_id
= id
;
6315 /* Value is already contained by the array constructor, but not
6319 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6320 const char *modname
, intmod_id module
, int id
)
6322 gfc_symtree
*tmp_symtree
;
6325 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6326 if (tmp_symtree
!= NULL
)
6328 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6331 gfc_error ("Symbol %qs already declared", name
);
6334 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6335 sym
= tmp_symtree
->n
.sym
;
6337 sym
->module
= gfc_get_string (modname
);
6338 sym
->attr
.flavor
= FL_PARAMETER
;
6339 sym
->ts
.type
= BT_INTEGER
;
6340 sym
->ts
.kind
= gfc_default_integer_kind
;
6341 sym
->attr
.use_assoc
= 1;
6342 sym
->from_intmod
= module
;
6343 sym
->intmod_sym_id
= id
;
6344 sym
->attr
.dimension
= 1;
6345 sym
->as
= gfc_get_array_spec ();
6347 sym
->as
->type
= AS_EXPLICIT
;
6348 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6349 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6352 sym
->value
->shape
= gfc_get_shape (1);
6353 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6357 /* Add an derived type for a given module. */
6360 create_derived_type (const char *name
, const char *modname
,
6361 intmod_id module
, int id
)
6363 gfc_symtree
*tmp_symtree
;
6364 gfc_symbol
*sym
, *dt_sym
;
6365 gfc_interface
*intr
, *head
;
6367 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6368 if (tmp_symtree
!= NULL
)
6370 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6373 gfc_error ("Symbol %qs already declared", name
);
6376 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6377 sym
= tmp_symtree
->n
.sym
;
6378 sym
->module
= gfc_get_string (modname
);
6379 sym
->from_intmod
= module
;
6380 sym
->intmod_sym_id
= id
;
6381 sym
->attr
.flavor
= FL_PROCEDURE
;
6382 sym
->attr
.function
= 1;
6383 sym
->attr
.generic
= 1;
6385 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6386 gfc_current_ns
, &tmp_symtree
, false);
6387 dt_sym
= tmp_symtree
->n
.sym
;
6388 dt_sym
->name
= gfc_get_string (sym
->name
);
6389 dt_sym
->attr
.flavor
= FL_DERIVED
;
6390 dt_sym
->attr
.private_comp
= 1;
6391 dt_sym
->attr
.zero_comp
= 1;
6392 dt_sym
->attr
.use_assoc
= 1;
6393 dt_sym
->module
= gfc_get_string (modname
);
6394 dt_sym
->from_intmod
= module
;
6395 dt_sym
->intmod_sym_id
= id
;
6397 head
= sym
->generic
;
6398 intr
= gfc_get_interface ();
6400 intr
->where
= gfc_current_locus
;
6402 sym
->generic
= intr
;
6403 sym
->attr
.if_source
= IFSRC_DECL
;
6407 /* Read the contents of the module file into a temporary buffer. */
6410 read_module_to_tmpbuf ()
6412 /* We don't know the uncompressed size, so enlarge the buffer as
6418 module_content
= XNEWVEC (char, cursz
);
6422 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6427 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6428 rsize
= cursz
- len
;
6431 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6432 module_content
[len
] = '\0';
6438 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6441 use_iso_fortran_env_module (void)
6443 static char mod
[] = "iso_fortran_env";
6445 gfc_symbol
*mod_sym
;
6446 gfc_symtree
*mod_symtree
;
6450 intmod_sym symbol
[] = {
6451 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6452 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6453 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6454 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6455 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6456 #include "iso-fortran-env.def"
6457 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6460 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6461 #include "iso-fortran-env.def"
6463 /* Generate the symbol for the module itself. */
6464 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6465 if (mod_symtree
== NULL
)
6467 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6468 gcc_assert (mod_symtree
);
6469 mod_sym
= mod_symtree
->n
.sym
;
6471 mod_sym
->attr
.flavor
= FL_MODULE
;
6472 mod_sym
->attr
.intrinsic
= 1;
6473 mod_sym
->module
= gfc_get_string (mod
);
6474 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6477 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6478 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6479 "non-intrinsic module name used previously", mod
);
6481 /* Generate the symbols for the module integer named constants. */
6483 for (i
= 0; symbol
[i
].name
; i
++)
6486 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6488 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6493 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol %qs, "
6494 "referenced at %L, is not in the selected "
6495 "standard", symbol
[i
].name
, &u
->where
))
6498 if ((flag_default_integer
|| flag_default_real
)
6499 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6500 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6501 "constant from intrinsic module "
6502 "ISO_FORTRAN_ENV at %L is incompatible with "
6503 "option %qs", &u
->where
,
6504 flag_default_integer
6505 ? "-fdefault-integer-8"
6506 : "-fdefault-real-8");
6507 switch (symbol
[i
].id
)
6509 #define NAMED_INTCST(a,b,c,d) \
6511 #include "iso-fortran-env.def"
6512 create_int_parameter (u
->local_name
[0] ? u
->local_name
6514 symbol
[i
].value
, mod
,
6515 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6518 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6520 expr = gfc_get_array_expr (BT_INTEGER, \
6521 gfc_default_integer_kind,\
6523 for (j = 0; KINDS[j].kind != 0; j++) \
6524 gfc_constructor_append_expr (&expr->value.constructor, \
6525 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6526 KINDS[j].kind), NULL); \
6527 create_int_parameter_array (u->local_name[0] ? u->local_name \
6530 INTMOD_ISO_FORTRAN_ENV, \
6533 #include "iso-fortran-env.def"
6535 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6537 #include "iso-fortran-env.def"
6538 create_derived_type (u
->local_name
[0] ? u
->local_name
6540 mod
, INTMOD_ISO_FORTRAN_ENV
,
6544 #define NAMED_FUNCTION(a,b,c,d) \
6546 #include "iso-fortran-env.def"
6547 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6550 INTMOD_ISO_FORTRAN_ENV
, false,
6560 if (!found
&& !only_flag
)
6562 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6565 if ((flag_default_integer
|| flag_default_real
)
6566 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6568 "Use of the NUMERIC_STORAGE_SIZE named constant "
6569 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6570 "incompatible with option %s",
6571 flag_default_integer
6572 ? "-fdefault-integer-8" : "-fdefault-real-8");
6574 switch (symbol
[i
].id
)
6576 #define NAMED_INTCST(a,b,c,d) \
6578 #include "iso-fortran-env.def"
6579 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6580 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6583 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6585 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6587 for (j = 0; KINDS[j].kind != 0; j++) \
6588 gfc_constructor_append_expr (&expr->value.constructor, \
6589 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6590 KINDS[j].kind), NULL); \
6591 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6592 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6594 #include "iso-fortran-env.def"
6596 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6598 #include "iso-fortran-env.def"
6599 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6603 #define NAMED_FUNCTION(a,b,c,d) \
6605 #include "iso-fortran-env.def"
6606 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6607 INTMOD_ISO_FORTRAN_ENV
, false,
6617 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6622 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6623 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6628 /* Process a USE directive. */
6631 gfc_use_module (gfc_use_list
*module
)
6636 gfc_symtree
*mod_symtree
;
6637 gfc_use_list
*use_stmt
;
6638 locus old_locus
= gfc_current_locus
;
6640 gfc_current_locus
= module
->where
;
6641 module_name
= module
->module_name
;
6642 gfc_rename_list
= module
->rename
;
6643 only_flag
= module
->only_flag
;
6644 current_intmod
= INTMOD_NONE
;
6647 gfc_warning_now (OPT_Wuse_without_only
,
6648 "USE statement at %C has no ONLY qualifier");
6650 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6652 strcpy (filename
, module_name
);
6653 strcat (filename
, MODULE_EXTENSION
);
6655 /* First, try to find an non-intrinsic module, unless the USE statement
6656 specified that the module is intrinsic. */
6658 if (!module
->intrinsic
)
6659 module_fp
= gzopen_included_file (filename
, true, true);
6661 /* Then, see if it's an intrinsic one, unless the USE statement
6662 specified that the module is non-intrinsic. */
6663 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6665 if (strcmp (module_name
, "iso_fortran_env") == 0
6666 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6667 "intrinsic module at %C"))
6669 use_iso_fortran_env_module ();
6670 free_rename (module
->rename
);
6671 module
->rename
= NULL
;
6672 gfc_current_locus
= old_locus
;
6673 module
->intrinsic
= true;
6677 if (strcmp (module_name
, "iso_c_binding") == 0
6678 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6680 import_iso_c_binding_module();
6681 free_rename (module
->rename
);
6682 module
->rename
= NULL
;
6683 gfc_current_locus
= old_locus
;
6684 module
->intrinsic
= true;
6688 module_fp
= gzopen_intrinsic_module (filename
);
6690 if (module_fp
== NULL
&& module
->intrinsic
)
6691 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6694 /* Check for the IEEE modules, so we can mark their symbols
6695 accordingly when we read them. */
6696 if (strcmp (module_name
, "ieee_features") == 0
6697 && gfc_notify_std (GFC_STD_F2003
, "IEEE_FEATURES module at %C"))
6699 current_intmod
= INTMOD_IEEE_FEATURES
;
6701 else if (strcmp (module_name
, "ieee_exceptions") == 0
6702 && gfc_notify_std (GFC_STD_F2003
,
6703 "IEEE_EXCEPTIONS module at %C"))
6705 current_intmod
= INTMOD_IEEE_EXCEPTIONS
;
6707 else if (strcmp (module_name
, "ieee_arithmetic") == 0
6708 && gfc_notify_std (GFC_STD_F2003
,
6709 "IEEE_ARITHMETIC module at %C"))
6711 current_intmod
= INTMOD_IEEE_ARITHMETIC
;
6715 if (module_fp
== NULL
)
6716 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6717 filename
, xstrerror (errno
));
6719 /* Check that we haven't already USEd an intrinsic module with the
6722 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6723 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6724 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6725 "intrinsic module name used previously", module_name
);
6732 read_module_to_tmpbuf ();
6733 gzclose (module_fp
);
6735 /* Skip the first line of the module, after checking that this is
6736 a gfortran module file. */
6742 bad_module ("Unexpected end of module");
6745 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6746 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6747 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6748 " module file", filename
);
6751 if (strcmp (atom_name
, " version") != 0
6752 || module_char () != ' '
6753 || parse_atom () != ATOM_STRING
6754 || strcmp (atom_string
, MOD_VERSION
))
6755 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6756 " because it was created by a different"
6757 " version of GNU Fortran", filename
);
6766 /* Make sure we're not reading the same module that we may be building. */
6767 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6768 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6769 gfc_fatal_error ("Can't USE the same module we're building!");
6772 init_true_name_tree ();
6776 free_true_name (true_name_root
);
6777 true_name_root
= NULL
;
6779 free_pi_tree (pi_root
);
6782 XDELETEVEC (module_content
);
6783 module_content
= NULL
;
6785 use_stmt
= gfc_get_use_list ();
6786 *use_stmt
= *module
;
6787 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6788 gfc_current_ns
->use_stmts
= use_stmt
;
6790 gfc_current_locus
= old_locus
;
6794 /* Remove duplicated intrinsic operators from the rename list. */
6797 rename_list_remove_duplicate (gfc_use_rename
*list
)
6799 gfc_use_rename
*seek
, *last
;
6801 for (; list
; list
= list
->next
)
6802 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6805 for (seek
= list
->next
; seek
; seek
= last
->next
)
6807 if (list
->op
== seek
->op
)
6809 last
->next
= seek
->next
;
6819 /* Process all USE directives. */
6822 gfc_use_modules (void)
6824 gfc_use_list
*next
, *seek
, *last
;
6826 for (next
= module_list
; next
; next
= next
->next
)
6828 bool non_intrinsic
= next
->non_intrinsic
;
6829 bool intrinsic
= next
->intrinsic
;
6830 bool neither
= !non_intrinsic
&& !intrinsic
;
6832 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6834 if (next
->module_name
!= seek
->module_name
)
6837 if (seek
->non_intrinsic
)
6838 non_intrinsic
= true;
6839 else if (seek
->intrinsic
)
6845 if (intrinsic
&& neither
&& !non_intrinsic
)
6850 filename
= XALLOCAVEC (char,
6851 strlen (next
->module_name
)
6852 + strlen (MODULE_EXTENSION
) + 1);
6853 strcpy (filename
, next
->module_name
);
6854 strcat (filename
, MODULE_EXTENSION
);
6855 fp
= gfc_open_included_file (filename
, true, true);
6858 non_intrinsic
= true;
6864 for (seek
= next
->next
; seek
; seek
= last
->next
)
6866 if (next
->module_name
!= seek
->module_name
)
6872 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6873 || (next
->intrinsic
&& seek
->intrinsic
)
6876 if (!seek
->only_flag
)
6877 next
->only_flag
= false;
6880 gfc_use_rename
*r
= seek
->rename
;
6883 r
->next
= next
->rename
;
6884 next
->rename
= seek
->rename
;
6886 last
->next
= seek
->next
;
6894 for (; module_list
; module_list
= next
)
6896 next
= module_list
->next
;
6897 rename_list_remove_duplicate (module_list
->rename
);
6898 gfc_use_module (module_list
);
6901 gfc_rename_list
= NULL
;
6906 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6909 for (; use_stmts
; use_stmts
= next
)
6911 gfc_use_rename
*next_rename
;
6913 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6915 next_rename
= use_stmts
->rename
->next
;
6916 free (use_stmts
->rename
);
6918 next
= use_stmts
->next
;
6925 gfc_module_init_2 (void)
6927 last_atom
= ATOM_LPAREN
;
6928 gfc_rename_list
= NULL
;
6934 gfc_module_done_2 (void)
6936 free_rename (gfc_rename_list
);
6937 gfc_rename_list
= NULL
;