1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2014 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"
77 #include "stringpool.h"
81 #define MODULE_EXTENSION ".mod"
83 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
85 #define MOD_VERSION "12"
88 /* Structure that describes a position within a module file. */
97 /* Structure for list of symbols of intrinsic modules. */
110 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
114 /* The fixup structure lists pointers to pointers that have to
115 be updated when a pointer value becomes known. */
117 typedef struct fixup_t
120 struct fixup_t
*next
;
125 /* Structure for holding extra info needed for pointers being read. */
141 typedef struct pointer_info
143 BBT_HEADER (pointer_info
);
147 /* The first component of each member of the union is the pointer
154 void *pointer
; /* Member for doing pointer searches. */
159 char *true_name
, *module
, *binding_label
;
161 gfc_symtree
*symtree
;
162 enum gfc_rsym_state state
;
163 int ns
, referenced
, renamed
;
171 enum gfc_wsym_state state
;
180 #define gfc_get_pointer_info() XCNEW (pointer_info)
183 /* Local variables */
185 /* The gzFile for the module we're reading or writing. */
186 static gzFile module_fp
;
189 /* The name of the module we're reading (USE'ing) or writing. */
190 static const char *module_name
;
191 static gfc_use_list
*module_list
;
193 /* Content of module. */
194 static char* module_content
;
196 static long module_pos
;
197 static int module_line
, module_column
, only_flag
;
198 static int prev_module_line
, prev_module_column
;
201 { IO_INPUT
, IO_OUTPUT
}
204 static gfc_use_rename
*gfc_rename_list
;
205 static pointer_info
*pi_root
;
206 static int symbol_number
; /* Counter for assigning symbol numbers */
208 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
209 static bool in_load_equiv
;
213 /*****************************************************************/
215 /* Pointer/integer conversion. Pointers between structures are stored
216 as integers in the module file. The next couple of subroutines
217 handle this translation for reading and writing. */
219 /* Recursively free the tree of pointer structures. */
222 free_pi_tree (pointer_info
*p
)
227 if (p
->fixup
!= NULL
)
228 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
230 free_pi_tree (p
->left
);
231 free_pi_tree (p
->right
);
233 if (iomode
== IO_INPUT
)
235 XDELETEVEC (p
->u
.rsym
.true_name
);
236 XDELETEVEC (p
->u
.rsym
.module
);
237 XDELETEVEC (p
->u
.rsym
.binding_label
);
244 /* Compare pointers when searching by pointer. Used when writing a
248 compare_pointers (void *_sn1
, void *_sn2
)
250 pointer_info
*sn1
, *sn2
;
252 sn1
= (pointer_info
*) _sn1
;
253 sn2
= (pointer_info
*) _sn2
;
255 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
257 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
264 /* Compare integers when searching by integer. Used when reading a
268 compare_integers (void *_sn1
, void *_sn2
)
270 pointer_info
*sn1
, *sn2
;
272 sn1
= (pointer_info
*) _sn1
;
273 sn2
= (pointer_info
*) _sn2
;
275 if (sn1
->integer
< sn2
->integer
)
277 if (sn1
->integer
> sn2
->integer
)
284 /* Initialize the pointer_info tree. */
293 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
295 /* Pointer 0 is the NULL pointer. */
296 p
= gfc_get_pointer_info ();
301 gfc_insert_bbt (&pi_root
, p
, compare
);
303 /* Pointer 1 is the current namespace. */
304 p
= gfc_get_pointer_info ();
305 p
->u
.pointer
= gfc_current_ns
;
307 p
->type
= P_NAMESPACE
;
309 gfc_insert_bbt (&pi_root
, p
, compare
);
315 /* During module writing, call here with a pointer to something,
316 returning the pointer_info node. */
318 static pointer_info
*
319 find_pointer (void *gp
)
326 if (p
->u
.pointer
== gp
)
328 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
335 /* Given a pointer while writing, returns the pointer_info tree node,
336 creating it if it doesn't exist. */
338 static pointer_info
*
339 get_pointer (void *gp
)
343 p
= find_pointer (gp
);
347 /* Pointer doesn't have an integer. Give it one. */
348 p
= gfc_get_pointer_info ();
351 p
->integer
= symbol_number
++;
353 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
359 /* Given an integer during reading, find it in the pointer_info tree,
360 creating the node if not found. */
362 static pointer_info
*
363 get_integer (int integer
)
373 c
= compare_integers (&t
, p
);
377 p
= (c
< 0) ? p
->left
: p
->right
;
383 p
= gfc_get_pointer_info ();
384 p
->integer
= integer
;
387 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
393 /* Resolve any fixups using a known pointer. */
396 resolve_fixups (fixup_t
*f
, void *gp
)
409 /* Convert a string such that it starts with a lower-case character. Used
410 to convert the symtree name of a derived-type to the symbol name or to
411 the name of the associated generic function. */
414 dt_lower_string (const char *name
)
416 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
417 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
419 return gfc_get_string (name
);
423 /* Convert a string such that it starts with an upper-case character. Used to
424 return the symtree-name for a derived type; the symbol name itself and the
425 symtree/symbol name of the associated generic function start with a lower-
429 dt_upper_string (const char *name
)
431 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
432 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
434 return gfc_get_string (name
);
437 /* Call here during module reading when we know what pointer to
438 associate with an integer. Any fixups that exist are resolved at
442 associate_integer_pointer (pointer_info
*p
, void *gp
)
444 if (p
->u
.pointer
!= NULL
)
445 gfc_internal_error ("associate_integer_pointer(): Already associated");
449 resolve_fixups (p
->fixup
, gp
);
455 /* During module reading, given an integer and a pointer to a pointer,
456 either store the pointer from an already-known value or create a
457 fixup structure in order to store things later. Returns zero if
458 the reference has been actually stored, or nonzero if the reference
459 must be fixed later (i.e., associate_integer_pointer must be called
460 sometime later. Returns the pointer_info structure. */
462 static pointer_info
*
463 add_fixup (int integer
, void *gp
)
469 p
= get_integer (integer
);
471 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
474 *cp
= (char *) p
->u
.pointer
;
483 f
->pointer
= (void **) gp
;
490 /*****************************************************************/
492 /* Parser related subroutines */
494 /* Free the rename list left behind by a USE statement. */
497 free_rename (gfc_use_rename
*list
)
499 gfc_use_rename
*next
;
501 for (; list
; list
= next
)
509 /* Match a USE statement. */
514 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
515 gfc_use_rename
*tail
= NULL
, *new_use
;
516 interface_type type
, type2
;
519 gfc_use_list
*use_list
;
521 use_list
= gfc_get_use_list ();
523 if (gfc_match (" , ") == MATCH_YES
)
525 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
527 if (!gfc_notify_std (GFC_STD_F2003
, "module "
528 "nature in USE statement at %C"))
531 if (strcmp (module_nature
, "intrinsic") == 0)
532 use_list
->intrinsic
= true;
535 if (strcmp (module_nature
, "non_intrinsic") == 0)
536 use_list
->non_intrinsic
= true;
539 gfc_error ("Module nature in USE statement at %C shall "
540 "be either INTRINSIC or NON_INTRINSIC");
547 /* Help output a better error message than "Unclassifiable
549 gfc_match (" %n", module_nature
);
550 if (strcmp (module_nature
, "intrinsic") == 0
551 || strcmp (module_nature
, "non_intrinsic") == 0)
552 gfc_error ("\"::\" was expected after module nature at %C "
553 "but was not found");
560 m
= gfc_match (" ::");
561 if (m
== MATCH_YES
&&
562 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
567 m
= gfc_match ("% ");
576 use_list
->where
= gfc_current_locus
;
578 m
= gfc_match_name (name
);
585 use_list
->module_name
= gfc_get_string (name
);
587 if (gfc_match_eos () == MATCH_YES
)
590 if (gfc_match_char (',') != MATCH_YES
)
593 if (gfc_match (" only :") == MATCH_YES
)
594 use_list
->only_flag
= true;
596 if (gfc_match_eos () == MATCH_YES
)
601 /* Get a new rename struct and add it to the rename list. */
602 new_use
= gfc_get_use_rename ();
603 new_use
->where
= gfc_current_locus
;
606 if (use_list
->rename
== NULL
)
607 use_list
->rename
= new_use
;
609 tail
->next
= new_use
;
612 /* See what kind of interface we're dealing with. Assume it is
614 new_use
->op
= INTRINSIC_NONE
;
615 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
620 case INTERFACE_NAMELESS
:
621 gfc_error ("Missing generic specification in USE statement at %C");
624 case INTERFACE_USER_OP
:
625 case INTERFACE_GENERIC
:
626 m
= gfc_match (" =>");
628 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
629 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
630 "operators in USE statements at %C")))
633 if (type
== INTERFACE_USER_OP
)
634 new_use
->op
= INTRINSIC_USER
;
636 if (use_list
->only_flag
)
639 strcpy (new_use
->use_name
, name
);
642 strcpy (new_use
->local_name
, name
);
643 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
648 if (m
== MATCH_ERROR
)
656 strcpy (new_use
->local_name
, name
);
658 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
663 if (m
== MATCH_ERROR
)
667 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
668 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
670 gfc_error ("The name '%s' at %C has already been used as "
671 "an external module name.", use_list
->module_name
);
676 case INTERFACE_INTRINSIC_OP
:
684 if (gfc_match_eos () == MATCH_YES
)
686 if (gfc_match_char (',') != MATCH_YES
)
693 gfc_use_list
*last
= module_list
;
696 last
->next
= use_list
;
699 module_list
= use_list
;
704 gfc_syntax_error (ST_USE
);
707 free_rename (use_list
->rename
);
713 /* Given a name and a number, inst, return the inst name
714 under which to load this symbol. Returns NULL if this
715 symbol shouldn't be loaded. If inst is zero, returns
716 the number of instances of this name. If interface is
717 true, a user-defined operator is sought, otherwise only
718 non-operators are sought. */
721 find_use_name_n (const char *name
, int *inst
, bool interface
)
724 const char *low_name
= NULL
;
727 /* For derived types. */
728 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
729 low_name
= dt_lower_string (name
);
732 for (u
= gfc_rename_list
; u
; u
= u
->next
)
734 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
735 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
736 || (u
->op
== INTRINSIC_USER
&& !interface
)
737 || (u
->op
!= INTRINSIC_USER
&& interface
))
750 return only_flag
? NULL
: name
;
756 if (u
->local_name
[0] == '\0')
758 return dt_upper_string (u
->local_name
);
761 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
765 /* Given a name, return the name under which to load this symbol.
766 Returns NULL if this symbol shouldn't be loaded. */
769 find_use_name (const char *name
, bool interface
)
772 return find_use_name_n (name
, &i
, interface
);
776 /* Given a real name, return the number of use names associated with it. */
779 number_use_names (const char *name
, bool interface
)
782 find_use_name_n (name
, &i
, interface
);
787 /* Try to find the operator in the current list. */
789 static gfc_use_rename
*
790 find_use_operator (gfc_intrinsic_op op
)
794 for (u
= gfc_rename_list
; u
; u
= u
->next
)
802 /*****************************************************************/
804 /* The next couple of subroutines maintain a tree used to avoid a
805 brute-force search for a combination of true name and module name.
806 While symtree names, the name that a particular symbol is known by
807 can changed with USE statements, we still have to keep track of the
808 true names to generate the correct reference, and also avoid
809 loading the same real symbol twice in a program unit.
811 When we start reading, the true name tree is built and maintained
812 as symbols are read. The tree is searched as we load new symbols
813 to see if it already exists someplace in the namespace. */
815 typedef struct true_name
817 BBT_HEADER (true_name
);
823 static true_name
*true_name_root
;
826 /* Compare two true_name structures. */
829 compare_true_names (void *_t1
, void *_t2
)
834 t1
= (true_name
*) _t1
;
835 t2
= (true_name
*) _t2
;
837 c
= ((t1
->sym
->module
> t2
->sym
->module
)
838 - (t1
->sym
->module
< t2
->sym
->module
));
842 return strcmp (t1
->name
, t2
->name
);
846 /* Given a true name, search the true name tree to see if it exists
847 within the main namespace. */
850 find_true_name (const char *name
, const char *module
)
856 t
.name
= gfc_get_string (name
);
858 sym
.module
= gfc_get_string (module
);
866 c
= compare_true_names ((void *) (&t
), (void *) p
);
870 p
= (c
< 0) ? p
->left
: p
->right
;
877 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
880 add_true_name (gfc_symbol
*sym
)
884 t
= XCNEW (true_name
);
886 if (sym
->attr
.flavor
== FL_DERIVED
)
887 t
->name
= dt_upper_string (sym
->name
);
891 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
895 /* Recursive function to build the initial true name tree by
896 recursively traversing the current namespace. */
899 build_tnt (gfc_symtree
*st
)
905 build_tnt (st
->left
);
906 build_tnt (st
->right
);
908 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
909 name
= dt_upper_string (st
->n
.sym
->name
);
911 name
= st
->n
.sym
->name
;
913 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
916 add_true_name (st
->n
.sym
);
920 /* Initialize the true name tree with the current namespace. */
923 init_true_name_tree (void)
925 true_name_root
= NULL
;
926 build_tnt (gfc_current_ns
->sym_root
);
930 /* Recursively free a true name tree node. */
933 free_true_name (true_name
*t
)
937 free_true_name (t
->left
);
938 free_true_name (t
->right
);
944 /*****************************************************************/
946 /* Module reading and writing. */
948 /* The following are versions similar to the ones in scanner.c, but
949 for dealing with compressed module files. */
952 gzopen_included_file_1 (const char *name
, gfc_directorylist
*list
,
953 bool module
, bool system
)
956 gfc_directorylist
*p
;
959 for (p
= list
; p
; p
= p
->next
)
961 if (module
&& !p
->use_for_modules
)
964 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
965 strcpy (fullname
, p
->path
);
966 strcat (fullname
, name
);
968 f
= gzopen (fullname
, "r");
971 if (gfc_cpp_makedep ())
972 gfc_cpp_add_dep (fullname
, system
);
982 gzopen_included_file (const char *name
, bool include_cwd
, bool module
)
986 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
988 f
= gzopen (name
, "r");
989 if (f
&& gfc_cpp_makedep ())
990 gfc_cpp_add_dep (name
, false);
994 f
= gzopen_included_file_1 (name
, include_dirs
, module
, false);
1000 gzopen_intrinsic_module (const char* name
)
1004 if (IS_ABSOLUTE_PATH (name
))
1006 f
= gzopen (name
, "r");
1007 if (f
&& gfc_cpp_makedep ())
1008 gfc_cpp_add_dep (name
, true);
1012 f
= gzopen_included_file_1 (name
, intrinsic_modules_dirs
, true, true);
1020 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
1024 static atom_type last_atom
;
1027 /* The name buffer must be at least as long as a symbol name. Right
1028 now it's not clear how we're going to store numeric constants--
1029 probably as a hexadecimal string, since this will allow the exact
1030 number to be preserved (this can't be done by a decimal
1031 representation). Worry about that later. TODO! */
1033 #define MAX_ATOM_SIZE 100
1035 static int atom_int
;
1036 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1039 /* Report problems with a module. Error reporting is not very
1040 elaborate, since this sorts of errors shouldn't really happen.
1041 This subroutine never returns. */
1043 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1046 bad_module (const char *msgid
)
1048 XDELETEVEC (module_content
);
1049 module_content
= NULL
;
1054 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1055 module_name
, module_line
, module_column
, msgid
);
1058 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1059 module_name
, module_line
, module_column
, msgid
);
1062 gfc_fatal_error ("Module %s at line %d column %d: %s",
1063 module_name
, module_line
, module_column
, msgid
);
1069 /* Set the module's input pointer. */
1072 set_module_locus (module_locus
*m
)
1074 module_column
= m
->column
;
1075 module_line
= m
->line
;
1076 module_pos
= m
->pos
;
1080 /* Get the module's input pointer so that we can restore it later. */
1083 get_module_locus (module_locus
*m
)
1085 m
->column
= module_column
;
1086 m
->line
= module_line
;
1087 m
->pos
= module_pos
;
1091 /* Get the next character in the module, updating our reckoning of
1097 const char c
= module_content
[module_pos
++];
1099 bad_module ("Unexpected EOF");
1101 prev_module_line
= module_line
;
1102 prev_module_column
= module_column
;
1114 /* Unget a character while remembering the line and column. Works for
1115 a single character only. */
1118 module_unget_char (void)
1120 module_line
= prev_module_line
;
1121 module_column
= prev_module_column
;
1125 /* Parse a string constant. The delimiter is guaranteed to be a
1135 atom_string
= XNEWVEC (char, cursz
);
1143 int c2
= module_char ();
1146 module_unget_char ();
1154 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1156 atom_string
[len
] = c
;
1160 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1161 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1165 /* Parse a small integer. */
1168 parse_integer (int c
)
1177 module_unget_char ();
1181 atom_int
= 10 * atom_int
+ c
- '0';
1182 if (atom_int
> 99999999)
1183 bad_module ("Integer overflow");
1205 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1207 module_unget_char ();
1212 if (++len
> GFC_MAX_SYMBOL_LEN
)
1213 bad_module ("Name too long");
1221 /* Read the next atom in the module's input stream. */
1232 while (c
== ' ' || c
== '\r' || c
== '\n');
1257 return ATOM_INTEGER
;
1315 bad_module ("Bad name");
1322 /* Peek at the next atom on the input. */
1333 while (c
== ' ' || c
== '\r' || c
== '\n');
1338 module_unget_char ();
1342 module_unget_char ();
1346 module_unget_char ();
1359 module_unget_char ();
1360 return ATOM_INTEGER
;
1414 module_unget_char ();
1418 bad_module ("Bad name");
1423 /* Read the next atom from the input, requiring that it be a
1427 require_atom (atom_type type
)
1433 column
= module_column
;
1442 p
= _("Expected name");
1445 p
= _("Expected left parenthesis");
1448 p
= _("Expected right parenthesis");
1451 p
= _("Expected integer");
1454 p
= _("Expected string");
1457 gfc_internal_error ("require_atom(): bad atom type required");
1460 module_column
= column
;
1467 /* Given a pointer to an mstring array, require that the current input
1468 be one of the strings in the array. We return the enum value. */
1471 find_enum (const mstring
*m
)
1475 i
= gfc_string2code (m
, atom_name
);
1479 bad_module ("find_enum(): Enum not found");
1485 /* Read a string. The caller is responsible for freeing. */
1491 require_atom (ATOM_STRING
);
1498 /**************** Module output subroutines ***************************/
1500 /* Output a character to a module file. */
1503 write_char (char out
)
1505 if (gzputc (module_fp
, out
) == EOF
)
1506 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1518 /* Write an atom to a module. The line wrapping isn't perfect, but it
1519 should work most of the time. This isn't that big of a deal, since
1520 the file really isn't meant to be read by people anyway. */
1523 write_atom (atom_type atom
, const void *v
)
1533 p
= (const char *) v
;
1545 i
= *((const int *) v
);
1547 gfc_internal_error ("write_atom(): Writing negative integer");
1549 sprintf (buffer
, "%d", i
);
1554 gfc_internal_error ("write_atom(): Trying to write dab atom");
1558 if(p
== NULL
|| *p
== '\0')
1563 if (atom
!= ATOM_RPAREN
)
1565 if (module_column
+ len
> 72)
1570 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1575 if (atom
== ATOM_STRING
)
1578 while (p
!= NULL
&& *p
)
1580 if (atom
== ATOM_STRING
&& *p
== '\'')
1585 if (atom
== ATOM_STRING
)
1593 /***************** Mid-level I/O subroutines *****************/
1595 /* These subroutines let their caller read or write atoms without
1596 caring about which of the two is actually happening. This lets a
1597 subroutine concentrate on the actual format of the data being
1600 static void mio_expr (gfc_expr
**);
1601 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1602 pointer_info
*mio_interface_rest (gfc_interface
**);
1603 static void mio_symtree_ref (gfc_symtree
**);
1605 /* Read or write an enumerated value. On writing, we return the input
1606 value for the convenience of callers. We avoid using an integer
1607 pointer because enums are sometimes inside bitfields. */
1610 mio_name (int t
, const mstring
*m
)
1612 if (iomode
== IO_OUTPUT
)
1613 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1616 require_atom (ATOM_NAME
);
1623 /* Specialization of mio_name. */
1625 #define DECL_MIO_NAME(TYPE) \
1626 static inline TYPE \
1627 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1629 return (TYPE) mio_name ((int) t, m); \
1631 #define MIO_NAME(TYPE) mio_name_##TYPE
1636 if (iomode
== IO_OUTPUT
)
1637 write_atom (ATOM_LPAREN
, NULL
);
1639 require_atom (ATOM_LPAREN
);
1646 if (iomode
== IO_OUTPUT
)
1647 write_atom (ATOM_RPAREN
, NULL
);
1649 require_atom (ATOM_RPAREN
);
1654 mio_integer (int *ip
)
1656 if (iomode
== IO_OUTPUT
)
1657 write_atom (ATOM_INTEGER
, ip
);
1660 require_atom (ATOM_INTEGER
);
1666 /* Read or write a gfc_intrinsic_op value. */
1669 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1671 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1672 if (iomode
== IO_OUTPUT
)
1674 int converted
= (int) *op
;
1675 write_atom (ATOM_INTEGER
, &converted
);
1679 require_atom (ATOM_INTEGER
);
1680 *op
= (gfc_intrinsic_op
) atom_int
;
1685 /* Read or write a character pointer that points to a string on the heap. */
1688 mio_allocated_string (const char *s
)
1690 if (iomode
== IO_OUTPUT
)
1692 write_atom (ATOM_STRING
, s
);
1697 require_atom (ATOM_STRING
);
1703 /* Functions for quoting and unquoting strings. */
1706 quote_string (const gfc_char_t
*s
, const size_t slength
)
1708 const gfc_char_t
*p
;
1712 /* Calculate the length we'll need: a backslash takes two ("\\"),
1713 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1714 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1718 else if (!gfc_wide_is_printable (*p
))
1724 q
= res
= XCNEWVEC (char, len
+ 1);
1725 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1728 *q
++ = '\\', *q
++ = '\\';
1729 else if (!gfc_wide_is_printable (*p
))
1731 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1732 (unsigned HOST_WIDE_INT
) *p
);
1736 *q
++ = (unsigned char) *p
;
1744 unquote_string (const char *s
)
1750 for (p
= s
, len
= 0; *p
; p
++, len
++)
1757 else if (p
[1] == 'U')
1758 p
+= 9; /* That is a "\U????????". */
1760 gfc_internal_error ("unquote_string(): got bad string");
1763 res
= gfc_get_wide_string (len
+ 1);
1764 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1769 res
[i
] = (unsigned char) *p
;
1770 else if (p
[1] == '\\')
1772 res
[i
] = (unsigned char) '\\';
1777 /* We read the 8-digits hexadecimal constant that follows. */
1782 gcc_assert (p
[1] == 'U');
1783 for (j
= 0; j
< 8; j
++)
1786 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1800 /* Read or write a character pointer that points to a wide string on the
1801 heap, performing quoting/unquoting of nonprintable characters using the
1802 form \U???????? (where each ? is a hexadecimal digit).
1803 Length is the length of the string, only known and used in output mode. */
1805 static const gfc_char_t
*
1806 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1808 if (iomode
== IO_OUTPUT
)
1810 char *quoted
= quote_string (s
, length
);
1811 write_atom (ATOM_STRING
, quoted
);
1817 gfc_char_t
*unquoted
;
1819 require_atom (ATOM_STRING
);
1820 unquoted
= unquote_string (atom_string
);
1827 /* Read or write a string that is in static memory. */
1830 mio_pool_string (const char **stringp
)
1832 /* TODO: one could write the string only once, and refer to it via a
1835 /* As a special case we have to deal with a NULL string. This
1836 happens for the 'module' member of 'gfc_symbol's that are not in a
1837 module. We read / write these as the empty string. */
1838 if (iomode
== IO_OUTPUT
)
1840 const char *p
= *stringp
== NULL
? "" : *stringp
;
1841 write_atom (ATOM_STRING
, p
);
1845 require_atom (ATOM_STRING
);
1846 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1852 /* Read or write a string that is inside of some already-allocated
1856 mio_internal_string (char *string
)
1858 if (iomode
== IO_OUTPUT
)
1859 write_atom (ATOM_STRING
, string
);
1862 require_atom (ATOM_STRING
);
1863 strcpy (string
, atom_string
);
1870 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1871 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1872 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1873 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1874 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1875 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1876 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1877 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1878 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1879 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1880 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
1884 static const mstring attr_bits
[] =
1886 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1887 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1888 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1889 minit ("DIMENSION", AB_DIMENSION
),
1890 minit ("CODIMENSION", AB_CODIMENSION
),
1891 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1892 minit ("EXTERNAL", AB_EXTERNAL
),
1893 minit ("INTRINSIC", AB_INTRINSIC
),
1894 minit ("OPTIONAL", AB_OPTIONAL
),
1895 minit ("POINTER", AB_POINTER
),
1896 minit ("VOLATILE", AB_VOLATILE
),
1897 minit ("TARGET", AB_TARGET
),
1898 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1899 minit ("DUMMY", AB_DUMMY
),
1900 minit ("RESULT", AB_RESULT
),
1901 minit ("DATA", AB_DATA
),
1902 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1903 minit ("IN_COMMON", AB_IN_COMMON
),
1904 minit ("FUNCTION", AB_FUNCTION
),
1905 minit ("SUBROUTINE", AB_SUBROUTINE
),
1906 minit ("SEQUENCE", AB_SEQUENCE
),
1907 minit ("ELEMENTAL", AB_ELEMENTAL
),
1908 minit ("PURE", AB_PURE
),
1909 minit ("RECURSIVE", AB_RECURSIVE
),
1910 minit ("GENERIC", AB_GENERIC
),
1911 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1912 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1913 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1914 minit ("IS_BIND_C", AB_IS_BIND_C
),
1915 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1916 minit ("IS_ISO_C", AB_IS_ISO_C
),
1917 minit ("VALUE", AB_VALUE
),
1918 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1919 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1920 minit ("LOCK_COMP", AB_LOCK_COMP
),
1921 minit ("POINTER_COMP", AB_POINTER_COMP
),
1922 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1923 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1924 minit ("ZERO_COMP", AB_ZERO_COMP
),
1925 minit ("PROTECTED", AB_PROTECTED
),
1926 minit ("ABSTRACT", AB_ABSTRACT
),
1927 minit ("IS_CLASS", AB_IS_CLASS
),
1928 minit ("PROCEDURE", AB_PROCEDURE
),
1929 minit ("PROC_POINTER", AB_PROC_POINTER
),
1930 minit ("VTYPE", AB_VTYPE
),
1931 minit ("VTAB", AB_VTAB
),
1932 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
1933 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
1934 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
1938 /* For binding attributes. */
1939 static const mstring binding_passing
[] =
1942 minit ("NOPASS", 1),
1945 static const mstring binding_overriding
[] =
1947 minit ("OVERRIDABLE", 0),
1948 minit ("NON_OVERRIDABLE", 1),
1949 minit ("DEFERRED", 2),
1952 static const mstring binding_generic
[] =
1954 minit ("SPECIFIC", 0),
1955 minit ("GENERIC", 1),
1958 static const mstring binding_ppc
[] =
1960 minit ("NO_PPC", 0),
1965 /* Specialization of mio_name. */
1966 DECL_MIO_NAME (ab_attribute
)
1967 DECL_MIO_NAME (ar_type
)
1968 DECL_MIO_NAME (array_type
)
1970 DECL_MIO_NAME (expr_t
)
1971 DECL_MIO_NAME (gfc_access
)
1972 DECL_MIO_NAME (gfc_intrinsic_op
)
1973 DECL_MIO_NAME (ifsrc
)
1974 DECL_MIO_NAME (save_state
)
1975 DECL_MIO_NAME (procedure_type
)
1976 DECL_MIO_NAME (ref_type
)
1977 DECL_MIO_NAME (sym_flavor
)
1978 DECL_MIO_NAME (sym_intent
)
1979 #undef DECL_MIO_NAME
1981 /* Symbol attributes are stored in list with the first three elements
1982 being the enumerated fields, while the remaining elements (if any)
1983 indicate the individual attribute bits. The access field is not
1984 saved-- it controls what symbols are exported when a module is
1988 mio_symbol_attribute (symbol_attribute
*attr
)
1991 unsigned ext_attr
,extension_level
;
1995 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1996 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1997 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1998 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1999 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2001 ext_attr
= attr
->ext_attr
;
2002 mio_integer ((int *) &ext_attr
);
2003 attr
->ext_attr
= ext_attr
;
2005 extension_level
= attr
->extension
;
2006 mio_integer ((int *) &extension_level
);
2007 attr
->extension
= extension_level
;
2009 if (iomode
== IO_OUTPUT
)
2011 if (attr
->allocatable
)
2012 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2013 if (attr
->artificial
)
2014 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2015 if (attr
->asynchronous
)
2016 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2017 if (attr
->dimension
)
2018 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2019 if (attr
->codimension
)
2020 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2021 if (attr
->contiguous
)
2022 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2024 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2025 if (attr
->intrinsic
)
2026 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2028 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2030 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2031 if (attr
->class_pointer
)
2032 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2033 if (attr
->is_protected
)
2034 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2036 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2037 if (attr
->volatile_
)
2038 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2040 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2041 if (attr
->threadprivate
)
2042 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2044 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2046 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2047 /* We deliberately don't preserve the "entry" flag. */
2050 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2051 if (attr
->in_namelist
)
2052 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2053 if (attr
->in_common
)
2054 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2057 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2058 if (attr
->subroutine
)
2059 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2061 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2063 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2066 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2067 if (attr
->elemental
)
2068 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2070 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2071 if (attr
->implicit_pure
)
2072 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2073 if (attr
->unlimited_polymorphic
)
2074 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2075 if (attr
->recursive
)
2076 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2077 if (attr
->always_explicit
)
2078 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2079 if (attr
->cray_pointer
)
2080 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2081 if (attr
->cray_pointee
)
2082 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2083 if (attr
->is_bind_c
)
2084 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2085 if (attr
->is_c_interop
)
2086 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2088 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2089 if (attr
->alloc_comp
)
2090 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2091 if (attr
->pointer_comp
)
2092 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2093 if (attr
->proc_pointer_comp
)
2094 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2095 if (attr
->private_comp
)
2096 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2097 if (attr
->coarray_comp
)
2098 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2099 if (attr
->lock_comp
)
2100 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2101 if (attr
->zero_comp
)
2102 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2104 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2105 if (attr
->procedure
)
2106 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2107 if (attr
->proc_pointer
)
2108 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2110 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2112 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2122 if (t
== ATOM_RPAREN
)
2125 bad_module ("Expected attribute bit name");
2127 switch ((ab_attribute
) find_enum (attr_bits
))
2129 case AB_ALLOCATABLE
:
2130 attr
->allocatable
= 1;
2133 attr
->artificial
= 1;
2135 case AB_ASYNCHRONOUS
:
2136 attr
->asynchronous
= 1;
2139 attr
->dimension
= 1;
2141 case AB_CODIMENSION
:
2142 attr
->codimension
= 1;
2145 attr
->contiguous
= 1;
2151 attr
->intrinsic
= 1;
2159 case AB_CLASS_POINTER
:
2160 attr
->class_pointer
= 1;
2163 attr
->is_protected
= 1;
2169 attr
->volatile_
= 1;
2174 case AB_THREADPRIVATE
:
2175 attr
->threadprivate
= 1;
2186 case AB_IN_NAMELIST
:
2187 attr
->in_namelist
= 1;
2190 attr
->in_common
= 1;
2196 attr
->subroutine
= 1;
2208 attr
->elemental
= 1;
2213 case AB_IMPLICIT_PURE
:
2214 attr
->implicit_pure
= 1;
2216 case AB_UNLIMITED_POLY
:
2217 attr
->unlimited_polymorphic
= 1;
2220 attr
->recursive
= 1;
2222 case AB_ALWAYS_EXPLICIT
:
2223 attr
->always_explicit
= 1;
2225 case AB_CRAY_POINTER
:
2226 attr
->cray_pointer
= 1;
2228 case AB_CRAY_POINTEE
:
2229 attr
->cray_pointee
= 1;
2232 attr
->is_bind_c
= 1;
2234 case AB_IS_C_INTEROP
:
2235 attr
->is_c_interop
= 1;
2241 attr
->alloc_comp
= 1;
2243 case AB_COARRAY_COMP
:
2244 attr
->coarray_comp
= 1;
2247 attr
->lock_comp
= 1;
2249 case AB_POINTER_COMP
:
2250 attr
->pointer_comp
= 1;
2252 case AB_PROC_POINTER_COMP
:
2253 attr
->proc_pointer_comp
= 1;
2255 case AB_PRIVATE_COMP
:
2256 attr
->private_comp
= 1;
2259 attr
->zero_comp
= 1;
2265 attr
->procedure
= 1;
2267 case AB_PROC_POINTER
:
2268 attr
->proc_pointer
= 1;
2282 static const mstring bt_types
[] = {
2283 minit ("INTEGER", BT_INTEGER
),
2284 minit ("REAL", BT_REAL
),
2285 minit ("COMPLEX", BT_COMPLEX
),
2286 minit ("LOGICAL", BT_LOGICAL
),
2287 minit ("CHARACTER", BT_CHARACTER
),
2288 minit ("DERIVED", BT_DERIVED
),
2289 minit ("CLASS", BT_CLASS
),
2290 minit ("PROCEDURE", BT_PROCEDURE
),
2291 minit ("UNKNOWN", BT_UNKNOWN
),
2292 minit ("VOID", BT_VOID
),
2293 minit ("ASSUMED", BT_ASSUMED
),
2299 mio_charlen (gfc_charlen
**clp
)
2305 if (iomode
== IO_OUTPUT
)
2309 mio_expr (&cl
->length
);
2313 if (peek_atom () != ATOM_RPAREN
)
2315 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2316 mio_expr (&cl
->length
);
2325 /* See if a name is a generated name. */
2328 check_unique_name (const char *name
)
2330 return *name
== '@';
2335 mio_typespec (gfc_typespec
*ts
)
2339 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2341 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2342 mio_integer (&ts
->kind
);
2344 mio_symbol_ref (&ts
->u
.derived
);
2346 mio_symbol_ref (&ts
->interface
);
2348 /* Add info for C interop and is_iso_c. */
2349 mio_integer (&ts
->is_c_interop
);
2350 mio_integer (&ts
->is_iso_c
);
2352 /* If the typespec is for an identifier either from iso_c_binding, or
2353 a constant that was initialized to an identifier from it, use the
2354 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2356 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2358 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2360 if (ts
->type
!= BT_CHARACTER
)
2362 /* ts->u.cl is only valid for BT_CHARACTER. */
2367 mio_charlen (&ts
->u
.cl
);
2369 /* So as not to disturb the existing API, use an ATOM_NAME to
2370 transmit deferred characteristic for characters (F2003). */
2371 if (iomode
== IO_OUTPUT
)
2373 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2374 write_atom (ATOM_NAME
, "DEFERRED_CL");
2376 else if (peek_atom () != ATOM_RPAREN
)
2378 if (parse_atom () != ATOM_NAME
)
2379 bad_module ("Expected string");
2387 static const mstring array_spec_types
[] = {
2388 minit ("EXPLICIT", AS_EXPLICIT
),
2389 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2390 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2391 minit ("DEFERRED", AS_DEFERRED
),
2392 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2398 mio_array_spec (gfc_array_spec
**asp
)
2405 if (iomode
== IO_OUTPUT
)
2413 /* mio_integer expects nonnegative values. */
2414 rank
= as
->rank
> 0 ? as
->rank
: 0;
2415 mio_integer (&rank
);
2419 if (peek_atom () == ATOM_RPAREN
)
2425 *asp
= as
= gfc_get_array_spec ();
2426 mio_integer (&as
->rank
);
2429 mio_integer (&as
->corank
);
2430 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2432 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2434 if (iomode
== IO_INPUT
&& as
->corank
)
2435 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2437 if (as
->rank
+ as
->corank
> 0)
2438 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2440 mio_expr (&as
->lower
[i
]);
2441 mio_expr (&as
->upper
[i
]);
2449 /* Given a pointer to an array reference structure (which lives in a
2450 gfc_ref structure), find the corresponding array specification
2451 structure. Storing the pointer in the ref structure doesn't quite
2452 work when loading from a module. Generating code for an array
2453 reference also needs more information than just the array spec. */
2455 static const mstring array_ref_types
[] = {
2456 minit ("FULL", AR_FULL
),
2457 minit ("ELEMENT", AR_ELEMENT
),
2458 minit ("SECTION", AR_SECTION
),
2464 mio_array_ref (gfc_array_ref
*ar
)
2469 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2470 mio_integer (&ar
->dimen
);
2478 for (i
= 0; i
< ar
->dimen
; i
++)
2479 mio_expr (&ar
->start
[i
]);
2484 for (i
= 0; i
< ar
->dimen
; i
++)
2486 mio_expr (&ar
->start
[i
]);
2487 mio_expr (&ar
->end
[i
]);
2488 mio_expr (&ar
->stride
[i
]);
2494 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2497 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2498 we can't call mio_integer directly. Instead loop over each element
2499 and cast it to/from an integer. */
2500 if (iomode
== IO_OUTPUT
)
2502 for (i
= 0; i
< ar
->dimen
; i
++)
2504 int tmp
= (int)ar
->dimen_type
[i
];
2505 write_atom (ATOM_INTEGER
, &tmp
);
2510 for (i
= 0; i
< ar
->dimen
; i
++)
2512 require_atom (ATOM_INTEGER
);
2513 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2517 if (iomode
== IO_INPUT
)
2519 ar
->where
= gfc_current_locus
;
2521 for (i
= 0; i
< ar
->dimen
; i
++)
2522 ar
->c_where
[i
] = gfc_current_locus
;
2529 /* Saves or restores a pointer. The pointer is converted back and
2530 forth from an integer. We return the pointer_info pointer so that
2531 the caller can take additional action based on the pointer type. */
2533 static pointer_info
*
2534 mio_pointer_ref (void *gp
)
2538 if (iomode
== IO_OUTPUT
)
2540 p
= get_pointer (*((char **) gp
));
2541 write_atom (ATOM_INTEGER
, &p
->integer
);
2545 require_atom (ATOM_INTEGER
);
2546 p
= add_fixup (atom_int
, gp
);
2553 /* Save and load references to components that occur within
2554 expressions. We have to describe these references by a number and
2555 by name. The number is necessary for forward references during
2556 reading, and the name is necessary if the symbol already exists in
2557 the namespace and is not loaded again. */
2560 mio_component_ref (gfc_component
**cp
)
2564 p
= mio_pointer_ref (cp
);
2565 if (p
->type
== P_UNKNOWN
)
2566 p
->type
= P_COMPONENT
;
2570 static void mio_namespace_ref (gfc_namespace
**nsp
);
2571 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2572 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2575 mio_component (gfc_component
*c
, int vtype
)
2582 if (iomode
== IO_OUTPUT
)
2584 p
= get_pointer (c
);
2585 mio_integer (&p
->integer
);
2590 p
= get_integer (n
);
2591 associate_integer_pointer (p
, c
);
2594 if (p
->type
== P_UNKNOWN
)
2595 p
->type
= P_COMPONENT
;
2597 mio_pool_string (&c
->name
);
2598 mio_typespec (&c
->ts
);
2599 mio_array_spec (&c
->as
);
2601 mio_symbol_attribute (&c
->attr
);
2602 if (c
->ts
.type
== BT_CLASS
)
2603 c
->attr
.class_ok
= 1;
2604 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2606 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2607 || strcmp (c
->name
, "_hash") == 0)
2608 mio_expr (&c
->initializer
);
2610 if (c
->attr
.proc_pointer
)
2611 mio_typebound_proc (&c
->tb
);
2618 mio_component_list (gfc_component
**cp
, int vtype
)
2620 gfc_component
*c
, *tail
;
2624 if (iomode
== IO_OUTPUT
)
2626 for (c
= *cp
; c
; c
= c
->next
)
2627 mio_component (c
, vtype
);
2636 if (peek_atom () == ATOM_RPAREN
)
2639 c
= gfc_get_component ();
2640 mio_component (c
, vtype
);
2656 mio_actual_arg (gfc_actual_arglist
*a
)
2659 mio_pool_string (&a
->name
);
2660 mio_expr (&a
->expr
);
2666 mio_actual_arglist (gfc_actual_arglist
**ap
)
2668 gfc_actual_arglist
*a
, *tail
;
2672 if (iomode
== IO_OUTPUT
)
2674 for (a
= *ap
; a
; a
= a
->next
)
2684 if (peek_atom () != ATOM_LPAREN
)
2687 a
= gfc_get_actual_arglist ();
2703 /* Read and write formal argument lists. */
2706 mio_formal_arglist (gfc_formal_arglist
**formal
)
2708 gfc_formal_arglist
*f
, *tail
;
2712 if (iomode
== IO_OUTPUT
)
2714 for (f
= *formal
; f
; f
= f
->next
)
2715 mio_symbol_ref (&f
->sym
);
2719 *formal
= tail
= NULL
;
2721 while (peek_atom () != ATOM_RPAREN
)
2723 f
= gfc_get_formal_arglist ();
2724 mio_symbol_ref (&f
->sym
);
2726 if (*formal
== NULL
)
2739 /* Save or restore a reference to a symbol node. */
2742 mio_symbol_ref (gfc_symbol
**symp
)
2746 p
= mio_pointer_ref (symp
);
2747 if (p
->type
== P_UNKNOWN
)
2750 if (iomode
== IO_OUTPUT
)
2752 if (p
->u
.wsym
.state
== UNREFERENCED
)
2753 p
->u
.wsym
.state
= NEEDS_WRITE
;
2757 if (p
->u
.rsym
.state
== UNUSED
)
2758 p
->u
.rsym
.state
= NEEDED
;
2764 /* Save or restore a reference to a symtree node. */
2767 mio_symtree_ref (gfc_symtree
**stp
)
2772 if (iomode
== IO_OUTPUT
)
2773 mio_symbol_ref (&(*stp
)->n
.sym
);
2776 require_atom (ATOM_INTEGER
);
2777 p
= get_integer (atom_int
);
2779 /* An unused equivalence member; make a symbol and a symtree
2781 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2783 /* Since this is not used, it must have a unique name. */
2784 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2786 /* Make the symbol. */
2787 if (p
->u
.rsym
.sym
== NULL
)
2789 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2791 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2794 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2795 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2796 p
->u
.rsym
.referenced
= 1;
2798 /* If the symbol is PRIVATE and in COMMON, load_commons will
2799 generate a fixup symbol, which must be associated. */
2801 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2805 if (p
->type
== P_UNKNOWN
)
2808 if (p
->u
.rsym
.state
== UNUSED
)
2809 p
->u
.rsym
.state
= NEEDED
;
2811 if (p
->u
.rsym
.symtree
!= NULL
)
2813 *stp
= p
->u
.rsym
.symtree
;
2817 f
= XCNEW (fixup_t
);
2819 f
->next
= p
->u
.rsym
.stfixup
;
2820 p
->u
.rsym
.stfixup
= f
;
2822 f
->pointer
= (void **) stp
;
2829 mio_iterator (gfc_iterator
**ip
)
2835 if (iomode
== IO_OUTPUT
)
2842 if (peek_atom () == ATOM_RPAREN
)
2848 *ip
= gfc_get_iterator ();
2853 mio_expr (&iter
->var
);
2854 mio_expr (&iter
->start
);
2855 mio_expr (&iter
->end
);
2856 mio_expr (&iter
->step
);
2864 mio_constructor (gfc_constructor_base
*cp
)
2870 if (iomode
== IO_OUTPUT
)
2872 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2875 mio_expr (&c
->expr
);
2876 mio_iterator (&c
->iterator
);
2882 while (peek_atom () != ATOM_RPAREN
)
2884 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2887 mio_expr (&c
->expr
);
2888 mio_iterator (&c
->iterator
);
2897 static const mstring ref_types
[] = {
2898 minit ("ARRAY", REF_ARRAY
),
2899 minit ("COMPONENT", REF_COMPONENT
),
2900 minit ("SUBSTRING", REF_SUBSTRING
),
2906 mio_ref (gfc_ref
**rp
)
2913 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2918 mio_array_ref (&r
->u
.ar
);
2922 mio_symbol_ref (&r
->u
.c
.sym
);
2923 mio_component_ref (&r
->u
.c
.component
);
2927 mio_expr (&r
->u
.ss
.start
);
2928 mio_expr (&r
->u
.ss
.end
);
2929 mio_charlen (&r
->u
.ss
.length
);
2938 mio_ref_list (gfc_ref
**rp
)
2940 gfc_ref
*ref
, *head
, *tail
;
2944 if (iomode
== IO_OUTPUT
)
2946 for (ref
= *rp
; ref
; ref
= ref
->next
)
2953 while (peek_atom () != ATOM_RPAREN
)
2956 head
= tail
= gfc_get_ref ();
2959 tail
->next
= gfc_get_ref ();
2973 /* Read and write an integer value. */
2976 mio_gmp_integer (mpz_t
*integer
)
2980 if (iomode
== IO_INPUT
)
2982 if (parse_atom () != ATOM_STRING
)
2983 bad_module ("Expected integer string");
2985 mpz_init (*integer
);
2986 if (mpz_set_str (*integer
, atom_string
, 10))
2987 bad_module ("Error converting integer");
2993 p
= mpz_get_str (NULL
, 10, *integer
);
2994 write_atom (ATOM_STRING
, p
);
3001 mio_gmp_real (mpfr_t
*real
)
3006 if (iomode
== IO_INPUT
)
3008 if (parse_atom () != ATOM_STRING
)
3009 bad_module ("Expected real string");
3012 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3017 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3019 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3021 write_atom (ATOM_STRING
, p
);
3026 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3028 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3030 /* Fix negative numbers. */
3031 if (atom_string
[2] == '-')
3033 atom_string
[0] = '-';
3034 atom_string
[1] = '0';
3035 atom_string
[2] = '.';
3038 write_atom (ATOM_STRING
, atom_string
);
3046 /* Save and restore the shape of an array constructor. */
3049 mio_shape (mpz_t
**pshape
, int rank
)
3055 /* A NULL shape is represented by (). */
3058 if (iomode
== IO_OUTPUT
)
3070 if (t
== ATOM_RPAREN
)
3077 shape
= gfc_get_shape (rank
);
3081 for (n
= 0; n
< rank
; n
++)
3082 mio_gmp_integer (&shape
[n
]);
3088 static const mstring expr_types
[] = {
3089 minit ("OP", EXPR_OP
),
3090 minit ("FUNCTION", EXPR_FUNCTION
),
3091 minit ("CONSTANT", EXPR_CONSTANT
),
3092 minit ("VARIABLE", EXPR_VARIABLE
),
3093 minit ("SUBSTRING", EXPR_SUBSTRING
),
3094 minit ("STRUCTURE", EXPR_STRUCTURE
),
3095 minit ("ARRAY", EXPR_ARRAY
),
3096 minit ("NULL", EXPR_NULL
),
3097 minit ("COMPCALL", EXPR_COMPCALL
),
3101 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3102 generic operators, not in expressions. INTRINSIC_USER is also
3103 replaced by the correct function name by the time we see it. */
3105 static const mstring intrinsics
[] =
3107 minit ("UPLUS", INTRINSIC_UPLUS
),
3108 minit ("UMINUS", INTRINSIC_UMINUS
),
3109 minit ("PLUS", INTRINSIC_PLUS
),
3110 minit ("MINUS", INTRINSIC_MINUS
),
3111 minit ("TIMES", INTRINSIC_TIMES
),
3112 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3113 minit ("POWER", INTRINSIC_POWER
),
3114 minit ("CONCAT", INTRINSIC_CONCAT
),
3115 minit ("AND", INTRINSIC_AND
),
3116 minit ("OR", INTRINSIC_OR
),
3117 minit ("EQV", INTRINSIC_EQV
),
3118 minit ("NEQV", INTRINSIC_NEQV
),
3119 minit ("EQ_SIGN", INTRINSIC_EQ
),
3120 minit ("EQ", INTRINSIC_EQ_OS
),
3121 minit ("NE_SIGN", INTRINSIC_NE
),
3122 minit ("NE", INTRINSIC_NE_OS
),
3123 minit ("GT_SIGN", INTRINSIC_GT
),
3124 minit ("GT", INTRINSIC_GT_OS
),
3125 minit ("GE_SIGN", INTRINSIC_GE
),
3126 minit ("GE", INTRINSIC_GE_OS
),
3127 minit ("LT_SIGN", INTRINSIC_LT
),
3128 minit ("LT", INTRINSIC_LT_OS
),
3129 minit ("LE_SIGN", INTRINSIC_LE
),
3130 minit ("LE", INTRINSIC_LE_OS
),
3131 minit ("NOT", INTRINSIC_NOT
),
3132 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3137 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3140 fix_mio_expr (gfc_expr
*e
)
3142 gfc_symtree
*ns_st
= NULL
;
3145 if (iomode
!= IO_OUTPUT
)
3150 /* If this is a symtree for a symbol that came from a contained module
3151 namespace, it has a unique name and we should look in the current
3152 namespace to see if the required, non-contained symbol is available
3153 yet. If so, the latter should be written. */
3154 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3156 const char *name
= e
->symtree
->n
.sym
->name
;
3157 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3158 name
= dt_upper_string (name
);
3159 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3162 /* On the other hand, if the existing symbol is the module name or the
3163 new symbol is a dummy argument, do not do the promotion. */
3164 if (ns_st
&& ns_st
->n
.sym
3165 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3166 && !e
->symtree
->n
.sym
->attr
.dummy
)
3169 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
3173 /* In some circumstances, a function used in an initialization
3174 expression, in one use associated module, can fail to be
3175 coupled to its symtree when used in a specification
3176 expression in another module. */
3177 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3178 : e
->value
.function
.isym
->name
;
3179 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3184 /* This is probably a reference to a private procedure from another
3185 module. To prevent a segfault, make a generic with no specific
3186 instances. If this module is used, without the required
3187 specific coming from somewhere, the appropriate error message
3189 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3190 sym
->attr
.flavor
= FL_PROCEDURE
;
3191 sym
->attr
.generic
= 1;
3192 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3193 gfc_commit_symbol (sym
);
3198 /* Read and write expressions. The form "()" is allowed to indicate a
3202 mio_expr (gfc_expr
**ep
)
3210 if (iomode
== IO_OUTPUT
)
3219 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3224 if (t
== ATOM_RPAREN
)
3231 bad_module ("Expected expression type");
3233 e
= *ep
= gfc_get_expr ();
3234 e
->where
= gfc_current_locus
;
3235 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3238 mio_typespec (&e
->ts
);
3239 mio_integer (&e
->rank
);
3243 switch (e
->expr_type
)
3247 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3249 switch (e
->value
.op
.op
)
3251 case INTRINSIC_UPLUS
:
3252 case INTRINSIC_UMINUS
:
3254 case INTRINSIC_PARENTHESES
:
3255 mio_expr (&e
->value
.op
.op1
);
3258 case INTRINSIC_PLUS
:
3259 case INTRINSIC_MINUS
:
3260 case INTRINSIC_TIMES
:
3261 case INTRINSIC_DIVIDE
:
3262 case INTRINSIC_POWER
:
3263 case INTRINSIC_CONCAT
:
3267 case INTRINSIC_NEQV
:
3269 case INTRINSIC_EQ_OS
:
3271 case INTRINSIC_NE_OS
:
3273 case INTRINSIC_GT_OS
:
3275 case INTRINSIC_GE_OS
:
3277 case INTRINSIC_LT_OS
:
3279 case INTRINSIC_LE_OS
:
3280 mio_expr (&e
->value
.op
.op1
);
3281 mio_expr (&e
->value
.op
.op2
);
3285 bad_module ("Bad operator");
3291 mio_symtree_ref (&e
->symtree
);
3292 mio_actual_arglist (&e
->value
.function
.actual
);
3294 if (iomode
== IO_OUTPUT
)
3296 e
->value
.function
.name
3297 = mio_allocated_string (e
->value
.function
.name
);
3298 if (e
->value
.function
.esym
)
3304 mio_integer (&flag
);
3308 mio_symbol_ref (&e
->value
.function
.esym
);
3311 mio_ref_list (&e
->ref
);
3314 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3319 require_atom (ATOM_STRING
);
3320 e
->value
.function
.name
= gfc_get_string (atom_string
);
3323 mio_integer (&flag
);
3327 mio_symbol_ref (&e
->value
.function
.esym
);
3330 mio_ref_list (&e
->ref
);
3333 require_atom (ATOM_STRING
);
3334 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3342 mio_symtree_ref (&e
->symtree
);
3343 mio_ref_list (&e
->ref
);
3346 case EXPR_SUBSTRING
:
3347 e
->value
.character
.string
3348 = CONST_CAST (gfc_char_t
*,
3349 mio_allocated_wide_string (e
->value
.character
.string
,
3350 e
->value
.character
.length
));
3351 mio_ref_list (&e
->ref
);
3354 case EXPR_STRUCTURE
:
3356 mio_constructor (&e
->value
.constructor
);
3357 mio_shape (&e
->shape
, e
->rank
);
3364 mio_gmp_integer (&e
->value
.integer
);
3368 gfc_set_model_kind (e
->ts
.kind
);
3369 mio_gmp_real (&e
->value
.real
);
3373 gfc_set_model_kind (e
->ts
.kind
);
3374 mio_gmp_real (&mpc_realref (e
->value
.complex));
3375 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3379 mio_integer (&e
->value
.logical
);
3383 mio_integer (&e
->value
.character
.length
);
3384 e
->value
.character
.string
3385 = CONST_CAST (gfc_char_t
*,
3386 mio_allocated_wide_string (e
->value
.character
.string
,
3387 e
->value
.character
.length
));
3391 bad_module ("Bad type in constant expression");
3409 /* Read and write namelists. */
3412 mio_namelist (gfc_symbol
*sym
)
3414 gfc_namelist
*n
, *m
;
3415 const char *check_name
;
3419 if (iomode
== IO_OUTPUT
)
3421 for (n
= sym
->namelist
; n
; n
= n
->next
)
3422 mio_symbol_ref (&n
->sym
);
3426 /* This departure from the standard is flagged as an error.
3427 It does, in fact, work correctly. TODO: Allow it
3429 if (sym
->attr
.flavor
== FL_NAMELIST
)
3431 check_name
= find_use_name (sym
->name
, false);
3432 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3433 gfc_error ("Namelist %s cannot be renamed by USE "
3434 "association to %s", sym
->name
, check_name
);
3438 while (peek_atom () != ATOM_RPAREN
)
3440 n
= gfc_get_namelist ();
3441 mio_symbol_ref (&n
->sym
);
3443 if (sym
->namelist
== NULL
)
3450 sym
->namelist_tail
= m
;
3457 /* Save/restore lists of gfc_interface structures. When loading an
3458 interface, we are really appending to the existing list of
3459 interfaces. Checking for duplicate and ambiguous interfaces has to
3460 be done later when all symbols have been loaded. */
3463 mio_interface_rest (gfc_interface
**ip
)
3465 gfc_interface
*tail
, *p
;
3466 pointer_info
*pi
= NULL
;
3468 if (iomode
== IO_OUTPUT
)
3471 for (p
= *ip
; p
; p
= p
->next
)
3472 mio_symbol_ref (&p
->sym
);
3487 if (peek_atom () == ATOM_RPAREN
)
3490 p
= gfc_get_interface ();
3491 p
->where
= gfc_current_locus
;
3492 pi
= mio_symbol_ref (&p
->sym
);
3508 /* Save/restore a nameless operator interface. */
3511 mio_interface (gfc_interface
**ip
)
3514 mio_interface_rest (ip
);
3518 /* Save/restore a named operator interface. */
3521 mio_symbol_interface (const char **name
, const char **module
,
3525 mio_pool_string (name
);
3526 mio_pool_string (module
);
3527 mio_interface_rest (ip
);
3532 mio_namespace_ref (gfc_namespace
**nsp
)
3537 p
= mio_pointer_ref (nsp
);
3539 if (p
->type
== P_UNKNOWN
)
3540 p
->type
= P_NAMESPACE
;
3542 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3544 ns
= (gfc_namespace
*) p
->u
.pointer
;
3547 ns
= gfc_get_namespace (NULL
, 0);
3548 associate_integer_pointer (p
, ns
);
3556 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3558 static gfc_namespace
* current_f2k_derived
;
3561 mio_typebound_proc (gfc_typebound_proc
** proc
)
3564 int overriding_flag
;
3566 if (iomode
== IO_INPUT
)
3568 *proc
= gfc_get_typebound_proc (NULL
);
3569 (*proc
)->where
= gfc_current_locus
;
3575 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3577 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3578 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3579 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3580 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3581 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3582 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3583 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3585 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3586 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3587 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3589 mio_pool_string (&((*proc
)->pass_arg
));
3591 flag
= (int) (*proc
)->pass_arg_num
;
3592 mio_integer (&flag
);
3593 (*proc
)->pass_arg_num
= (unsigned) flag
;
3595 if ((*proc
)->is_generic
)
3602 if (iomode
== IO_OUTPUT
)
3603 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3605 iop
= (int) g
->is_operator
;
3607 mio_allocated_string (g
->specific_st
->name
);
3611 (*proc
)->u
.generic
= NULL
;
3612 while (peek_atom () != ATOM_RPAREN
)
3614 gfc_symtree
** sym_root
;
3616 g
= gfc_get_tbp_generic ();
3620 g
->is_operator
= (bool) iop
;
3622 require_atom (ATOM_STRING
);
3623 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3624 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3627 g
->next
= (*proc
)->u
.generic
;
3628 (*proc
)->u
.generic
= g
;
3634 else if (!(*proc
)->ppc
)
3635 mio_symtree_ref (&(*proc
)->u
.specific
);
3640 /* Walker-callback function for this purpose. */
3642 mio_typebound_symtree (gfc_symtree
* st
)
3644 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3647 if (iomode
== IO_OUTPUT
)
3650 mio_allocated_string (st
->name
);
3652 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3654 mio_typebound_proc (&st
->n
.tb
);
3658 /* IO a full symtree (in all depth). */
3660 mio_full_typebound_tree (gfc_symtree
** root
)
3664 if (iomode
== IO_OUTPUT
)
3665 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3668 while (peek_atom () == ATOM_LPAREN
)
3674 require_atom (ATOM_STRING
);
3675 st
= gfc_get_tbp_symtree (root
, atom_string
);
3678 mio_typebound_symtree (st
);
3686 mio_finalizer (gfc_finalizer
**f
)
3688 if (iomode
== IO_OUTPUT
)
3691 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3692 mio_symtree_ref (&(*f
)->proc_tree
);
3696 *f
= gfc_get_finalizer ();
3697 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3700 mio_symtree_ref (&(*f
)->proc_tree
);
3701 (*f
)->proc_sym
= NULL
;
3706 mio_f2k_derived (gfc_namespace
*f2k
)
3708 current_f2k_derived
= f2k
;
3710 /* Handle the list of finalizer procedures. */
3712 if (iomode
== IO_OUTPUT
)
3715 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3720 f2k
->finalizers
= NULL
;
3721 while (peek_atom () != ATOM_RPAREN
)
3723 gfc_finalizer
*cur
= NULL
;
3724 mio_finalizer (&cur
);
3725 cur
->next
= f2k
->finalizers
;
3726 f2k
->finalizers
= cur
;
3731 /* Handle type-bound procedures. */
3732 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3734 /* Type-bound user operators. */
3735 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3737 /* Type-bound intrinsic operators. */
3739 if (iomode
== IO_OUTPUT
)
3742 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3744 gfc_intrinsic_op realop
;
3746 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3750 realop
= (gfc_intrinsic_op
) op
;
3751 mio_intrinsic_op (&realop
);
3752 mio_typebound_proc (&f2k
->tb_op
[op
]);
3757 while (peek_atom () != ATOM_RPAREN
)
3759 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3762 mio_intrinsic_op (&op
);
3763 mio_typebound_proc (&f2k
->tb_op
[op
]);
3770 mio_full_f2k_derived (gfc_symbol
*sym
)
3774 if (iomode
== IO_OUTPUT
)
3776 if (sym
->f2k_derived
)
3777 mio_f2k_derived (sym
->f2k_derived
);
3781 if (peek_atom () != ATOM_RPAREN
)
3783 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3784 mio_f2k_derived (sym
->f2k_derived
);
3787 gcc_assert (!sym
->f2k_derived
);
3794 /* Unlike most other routines, the address of the symbol node is already
3795 fixed on input and the name/module has already been filled in.
3796 If you update the symbol format here, don't forget to update read_module
3797 as well (look for "seek to the symbol's component list"). */
3800 mio_symbol (gfc_symbol
*sym
)
3802 int intmod
= INTMOD_NONE
;
3806 mio_symbol_attribute (&sym
->attr
);
3808 /* Note that components are always saved, even if they are supposed
3809 to be private. Component access is checked during searching. */
3810 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
3811 if (sym
->components
!= NULL
)
3812 sym
->component_access
3813 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3815 mio_typespec (&sym
->ts
);
3816 if (sym
->ts
.type
== BT_CLASS
)
3817 sym
->attr
.class_ok
= 1;
3819 if (iomode
== IO_OUTPUT
)
3820 mio_namespace_ref (&sym
->formal_ns
);
3823 mio_namespace_ref (&sym
->formal_ns
);
3825 sym
->formal_ns
->proc_name
= sym
;
3828 /* Save/restore common block links. */
3829 mio_symbol_ref (&sym
->common_next
);
3831 mio_formal_arglist (&sym
->formal
);
3833 if (sym
->attr
.flavor
== FL_PARAMETER
)
3834 mio_expr (&sym
->value
);
3836 mio_array_spec (&sym
->as
);
3838 mio_symbol_ref (&sym
->result
);
3840 if (sym
->attr
.cray_pointee
)
3841 mio_symbol_ref (&sym
->cp_pointer
);
3843 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3844 mio_full_f2k_derived (sym
);
3848 /* Add the fields that say whether this is from an intrinsic module,
3849 and if so, what symbol it is within the module. */
3850 /* mio_integer (&(sym->from_intmod)); */
3851 if (iomode
== IO_OUTPUT
)
3853 intmod
= sym
->from_intmod
;
3854 mio_integer (&intmod
);
3858 mio_integer (&intmod
);
3859 sym
->from_intmod
= (intmod_id
) intmod
;
3862 mio_integer (&(sym
->intmod_sym_id
));
3864 if (sym
->attr
.flavor
== FL_DERIVED
)
3865 mio_integer (&(sym
->hash_value
));
3871 /************************* Top level subroutines *************************/
3873 /* Given a root symtree node and a symbol, try to find a symtree that
3874 references the symbol that is not a unique name. */
3876 static gfc_symtree
*
3877 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3879 gfc_symtree
*s
= NULL
;
3884 s
= find_symtree_for_symbol (st
->right
, sym
);
3887 s
= find_symtree_for_symbol (st
->left
, sym
);
3891 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3898 /* A recursive function to look for a specific symbol by name and by
3899 module. Whilst several symtrees might point to one symbol, its
3900 is sufficient for the purposes here than one exist. Note that
3901 generic interfaces are distinguished as are symbols that have been
3902 renamed in another module. */
3903 static gfc_symtree
*
3904 find_symbol (gfc_symtree
*st
, const char *name
,
3905 const char *module
, int generic
)
3908 gfc_symtree
*retval
, *s
;
3910 if (st
== NULL
|| st
->n
.sym
== NULL
)
3913 c
= strcmp (name
, st
->n
.sym
->name
);
3914 if (c
== 0 && st
->n
.sym
->module
3915 && strcmp (module
, st
->n
.sym
->module
) == 0
3916 && !check_unique_name (st
->name
))
3918 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3920 /* Detect symbols that are renamed by use association in another
3921 module by the absence of a symtree and null attr.use_rename,
3922 since the latter is not transmitted in the module file. */
3923 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3924 || (generic
&& st
->n
.sym
->attr
.generic
))
3925 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3929 retval
= find_symbol (st
->left
, name
, module
, generic
);
3932 retval
= find_symbol (st
->right
, name
, module
, generic
);
3938 /* Skip a list between balanced left and right parens.
3939 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
3940 have been already parsed by hand, and the remaining of the content is to be
3941 skipped here. The default value is 0 (balanced parens). */
3944 skip_list (int nest_level
= 0)
3951 switch (parse_atom ())
3974 /* Load operator interfaces from the module. Interfaces are unusual
3975 in that they attach themselves to existing symbols. */
3978 load_operator_interfaces (void)
3981 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3983 pointer_info
*pi
= NULL
;
3988 while (peek_atom () != ATOM_RPAREN
)
3992 mio_internal_string (name
);
3993 mio_internal_string (module
);
3995 n
= number_use_names (name
, true);
3998 for (i
= 1; i
<= n
; i
++)
4000 /* Decide if we need to load this one or not. */
4001 p
= find_use_name_n (name
, &i
, true);
4005 while (parse_atom () != ATOM_RPAREN
);
4011 uop
= gfc_get_uop (p
);
4012 pi
= mio_interface_rest (&uop
->op
);
4016 if (gfc_find_uop (p
, NULL
))
4018 uop
= gfc_get_uop (p
);
4019 uop
->op
= gfc_get_interface ();
4020 uop
->op
->where
= gfc_current_locus
;
4021 add_fixup (pi
->integer
, &uop
->op
->sym
);
4030 /* Load interfaces from the module. Interfaces are unusual in that
4031 they attach themselves to existing symbols. */
4034 load_generic_interfaces (void)
4037 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4039 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4041 bool ambiguous_set
= false;
4045 while (peek_atom () != ATOM_RPAREN
)
4049 mio_internal_string (name
);
4050 mio_internal_string (module
);
4052 n
= number_use_names (name
, false);
4053 renamed
= n
? 1 : 0;
4056 for (i
= 1; i
<= n
; i
++)
4059 /* Decide if we need to load this one or not. */
4060 p
= find_use_name_n (name
, &i
, false);
4062 st
= find_symbol (gfc_current_ns
->sym_root
,
4063 name
, module_name
, 1);
4065 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4067 /* Skip the specific names for these cases. */
4068 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4073 /* If the symbol exists already and is being USEd without being
4074 in an ONLY clause, do not load a new symtree(11.3.2). */
4075 if (!only_flag
&& st
)
4083 if (strcmp (st
->name
, p
) != 0)
4085 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4091 /* Since we haven't found a valid generic interface, we had
4095 gfc_get_symbol (p
, NULL
, &sym
);
4096 sym
->name
= gfc_get_string (name
);
4097 sym
->module
= module_name
;
4098 sym
->attr
.flavor
= FL_PROCEDURE
;
4099 sym
->attr
.generic
= 1;
4100 sym
->attr
.use_assoc
= 1;
4105 /* Unless sym is a generic interface, this reference
4108 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4112 if (st
&& !sym
->attr
.generic
4115 && strcmp (module
, sym
->module
))
4117 ambiguous_set
= true;
4122 sym
->attr
.use_only
= only_flag
;
4123 sym
->attr
.use_rename
= renamed
;
4127 mio_interface_rest (&sym
->generic
);
4128 generic
= sym
->generic
;
4130 else if (!sym
->generic
)
4132 sym
->generic
= generic
;
4133 sym
->attr
.generic_copy
= 1;
4136 /* If a procedure that is not generic has generic interfaces
4137 that include itself, it is generic! We need to take care
4138 to retain symbols ambiguous that were already so. */
4139 if (sym
->attr
.use_assoc
4140 && !sym
->attr
.generic
4141 && sym
->attr
.flavor
== FL_PROCEDURE
)
4143 for (gen
= generic
; gen
; gen
= gen
->next
)
4145 if (gen
->sym
== sym
)
4147 sym
->attr
.generic
= 1;
4162 /* Load common blocks. */
4167 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4172 while (peek_atom () != ATOM_RPAREN
)
4177 mio_internal_string (name
);
4179 p
= gfc_get_common (name
, 1);
4181 mio_symbol_ref (&p
->head
);
4182 mio_integer (&flags
);
4186 p
->threadprivate
= 1;
4189 /* Get whether this was a bind(c) common or not. */
4190 mio_integer (&p
->is_bind_c
);
4191 /* Get the binding label. */
4192 label
= read_string ();
4194 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4204 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4205 so that unused variables are not loaded and so that the expression can
4211 gfc_equiv
*head
, *tail
, *end
, *eq
;
4215 in_load_equiv
= true;
4217 end
= gfc_current_ns
->equiv
;
4218 while (end
!= NULL
&& end
->next
!= NULL
)
4221 while (peek_atom () != ATOM_RPAREN
) {
4225 while(peek_atom () != ATOM_RPAREN
)
4228 head
= tail
= gfc_get_equiv ();
4231 tail
->eq
= gfc_get_equiv ();
4235 mio_pool_string (&tail
->module
);
4236 mio_expr (&tail
->expr
);
4239 /* Unused equivalence members have a unique name. In addition, it
4240 must be checked that the symbols are from the same module. */
4242 for (eq
= head
; eq
; eq
= eq
->eq
)
4244 if (eq
->expr
->symtree
->n
.sym
->module
4245 && head
->expr
->symtree
->n
.sym
->module
4246 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4247 eq
->expr
->symtree
->n
.sym
->module
) == 0
4248 && !check_unique_name (eq
->expr
->symtree
->name
))
4257 for (eq
= head
; eq
; eq
= head
)
4260 gfc_free_expr (eq
->expr
);
4266 gfc_current_ns
->equiv
= head
;
4277 in_load_equiv
= false;
4281 /* This function loads the sym_root of f2k_derived with the extensions to
4282 the derived type. */
4284 load_derived_extensions (void)
4287 gfc_symbol
*derived
;
4291 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4292 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4296 while (peek_atom () != ATOM_RPAREN
)
4299 mio_integer (&symbol
);
4300 info
= get_integer (symbol
);
4301 derived
= info
->u
.rsym
.sym
;
4303 /* This one is not being loaded. */
4304 if (!info
|| !derived
)
4306 while (peek_atom () != ATOM_RPAREN
)
4311 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4312 if (derived
->f2k_derived
== NULL
)
4313 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4315 while (peek_atom () != ATOM_RPAREN
)
4318 mio_internal_string (name
);
4319 mio_internal_string (module
);
4321 /* Only use one use name to find the symbol. */
4323 p
= find_use_name_n (name
, &j
, false);
4326 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4328 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4331 /* Only use the real name in f2k_derived to ensure a single
4333 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4346 /* Recursive function to traverse the pointer_info tree and load a
4347 needed symbol. We return nonzero if we load a symbol and stop the
4348 traversal, because the act of loading can alter the tree. */
4351 load_needed (pointer_info
*p
)
4362 rv
|= load_needed (p
->left
);
4363 rv
|= load_needed (p
->right
);
4365 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4368 p
->u
.rsym
.state
= USED
;
4370 set_module_locus (&p
->u
.rsym
.where
);
4372 sym
= p
->u
.rsym
.sym
;
4375 q
= get_integer (p
->u
.rsym
.ns
);
4377 ns
= (gfc_namespace
*) q
->u
.pointer
;
4380 /* Create an interface namespace if necessary. These are
4381 the namespaces that hold the formal parameters of module
4384 ns
= gfc_get_namespace (NULL
, 0);
4385 associate_integer_pointer (q
, ns
);
4388 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4389 doesn't go pear-shaped if the symbol is used. */
4391 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4394 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4395 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4396 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4397 if (p
->u
.rsym
.binding_label
)
4398 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4399 (p
->u
.rsym
.binding_label
));
4401 associate_integer_pointer (p
, sym
);
4405 sym
->attr
.use_assoc
= 1;
4407 /* Mark as only or rename for later diagnosis for explicitly imported
4408 but not used warnings; don't mark internal symbols such as __vtab,
4409 __def_init etc. Only mark them if they have been explicitly loaded. */
4411 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4415 /* Search the use/rename list for the variable; if the variable is
4417 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4419 if (strcmp (u
->use_name
, sym
->name
) == 0)
4421 sym
->attr
.use_only
= 1;
4427 if (p
->u
.rsym
.renamed
)
4428 sym
->attr
.use_rename
= 1;
4434 /* Recursive function for cleaning up things after a module has been read. */
4437 read_cleanup (pointer_info
*p
)
4445 read_cleanup (p
->left
);
4446 read_cleanup (p
->right
);
4448 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4451 /* Add hidden symbols to the symtree. */
4452 q
= get_integer (p
->u
.rsym
.ns
);
4453 ns
= (gfc_namespace
*) q
->u
.pointer
;
4455 if (!p
->u
.rsym
.sym
->attr
.vtype
4456 && !p
->u
.rsym
.sym
->attr
.vtab
)
4457 st
= gfc_get_unique_symtree (ns
);
4460 /* There is no reason to use 'unique_symtrees' for vtabs or
4461 vtypes - their name is fine for a symtree and reduces the
4462 namespace pollution. */
4463 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4465 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4468 st
->n
.sym
= p
->u
.rsym
.sym
;
4471 /* Fixup any symtree references. */
4472 p
->u
.rsym
.symtree
= st
;
4473 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4474 p
->u
.rsym
.stfixup
= NULL
;
4477 /* Free unused symbols. */
4478 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4479 gfc_free_symbol (p
->u
.rsym
.sym
);
4483 /* It is not quite enough to check for ambiguity in the symbols by
4484 the loaded symbol and the new symbol not being identical. */
4486 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4490 symbol_attribute attr
;
4492 if (gfc_current_ns
->proc_name
&& st_sym
->name
== gfc_current_ns
->proc_name
->name
)
4494 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4495 "current program unit", st_sym
->name
, module_name
);
4499 rsym
= info
->u
.rsym
.sym
;
4503 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4506 /* If the existing symbol is generic from a different module and
4507 the new symbol is generic there can be no ambiguity. */
4508 if (st_sym
->attr
.generic
4510 && st_sym
->module
!= module_name
)
4512 /* The new symbol's attributes have not yet been read. Since
4513 we need attr.generic, read it directly. */
4514 get_module_locus (&locus
);
4515 set_module_locus (&info
->u
.rsym
.where
);
4518 mio_symbol_attribute (&attr
);
4519 set_module_locus (&locus
);
4528 /* Read a module file. */
4533 module_locus operator_interfaces
, user_operators
, extensions
;
4535 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4537 int ambiguous
, j
, nuse
, symbol
;
4538 pointer_info
*info
, *q
;
4539 gfc_use_rename
*u
= NULL
;
4543 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4546 get_module_locus (&user_operators
);
4550 /* Skip commons, equivalences and derived type extensions for now. */
4554 get_module_locus (&extensions
);
4559 /* Create the fixup nodes for all the symbols. */
4561 while (peek_atom () != ATOM_RPAREN
)
4564 require_atom (ATOM_INTEGER
);
4565 info
= get_integer (atom_int
);
4567 info
->type
= P_SYMBOL
;
4568 info
->u
.rsym
.state
= UNUSED
;
4570 info
->u
.rsym
.true_name
= read_string ();
4571 info
->u
.rsym
.module
= read_string ();
4572 bind_label
= read_string ();
4573 if (strlen (bind_label
))
4574 info
->u
.rsym
.binding_label
= bind_label
;
4576 XDELETEVEC (bind_label
);
4578 require_atom (ATOM_INTEGER
);
4579 info
->u
.rsym
.ns
= atom_int
;
4581 get_module_locus (&info
->u
.rsym
.where
);
4583 /* See if the symbol has already been loaded by a previous module.
4584 If so, we reference the existing symbol and prevent it from
4585 being loaded again. This should not happen if the symbol being
4586 read is an index for an assumed shape dummy array (ns != 1). */
4588 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4591 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4597 info
->u
.rsym
.state
= USED
;
4598 info
->u
.rsym
.sym
= sym
;
4599 /* The current symbol has already been loaded, so we can avoid loading
4600 it again. However, if it is a derived type, some of its components
4601 can be used in expressions in the module. To avoid the module loading
4602 failing, we need to associate the module's component pointer indexes
4603 with the existing symbol's component pointers. */
4604 if (sym
->attr
.flavor
== FL_DERIVED
)
4608 /* First seek to the symbol's component list. */
4609 mio_lparen (); /* symbol opening. */
4610 skip_list (); /* skip symbol attribute. */
4612 mio_lparen (); /* component list opening. */
4613 for (c
= sym
->components
; c
; c
= c
->next
)
4616 const char *comp_name
;
4619 mio_lparen (); /* component opening. */
4621 p
= get_integer (n
);
4622 if (p
->u
.pointer
== NULL
)
4623 associate_integer_pointer (p
, c
);
4624 mio_pool_string (&comp_name
);
4625 gcc_assert (comp_name
== c
->name
);
4626 skip_list (1); /* component end. */
4628 mio_rparen (); /* component list closing. */
4630 skip_list (1); /* symbol end. */
4635 /* Some symbols do not have a namespace (eg. formal arguments),
4636 so the automatic "unique symtree" mechanism must be suppressed
4637 by marking them as referenced. */
4638 q
= get_integer (info
->u
.rsym
.ns
);
4639 if (q
->u
.pointer
== NULL
)
4641 info
->u
.rsym
.referenced
= 1;
4645 /* If possible recycle the symtree that references the symbol.
4646 If a symtree is not found and the module does not import one,
4647 a unique-name symtree is found by read_cleanup. */
4648 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4651 info
->u
.rsym
.symtree
= st
;
4652 info
->u
.rsym
.referenced
= 1;
4658 /* Parse the symtree lists. This lets us mark which symbols need to
4659 be loaded. Renaming is also done at this point by replacing the
4664 while (peek_atom () != ATOM_RPAREN
)
4666 mio_internal_string (name
);
4667 mio_integer (&ambiguous
);
4668 mio_integer (&symbol
);
4670 info
= get_integer (symbol
);
4672 /* See how many use names there are. If none, go through the start
4673 of the loop at least once. */
4674 nuse
= number_use_names (name
, false);
4675 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4680 for (j
= 1; j
<= nuse
; j
++)
4682 /* Get the jth local name for this symbol. */
4683 p
= find_use_name_n (name
, &j
, false);
4685 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4688 /* Exception: Always import vtabs & vtypes. */
4689 if (p
== NULL
&& name
[0] == '_'
4690 && (strncmp (name
, "__vtab_", 5) == 0
4691 || strncmp (name
, "__vtype_", 6) == 0))
4694 /* Skip symtree nodes not in an ONLY clause, unless there
4695 is an existing symtree loaded from another USE statement. */
4698 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4700 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
4701 && st
->n
.sym
->module
!= NULL
4702 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
4704 info
->u
.rsym
.symtree
= st
;
4705 info
->u
.rsym
.sym
= st
->n
.sym
;
4710 /* If a symbol of the same name and module exists already,
4711 this symbol, which is not in an ONLY clause, must not be
4712 added to the namespace(11.3.2). Note that find_symbol
4713 only returns the first occurrence that it finds. */
4714 if (!only_flag
&& !info
->u
.rsym
.renamed
4715 && strcmp (name
, module_name
) != 0
4716 && find_symbol (gfc_current_ns
->sym_root
, name
,
4720 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4724 /* Check for ambiguous symbols. */
4725 if (check_for_ambiguous (st
->n
.sym
, info
))
4728 info
->u
.rsym
.symtree
= st
;
4732 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4734 /* Create a symtree node in the current namespace for this
4736 st
= check_unique_name (p
)
4737 ? gfc_get_unique_symtree (gfc_current_ns
)
4738 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4739 st
->ambiguous
= ambiguous
;
4741 sym
= info
->u
.rsym
.sym
;
4743 /* Create a symbol node if it doesn't already exist. */
4746 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4748 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
4749 sym
= info
->u
.rsym
.sym
;
4750 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4752 if (info
->u
.rsym
.binding_label
)
4753 sym
->binding_label
=
4754 IDENTIFIER_POINTER (get_identifier
4755 (info
->u
.rsym
.binding_label
));
4761 if (strcmp (name
, p
) != 0)
4762 sym
->attr
.use_rename
= 1;
4765 || (strncmp (name
, "__vtab_", 5) != 0
4766 && strncmp (name
, "__vtype_", 6) != 0))
4767 sym
->attr
.use_only
= only_flag
;
4769 /* Store the symtree pointing to this symbol. */
4770 info
->u
.rsym
.symtree
= st
;
4772 if (info
->u
.rsym
.state
== UNUSED
)
4773 info
->u
.rsym
.state
= NEEDED
;
4774 info
->u
.rsym
.referenced
= 1;
4781 /* Load intrinsic operator interfaces. */
4782 set_module_locus (&operator_interfaces
);
4785 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4787 if (i
== INTRINSIC_USER
)
4792 u
= find_use_operator ((gfc_intrinsic_op
) i
);
4803 mio_interface (&gfc_current_ns
->op
[i
]);
4804 if (u
&& !gfc_current_ns
->op
[i
])
4810 /* Load generic and user operator interfaces. These must follow the
4811 loading of symtree because otherwise symbols can be marked as
4814 set_module_locus (&user_operators
);
4816 load_operator_interfaces ();
4817 load_generic_interfaces ();
4822 /* At this point, we read those symbols that are needed but haven't
4823 been loaded yet. If one symbol requires another, the other gets
4824 marked as NEEDED if its previous state was UNUSED. */
4826 while (load_needed (pi_root
));
4828 /* Make sure all elements of the rename-list were found in the module. */
4830 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4835 if (u
->op
== INTRINSIC_NONE
)
4837 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4838 u
->use_name
, &u
->where
, module_name
);
4842 if (u
->op
== INTRINSIC_USER
)
4844 gfc_error ("User operator '%s' referenced at %L not found "
4845 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4849 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4850 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4854 /* Now we should be in a position to fill f2k_derived with derived type
4855 extensions, since everything has been loaded. */
4856 set_module_locus (&extensions
);
4857 load_derived_extensions ();
4859 /* Clean up symbol nodes that were never loaded, create references
4860 to hidden symbols. */
4862 read_cleanup (pi_root
);
4866 /* Given an access type that is specific to an entity and the default
4867 access, return nonzero if the entity is publicly accessible. If the
4868 element is declared as PUBLIC, then it is public; if declared
4869 PRIVATE, then private, and otherwise it is public unless the default
4870 access in this context has been declared PRIVATE. */
4873 check_access (gfc_access specific_access
, gfc_access default_access
)
4875 if (specific_access
== ACCESS_PUBLIC
)
4877 if (specific_access
== ACCESS_PRIVATE
)
4880 if (gfc_option
.flag_module_private
)
4881 return default_access
== ACCESS_PUBLIC
;
4883 return default_access
!= ACCESS_PRIVATE
;
4888 gfc_check_symbol_access (gfc_symbol
*sym
)
4890 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
4893 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
4897 /* A structure to remember which commons we've already written. */
4899 struct written_common
4901 BBT_HEADER(written_common
);
4902 const char *name
, *label
;
4905 static struct written_common
*written_commons
= NULL
;
4907 /* Comparison function used for balancing the binary tree. */
4910 compare_written_commons (void *a1
, void *b1
)
4912 const char *aname
= ((struct written_common
*) a1
)->name
;
4913 const char *alabel
= ((struct written_common
*) a1
)->label
;
4914 const char *bname
= ((struct written_common
*) b1
)->name
;
4915 const char *blabel
= ((struct written_common
*) b1
)->label
;
4916 int c
= strcmp (aname
, bname
);
4918 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4921 /* Free a list of written commons. */
4924 free_written_common (struct written_common
*w
)
4930 free_written_common (w
->left
);
4932 free_written_common (w
->right
);
4937 /* Write a common block to the module -- recursive helper function. */
4940 write_common_0 (gfc_symtree
*st
, bool this_module
)
4946 struct written_common
*w
;
4947 bool write_me
= true;
4952 write_common_0 (st
->left
, this_module
);
4954 /* We will write out the binding label, or "" if no label given. */
4955 name
= st
->n
.common
->name
;
4957 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
4959 /* Check if we've already output this common. */
4960 w
= written_commons
;
4963 int c
= strcmp (name
, w
->name
);
4964 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4968 w
= (c
< 0) ? w
->left
: w
->right
;
4971 if (this_module
&& p
->use_assoc
)
4976 /* Write the common to the module. */
4978 mio_pool_string (&name
);
4980 mio_symbol_ref (&p
->head
);
4981 flags
= p
->saved
? 1 : 0;
4982 if (p
->threadprivate
)
4984 mio_integer (&flags
);
4986 /* Write out whether the common block is bind(c) or not. */
4987 mio_integer (&(p
->is_bind_c
));
4989 mio_pool_string (&label
);
4992 /* Record that we have written this common. */
4993 w
= XCNEW (struct written_common
);
4996 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4999 write_common_0 (st
->right
, this_module
);
5003 /* Write a common, by initializing the list of written commons, calling
5004 the recursive function write_common_0() and cleaning up afterwards. */
5007 write_common (gfc_symtree
*st
)
5009 written_commons
= NULL
;
5010 write_common_0 (st
, true);
5011 write_common_0 (st
, false);
5012 free_written_common (written_commons
);
5013 written_commons
= NULL
;
5017 /* Write the blank common block to the module. */
5020 write_blank_common (void)
5022 const char * name
= BLANK_COMMON_NAME
;
5024 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5025 this, but it hasn't been checked. Just making it so for now. */
5028 if (gfc_current_ns
->blank_common
.head
== NULL
)
5033 mio_pool_string (&name
);
5035 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5036 saved
= gfc_current_ns
->blank_common
.saved
;
5037 mio_integer (&saved
);
5039 /* Write out whether the common block is bind(c) or not. */
5040 mio_integer (&is_bind_c
);
5042 /* Write out an empty binding label. */
5043 write_atom (ATOM_STRING
, "");
5049 /* Write equivalences to the module. */
5058 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5062 for (e
= eq
; e
; e
= e
->eq
)
5064 if (e
->module
== NULL
)
5065 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5066 mio_allocated_string (e
->module
);
5067 mio_expr (&e
->expr
);
5076 /* Write derived type extensions to the module. */
5079 write_dt_extensions (gfc_symtree
*st
)
5081 if (!gfc_check_symbol_access (st
->n
.sym
))
5083 if (!(st
->n
.sym
->ns
&& st
->n
.sym
->ns
->proc_name
5084 && st
->n
.sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
5088 mio_pool_string (&st
->name
);
5089 if (st
->n
.sym
->module
!= NULL
)
5090 mio_pool_string (&st
->n
.sym
->module
);
5093 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5094 if (iomode
== IO_OUTPUT
)
5095 strcpy (name
, module_name
);
5096 mio_internal_string (name
);
5097 if (iomode
== IO_INPUT
)
5098 module_name
= gfc_get_string (name
);
5104 write_derived_extensions (gfc_symtree
*st
)
5106 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
5107 && (st
->n
.sym
->f2k_derived
!= NULL
)
5108 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
5112 mio_symbol_ref (&(st
->n
.sym
));
5113 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
5114 write_dt_extensions
);
5119 /* Write a symbol to the module. */
5122 write_symbol (int n
, gfc_symbol
*sym
)
5126 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5127 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
5131 if (sym
->attr
.flavor
== FL_DERIVED
)
5134 name
= dt_upper_string (sym
->name
);
5135 mio_pool_string (&name
);
5138 mio_pool_string (&sym
->name
);
5140 mio_pool_string (&sym
->module
);
5141 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5143 label
= sym
->binding_label
;
5144 mio_pool_string (&label
);
5147 write_atom (ATOM_STRING
, "");
5149 mio_pointer_ref (&sym
->ns
);
5156 /* Recursive traversal function to write the initial set of symbols to
5157 the module. We check to see if the symbol should be written
5158 according to the access specification. */
5161 write_symbol0 (gfc_symtree
*st
)
5165 bool dont_write
= false;
5170 write_symbol0 (st
->left
);
5173 if (sym
->module
== NULL
)
5174 sym
->module
= module_name
;
5176 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5177 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5180 if (!gfc_check_symbol_access (sym
))
5185 p
= get_pointer (sym
);
5186 if (p
->type
== P_UNKNOWN
)
5189 if (p
->u
.wsym
.state
!= WRITTEN
)
5191 write_symbol (p
->integer
, sym
);
5192 p
->u
.wsym
.state
= WRITTEN
;
5196 write_symbol0 (st
->right
);
5200 /* Type for the temporary tree used when writing secondary symbols. */
5202 struct sorted_pointer_info
5204 BBT_HEADER (sorted_pointer_info
);
5209 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5211 /* Recursively traverse the temporary tree, free its contents. */
5214 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5219 free_sorted_pointer_info_tree (p
->left
);
5220 free_sorted_pointer_info_tree (p
->right
);
5225 /* Comparison function for the temporary tree. */
5228 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5230 sorted_pointer_info
*spi1
, *spi2
;
5231 spi1
= (sorted_pointer_info
*)_spi1
;
5232 spi2
= (sorted_pointer_info
*)_spi2
;
5234 if (spi1
->p
->integer
< spi2
->p
->integer
)
5236 if (spi1
->p
->integer
> spi2
->p
->integer
)
5242 /* Finds the symbols that need to be written and collects them in the
5243 sorted_pi tree so that they can be traversed in an order
5244 independent of memory addresses. */
5247 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5252 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5254 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5257 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5260 find_symbols_to_write (tree
, p
->left
);
5261 find_symbols_to_write (tree
, p
->right
);
5265 /* Recursive function that traverses the tree of symbols that need to be
5266 written and writes them in order. */
5269 write_symbol1_recursion (sorted_pointer_info
*sp
)
5274 write_symbol1_recursion (sp
->left
);
5276 pointer_info
*p1
= sp
->p
;
5277 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5279 p1
->u
.wsym
.state
= WRITTEN
;
5280 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5281 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5283 write_symbol1_recursion (sp
->right
);
5287 /* Write the secondary set of symbols to the module file. These are
5288 symbols that were not public yet are needed by the public symbols
5289 or another dependent symbol. The act of writing a symbol can add
5290 symbols to the pointer_info tree, so we return nonzero if a symbol
5291 was written and pass that information upwards. The caller will
5292 then call this function again until nothing was written. It uses
5293 the utility functions and a temporary tree to ensure a reproducible
5294 ordering of the symbol output and thus the module file. */
5297 write_symbol1 (pointer_info
*p
)
5302 /* Put symbols that need to be written into a tree sorted on the
5305 sorted_pointer_info
*spi_root
= NULL
;
5306 find_symbols_to_write (&spi_root
, p
);
5308 /* No symbols to write, return. */
5312 /* Otherwise, write and free the tree again. */
5313 write_symbol1_recursion (spi_root
);
5314 free_sorted_pointer_info_tree (spi_root
);
5320 /* Write operator interfaces associated with a symbol. */
5323 write_operator (gfc_user_op
*uop
)
5325 static char nullstring
[] = "";
5326 const char *p
= nullstring
;
5328 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5331 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5335 /* Write generic interfaces from the namespace sym_root. */
5338 write_generic (gfc_symtree
*st
)
5345 write_generic (st
->left
);
5348 if (sym
&& !check_unique_name (st
->name
)
5349 && sym
->generic
&& gfc_check_symbol_access (sym
))
5352 sym
->module
= module_name
;
5354 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5357 write_generic (st
->right
);
5362 write_symtree (gfc_symtree
*st
)
5369 /* A symbol in an interface body must not be visible in the
5371 if (sym
->ns
!= gfc_current_ns
5372 && sym
->ns
->proc_name
5373 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5376 if (!gfc_check_symbol_access (sym
)
5377 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5378 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5381 if (check_unique_name (st
->name
))
5384 p
= find_pointer (sym
);
5386 gfc_internal_error ("write_symtree(): Symbol not written");
5388 mio_pool_string (&st
->name
);
5389 mio_integer (&st
->ambiguous
);
5390 mio_integer (&p
->integer
);
5399 /* Write the operator interfaces. */
5402 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5404 if (i
== INTRINSIC_USER
)
5407 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5408 gfc_current_ns
->default_access
)
5409 ? &gfc_current_ns
->op
[i
] : NULL
);
5417 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5423 write_generic (gfc_current_ns
->sym_root
);
5429 write_blank_common ();
5430 write_common (gfc_current_ns
->common_root
);
5442 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
5443 write_derived_extensions
);
5448 /* Write symbol information. First we traverse all symbols in the
5449 primary namespace, writing those that need to be written.
5450 Sometimes writing one symbol will cause another to need to be
5451 written. A list of these symbols ends up on the write stack, and
5452 we end by popping the bottom of the stack and writing the symbol
5453 until the stack is empty. */
5457 write_symbol0 (gfc_current_ns
->sym_root
);
5458 while (write_symbol1 (pi_root
))
5467 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5472 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5473 true on success, false on failure. */
5476 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5482 /* Open the file in binary mode. */
5483 if ((file
= fopen (filename
, "rb")) == NULL
)
5486 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5487 file. See RFC 1952. */
5488 if (fseek (file
, -8, SEEK_END
) != 0)
5494 /* Read the CRC32. */
5495 if (fread (buf
, 1, 4, file
) != 4)
5501 /* Close the file. */
5504 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
5505 + ((buf
[3] & 0xFF) << 24);
5508 /* For debugging, the CRC value printed in hexadecimal should match
5509 the CRC printed by "zcat -l -v filename".
5510 printf("CRC of file %s is %x\n", filename, val); */
5516 /* Given module, dump it to disk. If there was an error while
5517 processing the module, dump_flag will be set to zero and we delete
5518 the module file, even if it was already there. */
5521 gfc_dump_module (const char *name
, int dump_flag
)
5524 char *filename
, *filename_tmp
;
5527 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5528 if (gfc_option
.module_dir
!= NULL
)
5530 n
+= strlen (gfc_option
.module_dir
);
5531 filename
= (char *) alloca (n
);
5532 strcpy (filename
, gfc_option
.module_dir
);
5533 strcat (filename
, name
);
5537 filename
= (char *) alloca (n
);
5538 strcpy (filename
, name
);
5540 strcat (filename
, MODULE_EXTENSION
);
5542 /* Name of the temporary file used to write the module. */
5543 filename_tmp
= (char *) alloca (n
+ 1);
5544 strcpy (filename_tmp
, filename
);
5545 strcat (filename_tmp
, "0");
5547 /* There was an error while processing the module. We delete the
5548 module file, even if it was already there. */
5555 if (gfc_cpp_makedep ())
5556 gfc_cpp_add_target (filename
);
5558 /* Write the module to the temporary file. */
5559 module_fp
= gzopen (filename_tmp
, "w");
5560 if (module_fp
== NULL
)
5561 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5562 filename_tmp
, xstrerror (errno
));
5564 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
5565 MOD_VERSION
, gfc_source_file
);
5567 /* Write the module itself. */
5569 module_name
= gfc_get_string (name
);
5575 free_pi_tree (pi_root
);
5580 if (gzclose (module_fp
))
5581 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5582 filename_tmp
, xstrerror (errno
));
5584 /* Read the CRC32 from the gzip trailers of the module files and
5586 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
5587 || !read_crc32_from_module_file (filename
, &crc_old
)
5590 /* Module file have changed, replace the old one. */
5591 if (rename (filename_tmp
, filename
))
5592 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5593 filename_tmp
, filename
, xstrerror (errno
));
5597 if (unlink (filename_tmp
))
5598 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5599 filename_tmp
, xstrerror (errno
));
5605 create_intrinsic_function (const char *name
, int id
,
5606 const char *modname
, intmod_id module
,
5607 bool subroutine
, gfc_symbol
*result_type
)
5609 gfc_intrinsic_sym
*isym
;
5610 gfc_symtree
*tmp_symtree
;
5613 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5616 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5618 gfc_error ("Symbol '%s' already declared", name
);
5621 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5622 sym
= tmp_symtree
->n
.sym
;
5626 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5627 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
5628 sym
->attr
.subroutine
= 1;
5632 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5633 isym
= gfc_intrinsic_function_by_id (isym_id
);
5635 sym
->attr
.function
= 1;
5638 sym
->ts
.type
= BT_DERIVED
;
5639 sym
->ts
.u
.derived
= result_type
;
5640 sym
->ts
.is_c_interop
= 1;
5641 isym
->ts
.f90_type
= BT_VOID
;
5642 isym
->ts
.type
= BT_DERIVED
;
5643 isym
->ts
.f90_type
= BT_VOID
;
5644 isym
->ts
.u
.derived
= result_type
;
5645 isym
->ts
.is_c_interop
= 1;
5650 sym
->attr
.flavor
= FL_PROCEDURE
;
5651 sym
->attr
.intrinsic
= 1;
5653 sym
->module
= gfc_get_string (modname
);
5654 sym
->attr
.use_assoc
= 1;
5655 sym
->from_intmod
= module
;
5656 sym
->intmod_sym_id
= id
;
5660 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5661 the current namespace for all named constants, pointer types, and
5662 procedures in the module unless the only clause was used or a rename
5663 list was provided. */
5666 import_iso_c_binding_module (void)
5668 gfc_symbol
*mod_sym
= NULL
, *return_type
;
5669 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
5670 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
5671 const char *iso_c_module_name
= "__iso_c_binding";
5674 bool want_c_ptr
= false, want_c_funptr
= false;
5676 /* Look only in the current namespace. */
5677 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
5679 if (mod_symtree
== NULL
)
5681 /* symtree doesn't already exist in current namespace. */
5682 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
5685 if (mod_symtree
!= NULL
)
5686 mod_sym
= mod_symtree
->n
.sym
;
5688 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5689 "create symbol for %s", iso_c_module_name
);
5691 mod_sym
->attr
.flavor
= FL_MODULE
;
5692 mod_sym
->attr
.intrinsic
= 1;
5693 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
5694 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5697 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
5698 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
5700 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5702 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
5705 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
5708 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
5710 want_c_funptr
= true;
5711 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
5713 want_c_funptr
= true;
5714 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
5717 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
5718 (iso_c_binding_symbol
)
5720 u
->local_name
[0] ? u
->local_name
5724 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
5728 = generate_isocbinding_symbol (iso_c_module_name
,
5729 (iso_c_binding_symbol
)
5731 u
->local_name
[0] ? u
->local_name
5737 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
5738 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
5739 (iso_c_binding_symbol
)
5741 NULL
, NULL
, only_flag
);
5742 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
5743 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
5744 (iso_c_binding_symbol
)
5746 NULL
, NULL
, only_flag
);
5748 /* Generate the symbols for the named constants representing
5749 the kinds for intrinsic data types. */
5750 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
5753 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5754 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
5763 #define NAMED_FUNCTION(a,b,c,d) \
5765 not_in_std = (gfc_option.allow_std & d) == 0; \
5768 #define NAMED_SUBROUTINE(a,b,c,d) \
5770 not_in_std = (gfc_option.allow_std & d) == 0; \
5773 #define NAMED_INTCST(a,b,c,d) \
5775 not_in_std = (gfc_option.allow_std & d) == 0; \
5778 #define NAMED_REALCST(a,b,c,d) \
5780 not_in_std = (gfc_option.allow_std & d) == 0; \
5783 #define NAMED_CMPXCST(a,b,c,d) \
5785 not_in_std = (gfc_option.allow_std & d) == 0; \
5788 #include "iso-c-binding.def"
5796 gfc_error ("The symbol '%s', referenced at %L, is not "
5797 "in the selected standard", name
, &u
->where
);
5803 #define NAMED_FUNCTION(a,b,c,d) \
5805 if (a == ISOCBINDING_LOC) \
5806 return_type = c_ptr->n.sym; \
5807 else if (a == ISOCBINDING_FUNLOC) \
5808 return_type = c_funptr->n.sym; \
5810 return_type = NULL; \
5811 create_intrinsic_function (u->local_name[0] \
5812 ? u->local_name : u->use_name, \
5813 a, iso_c_module_name, \
5814 INTMOD_ISO_C_BINDING, false, \
5817 #define NAMED_SUBROUTINE(a,b,c,d) \
5819 create_intrinsic_function (u->local_name[0] ? u->local_name \
5821 a, iso_c_module_name, \
5822 INTMOD_ISO_C_BINDING, true, NULL); \
5824 #include "iso-c-binding.def"
5826 case ISOCBINDING_PTR
:
5827 case ISOCBINDING_FUNPTR
:
5828 /* Already handled above. */
5831 if (i
== ISOCBINDING_NULL_PTR
)
5832 tmp_symtree
= c_ptr
;
5833 else if (i
== ISOCBINDING_NULL_FUNPTR
)
5834 tmp_symtree
= c_funptr
;
5837 generate_isocbinding_symbol (iso_c_module_name
,
5838 (iso_c_binding_symbol
) i
,
5840 ? u
->local_name
: u
->use_name
,
5841 tmp_symtree
, false);
5845 if (!found
&& !only_flag
)
5847 /* Skip, if the symbol is not in the enabled standard. */
5850 #define NAMED_FUNCTION(a,b,c,d) \
5852 if ((gfc_option.allow_std & d) == 0) \
5855 #define NAMED_SUBROUTINE(a,b,c,d) \
5857 if ((gfc_option.allow_std & d) == 0) \
5860 #define NAMED_INTCST(a,b,c,d) \
5862 if ((gfc_option.allow_std & d) == 0) \
5865 #define NAMED_REALCST(a,b,c,d) \
5867 if ((gfc_option.allow_std & d) == 0) \
5870 #define NAMED_CMPXCST(a,b,c,d) \
5872 if ((gfc_option.allow_std & d) == 0) \
5875 #include "iso-c-binding.def"
5877 ; /* Not GFC_STD_* versioned. */
5882 #define NAMED_FUNCTION(a,b,c,d) \
5884 if (a == ISOCBINDING_LOC) \
5885 return_type = c_ptr->n.sym; \
5886 else if (a == ISOCBINDING_FUNLOC) \
5887 return_type = c_funptr->n.sym; \
5889 return_type = NULL; \
5890 create_intrinsic_function (b, a, iso_c_module_name, \
5891 INTMOD_ISO_C_BINDING, false, \
5894 #define NAMED_SUBROUTINE(a,b,c,d) \
5896 create_intrinsic_function (b, a, iso_c_module_name, \
5897 INTMOD_ISO_C_BINDING, true, NULL); \
5899 #include "iso-c-binding.def"
5901 case ISOCBINDING_PTR
:
5902 case ISOCBINDING_FUNPTR
:
5903 /* Already handled above. */
5906 if (i
== ISOCBINDING_NULL_PTR
)
5907 tmp_symtree
= c_ptr
;
5908 else if (i
== ISOCBINDING_NULL_FUNPTR
)
5909 tmp_symtree
= c_funptr
;
5912 generate_isocbinding_symbol (iso_c_module_name
,
5913 (iso_c_binding_symbol
) i
, NULL
,
5914 tmp_symtree
, false);
5919 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5924 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5925 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
5930 /* Add an integer named constant from a given module. */
5933 create_int_parameter (const char *name
, int value
, const char *modname
,
5934 intmod_id module
, int id
)
5936 gfc_symtree
*tmp_symtree
;
5939 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5940 if (tmp_symtree
!= NULL
)
5942 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5945 gfc_error ("Symbol '%s' already declared", name
);
5948 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5949 sym
= tmp_symtree
->n
.sym
;
5951 sym
->module
= gfc_get_string (modname
);
5952 sym
->attr
.flavor
= FL_PARAMETER
;
5953 sym
->ts
.type
= BT_INTEGER
;
5954 sym
->ts
.kind
= gfc_default_integer_kind
;
5955 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
5956 sym
->attr
.use_assoc
= 1;
5957 sym
->from_intmod
= module
;
5958 sym
->intmod_sym_id
= id
;
5962 /* Value is already contained by the array constructor, but not
5966 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
5967 const char *modname
, intmod_id module
, int id
)
5969 gfc_symtree
*tmp_symtree
;
5972 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5973 if (tmp_symtree
!= NULL
)
5975 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5978 gfc_error ("Symbol '%s' already declared", name
);
5981 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5982 sym
= tmp_symtree
->n
.sym
;
5984 sym
->module
= gfc_get_string (modname
);
5985 sym
->attr
.flavor
= FL_PARAMETER
;
5986 sym
->ts
.type
= BT_INTEGER
;
5987 sym
->ts
.kind
= gfc_default_integer_kind
;
5988 sym
->attr
.use_assoc
= 1;
5989 sym
->from_intmod
= module
;
5990 sym
->intmod_sym_id
= id
;
5991 sym
->attr
.dimension
= 1;
5992 sym
->as
= gfc_get_array_spec ();
5994 sym
->as
->type
= AS_EXPLICIT
;
5995 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5996 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
5999 sym
->value
->shape
= gfc_get_shape (1);
6000 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6004 /* Add an derived type for a given module. */
6007 create_derived_type (const char *name
, const char *modname
,
6008 intmod_id module
, int id
)
6010 gfc_symtree
*tmp_symtree
;
6011 gfc_symbol
*sym
, *dt_sym
;
6012 gfc_interface
*intr
, *head
;
6014 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6015 if (tmp_symtree
!= NULL
)
6017 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6020 gfc_error ("Symbol '%s' already declared", name
);
6023 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6024 sym
= tmp_symtree
->n
.sym
;
6025 sym
->module
= gfc_get_string (modname
);
6026 sym
->from_intmod
= module
;
6027 sym
->intmod_sym_id
= id
;
6028 sym
->attr
.flavor
= FL_PROCEDURE
;
6029 sym
->attr
.function
= 1;
6030 sym
->attr
.generic
= 1;
6032 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6033 gfc_current_ns
, &tmp_symtree
, false);
6034 dt_sym
= tmp_symtree
->n
.sym
;
6035 dt_sym
->name
= gfc_get_string (sym
->name
);
6036 dt_sym
->attr
.flavor
= FL_DERIVED
;
6037 dt_sym
->attr
.private_comp
= 1;
6038 dt_sym
->attr
.zero_comp
= 1;
6039 dt_sym
->attr
.use_assoc
= 1;
6040 dt_sym
->module
= gfc_get_string (modname
);
6041 dt_sym
->from_intmod
= module
;
6042 dt_sym
->intmod_sym_id
= id
;
6044 head
= sym
->generic
;
6045 intr
= gfc_get_interface ();
6047 intr
->where
= gfc_current_locus
;
6049 sym
->generic
= intr
;
6050 sym
->attr
.if_source
= IFSRC_DECL
;
6054 /* Read the contents of the module file into a temporary buffer. */
6057 read_module_to_tmpbuf ()
6059 /* We don't know the uncompressed size, so enlarge the buffer as
6065 module_content
= XNEWVEC (char, cursz
);
6069 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6074 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6075 rsize
= cursz
- len
;
6078 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6079 module_content
[len
] = '\0';
6085 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6088 use_iso_fortran_env_module (void)
6090 static char mod
[] = "iso_fortran_env";
6092 gfc_symbol
*mod_sym
;
6093 gfc_symtree
*mod_symtree
;
6097 intmod_sym symbol
[] = {
6098 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6099 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6100 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6101 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6102 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6103 #include "iso-fortran-env.def"
6104 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6107 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6108 #include "iso-fortran-env.def"
6110 /* Generate the symbol for the module itself. */
6111 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6112 if (mod_symtree
== NULL
)
6114 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6115 gcc_assert (mod_symtree
);
6116 mod_sym
= mod_symtree
->n
.sym
;
6118 mod_sym
->attr
.flavor
= FL_MODULE
;
6119 mod_sym
->attr
.intrinsic
= 1;
6120 mod_sym
->module
= gfc_get_string (mod
);
6121 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6124 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6125 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
6126 "non-intrinsic module name used previously", mod
);
6128 /* Generate the symbols for the module integer named constants. */
6130 for (i
= 0; symbol
[i
].name
; i
++)
6133 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6135 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6140 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
6141 "referenced at %L, is not in the selected "
6142 "standard", symbol
[i
].name
, &u
->where
))
6145 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6146 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6147 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
6148 "constant from intrinsic module "
6149 "ISO_FORTRAN_ENV at %L is incompatible with "
6150 "option %s", &u
->where
,
6151 gfc_option
.flag_default_integer
6152 ? "-fdefault-integer-8"
6153 : "-fdefault-real-8");
6154 switch (symbol
[i
].id
)
6156 #define NAMED_INTCST(a,b,c,d) \
6158 #include "iso-fortran-env.def"
6159 create_int_parameter (u
->local_name
[0] ? u
->local_name
6161 symbol
[i
].value
, mod
,
6162 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6165 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6167 expr = gfc_get_array_expr (BT_INTEGER, \
6168 gfc_default_integer_kind,\
6170 for (j = 0; KINDS[j].kind != 0; j++) \
6171 gfc_constructor_append_expr (&expr->value.constructor, \
6172 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6173 KINDS[j].kind), NULL); \
6174 create_int_parameter_array (u->local_name[0] ? u->local_name \
6177 INTMOD_ISO_FORTRAN_ENV, \
6180 #include "iso-fortran-env.def"
6182 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6184 #include "iso-fortran-env.def"
6185 create_derived_type (u
->local_name
[0] ? u
->local_name
6187 mod
, INTMOD_ISO_FORTRAN_ENV
,
6191 #define NAMED_FUNCTION(a,b,c,d) \
6193 #include "iso-fortran-env.def"
6194 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6197 INTMOD_ISO_FORTRAN_ENV
, false,
6207 if (!found
&& !only_flag
)
6209 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6212 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6213 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6214 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6215 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6216 "incompatible with option %s",
6217 gfc_option
.flag_default_integer
6218 ? "-fdefault-integer-8" : "-fdefault-real-8");
6220 switch (symbol
[i
].id
)
6222 #define NAMED_INTCST(a,b,c,d) \
6224 #include "iso-fortran-env.def"
6225 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6226 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6229 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6231 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6233 for (j = 0; KINDS[j].kind != 0; j++) \
6234 gfc_constructor_append_expr (&expr->value.constructor, \
6235 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6236 KINDS[j].kind), NULL); \
6237 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6238 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6240 #include "iso-fortran-env.def"
6242 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6244 #include "iso-fortran-env.def"
6245 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6249 #define NAMED_FUNCTION(a,b,c,d) \
6251 #include "iso-fortran-env.def"
6252 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6253 INTMOD_ISO_FORTRAN_ENV
, false,
6263 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6268 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6269 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6274 /* Process a USE directive. */
6277 gfc_use_module (gfc_use_list
*module
)
6282 gfc_symtree
*mod_symtree
;
6283 gfc_use_list
*use_stmt
;
6284 locus old_locus
= gfc_current_locus
;
6286 gfc_current_locus
= module
->where
;
6287 module_name
= module
->module_name
;
6288 gfc_rename_list
= module
->rename
;
6289 only_flag
= module
->only_flag
;
6291 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6293 strcpy (filename
, module_name
);
6294 strcat (filename
, MODULE_EXTENSION
);
6296 /* First, try to find an non-intrinsic module, unless the USE statement
6297 specified that the module is intrinsic. */
6299 if (!module
->intrinsic
)
6300 module_fp
= gzopen_included_file (filename
, true, true);
6302 /* Then, see if it's an intrinsic one, unless the USE statement
6303 specified that the module is non-intrinsic. */
6304 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6306 if (strcmp (module_name
, "iso_fortran_env") == 0
6307 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6308 "intrinsic module at %C"))
6310 use_iso_fortran_env_module ();
6311 free_rename (module
->rename
);
6312 module
->rename
= NULL
;
6313 gfc_current_locus
= old_locus
;
6314 module
->intrinsic
= true;
6318 if (strcmp (module_name
, "iso_c_binding") == 0
6319 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6321 import_iso_c_binding_module();
6322 free_rename (module
->rename
);
6323 module
->rename
= NULL
;
6324 gfc_current_locus
= old_locus
;
6325 module
->intrinsic
= true;
6329 module_fp
= gzopen_intrinsic_module (filename
);
6331 if (module_fp
== NULL
&& module
->intrinsic
)
6332 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6336 if (module_fp
== NULL
)
6337 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6338 filename
, xstrerror (errno
));
6340 /* Check that we haven't already USEd an intrinsic module with the
6343 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6344 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6345 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6346 "intrinsic module name used previously", module_name
);
6353 read_module_to_tmpbuf ();
6354 gzclose (module_fp
);
6356 /* Skip the first line of the module, after checking that this is
6357 a gfortran module file. */
6363 bad_module ("Unexpected end of module");
6366 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6367 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6368 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6369 " module file", filename
);
6372 if (strcmp (atom_name
, " version") != 0
6373 || module_char () != ' '
6374 || parse_atom () != ATOM_STRING
6375 || strcmp (atom_string
, MOD_VERSION
))
6376 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6377 " because it was created by a different"
6378 " version of GNU Fortran", filename
);
6387 /* Make sure we're not reading the same module that we may be building. */
6388 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6389 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6390 gfc_fatal_error ("Can't USE the same module we're building!");
6393 init_true_name_tree ();
6397 free_true_name (true_name_root
);
6398 true_name_root
= NULL
;
6400 free_pi_tree (pi_root
);
6403 XDELETEVEC (module_content
);
6404 module_content
= NULL
;
6406 use_stmt
= gfc_get_use_list ();
6407 *use_stmt
= *module
;
6408 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6409 gfc_current_ns
->use_stmts
= use_stmt
;
6411 gfc_current_locus
= old_locus
;
6415 /* Remove duplicated intrinsic operators from the rename list. */
6418 rename_list_remove_duplicate (gfc_use_rename
*list
)
6420 gfc_use_rename
*seek
, *last
;
6422 for (; list
; list
= list
->next
)
6423 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6426 for (seek
= list
->next
; seek
; seek
= last
->next
)
6428 if (list
->op
== seek
->op
)
6430 last
->next
= seek
->next
;
6440 /* Process all USE directives. */
6443 gfc_use_modules (void)
6445 gfc_use_list
*next
, *seek
, *last
;
6447 for (next
= module_list
; next
; next
= next
->next
)
6449 bool non_intrinsic
= next
->non_intrinsic
;
6450 bool intrinsic
= next
->intrinsic
;
6451 bool neither
= !non_intrinsic
&& !intrinsic
;
6453 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6455 if (next
->module_name
!= seek
->module_name
)
6458 if (seek
->non_intrinsic
)
6459 non_intrinsic
= true;
6460 else if (seek
->intrinsic
)
6466 if (intrinsic
&& neither
&& !non_intrinsic
)
6471 filename
= XALLOCAVEC (char,
6472 strlen (next
->module_name
)
6473 + strlen (MODULE_EXTENSION
) + 1);
6474 strcpy (filename
, next
->module_name
);
6475 strcat (filename
, MODULE_EXTENSION
);
6476 fp
= gfc_open_included_file (filename
, true, true);
6479 non_intrinsic
= true;
6485 for (seek
= next
->next
; seek
; seek
= last
->next
)
6487 if (next
->module_name
!= seek
->module_name
)
6493 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6494 || (next
->intrinsic
&& seek
->intrinsic
)
6497 if (!seek
->only_flag
)
6498 next
->only_flag
= false;
6501 gfc_use_rename
*r
= seek
->rename
;
6504 r
->next
= next
->rename
;
6505 next
->rename
= seek
->rename
;
6507 last
->next
= seek
->next
;
6515 for (; module_list
; module_list
= next
)
6517 next
= module_list
->next
;
6518 rename_list_remove_duplicate (module_list
->rename
);
6519 gfc_use_module (module_list
);
6522 gfc_rename_list
= NULL
;
6527 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6530 for (; use_stmts
; use_stmts
= next
)
6532 gfc_use_rename
*next_rename
;
6534 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6536 next_rename
= use_stmts
->rename
->next
;
6537 free (use_stmts
->rename
);
6539 next
= use_stmts
->next
;
6546 gfc_module_init_2 (void)
6548 last_atom
= ATOM_LPAREN
;
6549 gfc_rename_list
= NULL
;
6555 gfc_module_done_2 (void)
6557 free_rename (gfc_rename_list
);
6558 gfc_rename_list
= NULL
;