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 "13"
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
, AB_OMP_DECLARE_TARGET
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
),
1935 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET
),
1939 /* For binding attributes. */
1940 static const mstring binding_passing
[] =
1943 minit ("NOPASS", 1),
1946 static const mstring binding_overriding
[] =
1948 minit ("OVERRIDABLE", 0),
1949 minit ("NON_OVERRIDABLE", 1),
1950 minit ("DEFERRED", 2),
1953 static const mstring binding_generic
[] =
1955 minit ("SPECIFIC", 0),
1956 minit ("GENERIC", 1),
1959 static const mstring binding_ppc
[] =
1961 minit ("NO_PPC", 0),
1966 /* Specialization of mio_name. */
1967 DECL_MIO_NAME (ab_attribute
)
1968 DECL_MIO_NAME (ar_type
)
1969 DECL_MIO_NAME (array_type
)
1971 DECL_MIO_NAME (expr_t
)
1972 DECL_MIO_NAME (gfc_access
)
1973 DECL_MIO_NAME (gfc_intrinsic_op
)
1974 DECL_MIO_NAME (ifsrc
)
1975 DECL_MIO_NAME (save_state
)
1976 DECL_MIO_NAME (procedure_type
)
1977 DECL_MIO_NAME (ref_type
)
1978 DECL_MIO_NAME (sym_flavor
)
1979 DECL_MIO_NAME (sym_intent
)
1980 #undef DECL_MIO_NAME
1982 /* Symbol attributes are stored in list with the first three elements
1983 being the enumerated fields, while the remaining elements (if any)
1984 indicate the individual attribute bits. The access field is not
1985 saved-- it controls what symbols are exported when a module is
1989 mio_symbol_attribute (symbol_attribute
*attr
)
1992 unsigned ext_attr
,extension_level
;
1996 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1997 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1998 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1999 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
2000 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
2002 ext_attr
= attr
->ext_attr
;
2003 mio_integer ((int *) &ext_attr
);
2004 attr
->ext_attr
= ext_attr
;
2006 extension_level
= attr
->extension
;
2007 mio_integer ((int *) &extension_level
);
2008 attr
->extension
= extension_level
;
2010 if (iomode
== IO_OUTPUT
)
2012 if (attr
->allocatable
)
2013 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
2014 if (attr
->artificial
)
2015 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
2016 if (attr
->asynchronous
)
2017 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
2018 if (attr
->dimension
)
2019 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
2020 if (attr
->codimension
)
2021 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
2022 if (attr
->contiguous
)
2023 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
2025 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
2026 if (attr
->intrinsic
)
2027 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
2029 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
2031 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
2032 if (attr
->class_pointer
)
2033 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
2034 if (attr
->is_protected
)
2035 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2037 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2038 if (attr
->volatile_
)
2039 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2041 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2042 if (attr
->threadprivate
)
2043 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2045 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2047 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2048 /* We deliberately don't preserve the "entry" flag. */
2051 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2052 if (attr
->in_namelist
)
2053 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2054 if (attr
->in_common
)
2055 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2058 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2059 if (attr
->subroutine
)
2060 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2062 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2064 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2067 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2068 if (attr
->elemental
)
2069 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2071 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2072 if (attr
->implicit_pure
)
2073 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2074 if (attr
->unlimited_polymorphic
)
2075 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2076 if (attr
->recursive
)
2077 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2078 if (attr
->always_explicit
)
2079 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2080 if (attr
->cray_pointer
)
2081 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2082 if (attr
->cray_pointee
)
2083 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2084 if (attr
->is_bind_c
)
2085 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2086 if (attr
->is_c_interop
)
2087 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2089 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2090 if (attr
->alloc_comp
)
2091 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2092 if (attr
->pointer_comp
)
2093 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2094 if (attr
->proc_pointer_comp
)
2095 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2096 if (attr
->private_comp
)
2097 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2098 if (attr
->coarray_comp
)
2099 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2100 if (attr
->lock_comp
)
2101 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2102 if (attr
->zero_comp
)
2103 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2105 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2106 if (attr
->procedure
)
2107 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2108 if (attr
->proc_pointer
)
2109 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2111 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2113 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2114 if (attr
->omp_declare_target
)
2115 MIO_NAME (ab_attribute
) (AB_OMP_DECLARE_TARGET
, attr_bits
);
2125 if (t
== ATOM_RPAREN
)
2128 bad_module ("Expected attribute bit name");
2130 switch ((ab_attribute
) find_enum (attr_bits
))
2132 case AB_ALLOCATABLE
:
2133 attr
->allocatable
= 1;
2136 attr
->artificial
= 1;
2138 case AB_ASYNCHRONOUS
:
2139 attr
->asynchronous
= 1;
2142 attr
->dimension
= 1;
2144 case AB_CODIMENSION
:
2145 attr
->codimension
= 1;
2148 attr
->contiguous
= 1;
2154 attr
->intrinsic
= 1;
2162 case AB_CLASS_POINTER
:
2163 attr
->class_pointer
= 1;
2166 attr
->is_protected
= 1;
2172 attr
->volatile_
= 1;
2177 case AB_THREADPRIVATE
:
2178 attr
->threadprivate
= 1;
2189 case AB_IN_NAMELIST
:
2190 attr
->in_namelist
= 1;
2193 attr
->in_common
= 1;
2199 attr
->subroutine
= 1;
2211 attr
->elemental
= 1;
2216 case AB_IMPLICIT_PURE
:
2217 attr
->implicit_pure
= 1;
2219 case AB_UNLIMITED_POLY
:
2220 attr
->unlimited_polymorphic
= 1;
2223 attr
->recursive
= 1;
2225 case AB_ALWAYS_EXPLICIT
:
2226 attr
->always_explicit
= 1;
2228 case AB_CRAY_POINTER
:
2229 attr
->cray_pointer
= 1;
2231 case AB_CRAY_POINTEE
:
2232 attr
->cray_pointee
= 1;
2235 attr
->is_bind_c
= 1;
2237 case AB_IS_C_INTEROP
:
2238 attr
->is_c_interop
= 1;
2244 attr
->alloc_comp
= 1;
2246 case AB_COARRAY_COMP
:
2247 attr
->coarray_comp
= 1;
2250 attr
->lock_comp
= 1;
2252 case AB_POINTER_COMP
:
2253 attr
->pointer_comp
= 1;
2255 case AB_PROC_POINTER_COMP
:
2256 attr
->proc_pointer_comp
= 1;
2258 case AB_PRIVATE_COMP
:
2259 attr
->private_comp
= 1;
2262 attr
->zero_comp
= 1;
2268 attr
->procedure
= 1;
2270 case AB_PROC_POINTER
:
2271 attr
->proc_pointer
= 1;
2279 case AB_OMP_DECLARE_TARGET
:
2280 attr
->omp_declare_target
= 1;
2288 static const mstring bt_types
[] = {
2289 minit ("INTEGER", BT_INTEGER
),
2290 minit ("REAL", BT_REAL
),
2291 minit ("COMPLEX", BT_COMPLEX
),
2292 minit ("LOGICAL", BT_LOGICAL
),
2293 minit ("CHARACTER", BT_CHARACTER
),
2294 minit ("DERIVED", BT_DERIVED
),
2295 minit ("CLASS", BT_CLASS
),
2296 minit ("PROCEDURE", BT_PROCEDURE
),
2297 minit ("UNKNOWN", BT_UNKNOWN
),
2298 minit ("VOID", BT_VOID
),
2299 minit ("ASSUMED", BT_ASSUMED
),
2305 mio_charlen (gfc_charlen
**clp
)
2311 if (iomode
== IO_OUTPUT
)
2315 mio_expr (&cl
->length
);
2319 if (peek_atom () != ATOM_RPAREN
)
2321 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2322 mio_expr (&cl
->length
);
2331 /* See if a name is a generated name. */
2334 check_unique_name (const char *name
)
2336 return *name
== '@';
2341 mio_typespec (gfc_typespec
*ts
)
2345 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2347 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2348 mio_integer (&ts
->kind
);
2350 mio_symbol_ref (&ts
->u
.derived
);
2352 mio_symbol_ref (&ts
->interface
);
2354 /* Add info for C interop and is_iso_c. */
2355 mio_integer (&ts
->is_c_interop
);
2356 mio_integer (&ts
->is_iso_c
);
2358 /* If the typespec is for an identifier either from iso_c_binding, or
2359 a constant that was initialized to an identifier from it, use the
2360 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2362 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2364 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2366 if (ts
->type
!= BT_CHARACTER
)
2368 /* ts->u.cl is only valid for BT_CHARACTER. */
2373 mio_charlen (&ts
->u
.cl
);
2375 /* So as not to disturb the existing API, use an ATOM_NAME to
2376 transmit deferred characteristic for characters (F2003). */
2377 if (iomode
== IO_OUTPUT
)
2379 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2380 write_atom (ATOM_NAME
, "DEFERRED_CL");
2382 else if (peek_atom () != ATOM_RPAREN
)
2384 if (parse_atom () != ATOM_NAME
)
2385 bad_module ("Expected string");
2393 static const mstring array_spec_types
[] = {
2394 minit ("EXPLICIT", AS_EXPLICIT
),
2395 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2396 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2397 minit ("DEFERRED", AS_DEFERRED
),
2398 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2404 mio_array_spec (gfc_array_spec
**asp
)
2411 if (iomode
== IO_OUTPUT
)
2419 /* mio_integer expects nonnegative values. */
2420 rank
= as
->rank
> 0 ? as
->rank
: 0;
2421 mio_integer (&rank
);
2425 if (peek_atom () == ATOM_RPAREN
)
2431 *asp
= as
= gfc_get_array_spec ();
2432 mio_integer (&as
->rank
);
2435 mio_integer (&as
->corank
);
2436 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2438 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2440 if (iomode
== IO_INPUT
&& as
->corank
)
2441 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2443 if (as
->rank
+ as
->corank
> 0)
2444 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2446 mio_expr (&as
->lower
[i
]);
2447 mio_expr (&as
->upper
[i
]);
2455 /* Given a pointer to an array reference structure (which lives in a
2456 gfc_ref structure), find the corresponding array specification
2457 structure. Storing the pointer in the ref structure doesn't quite
2458 work when loading from a module. Generating code for an array
2459 reference also needs more information than just the array spec. */
2461 static const mstring array_ref_types
[] = {
2462 minit ("FULL", AR_FULL
),
2463 minit ("ELEMENT", AR_ELEMENT
),
2464 minit ("SECTION", AR_SECTION
),
2470 mio_array_ref (gfc_array_ref
*ar
)
2475 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2476 mio_integer (&ar
->dimen
);
2484 for (i
= 0; i
< ar
->dimen
; i
++)
2485 mio_expr (&ar
->start
[i
]);
2490 for (i
= 0; i
< ar
->dimen
; i
++)
2492 mio_expr (&ar
->start
[i
]);
2493 mio_expr (&ar
->end
[i
]);
2494 mio_expr (&ar
->stride
[i
]);
2500 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2503 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2504 we can't call mio_integer directly. Instead loop over each element
2505 and cast it to/from an integer. */
2506 if (iomode
== IO_OUTPUT
)
2508 for (i
= 0; i
< ar
->dimen
; i
++)
2510 int tmp
= (int)ar
->dimen_type
[i
];
2511 write_atom (ATOM_INTEGER
, &tmp
);
2516 for (i
= 0; i
< ar
->dimen
; i
++)
2518 require_atom (ATOM_INTEGER
);
2519 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2523 if (iomode
== IO_INPUT
)
2525 ar
->where
= gfc_current_locus
;
2527 for (i
= 0; i
< ar
->dimen
; i
++)
2528 ar
->c_where
[i
] = gfc_current_locus
;
2535 /* Saves or restores a pointer. The pointer is converted back and
2536 forth from an integer. We return the pointer_info pointer so that
2537 the caller can take additional action based on the pointer type. */
2539 static pointer_info
*
2540 mio_pointer_ref (void *gp
)
2544 if (iomode
== IO_OUTPUT
)
2546 p
= get_pointer (*((char **) gp
));
2547 write_atom (ATOM_INTEGER
, &p
->integer
);
2551 require_atom (ATOM_INTEGER
);
2552 p
= add_fixup (atom_int
, gp
);
2559 /* Save and load references to components that occur within
2560 expressions. We have to describe these references by a number and
2561 by name. The number is necessary for forward references during
2562 reading, and the name is necessary if the symbol already exists in
2563 the namespace and is not loaded again. */
2566 mio_component_ref (gfc_component
**cp
)
2570 p
= mio_pointer_ref (cp
);
2571 if (p
->type
== P_UNKNOWN
)
2572 p
->type
= P_COMPONENT
;
2576 static void mio_namespace_ref (gfc_namespace
**nsp
);
2577 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2578 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2581 mio_component (gfc_component
*c
, int vtype
)
2588 if (iomode
== IO_OUTPUT
)
2590 p
= get_pointer (c
);
2591 mio_integer (&p
->integer
);
2596 p
= get_integer (n
);
2597 associate_integer_pointer (p
, c
);
2600 if (p
->type
== P_UNKNOWN
)
2601 p
->type
= P_COMPONENT
;
2603 mio_pool_string (&c
->name
);
2604 mio_typespec (&c
->ts
);
2605 mio_array_spec (&c
->as
);
2607 mio_symbol_attribute (&c
->attr
);
2608 if (c
->ts
.type
== BT_CLASS
)
2609 c
->attr
.class_ok
= 1;
2610 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2612 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2613 || strcmp (c
->name
, "_hash") == 0)
2614 mio_expr (&c
->initializer
);
2616 if (c
->attr
.proc_pointer
)
2617 mio_typebound_proc (&c
->tb
);
2624 mio_component_list (gfc_component
**cp
, int vtype
)
2626 gfc_component
*c
, *tail
;
2630 if (iomode
== IO_OUTPUT
)
2632 for (c
= *cp
; c
; c
= c
->next
)
2633 mio_component (c
, vtype
);
2642 if (peek_atom () == ATOM_RPAREN
)
2645 c
= gfc_get_component ();
2646 mio_component (c
, vtype
);
2662 mio_actual_arg (gfc_actual_arglist
*a
)
2665 mio_pool_string (&a
->name
);
2666 mio_expr (&a
->expr
);
2672 mio_actual_arglist (gfc_actual_arglist
**ap
)
2674 gfc_actual_arglist
*a
, *tail
;
2678 if (iomode
== IO_OUTPUT
)
2680 for (a
= *ap
; a
; a
= a
->next
)
2690 if (peek_atom () != ATOM_LPAREN
)
2693 a
= gfc_get_actual_arglist ();
2709 /* Read and write formal argument lists. */
2712 mio_formal_arglist (gfc_formal_arglist
**formal
)
2714 gfc_formal_arglist
*f
, *tail
;
2718 if (iomode
== IO_OUTPUT
)
2720 for (f
= *formal
; f
; f
= f
->next
)
2721 mio_symbol_ref (&f
->sym
);
2725 *formal
= tail
= NULL
;
2727 while (peek_atom () != ATOM_RPAREN
)
2729 f
= gfc_get_formal_arglist ();
2730 mio_symbol_ref (&f
->sym
);
2732 if (*formal
== NULL
)
2745 /* Save or restore a reference to a symbol node. */
2748 mio_symbol_ref (gfc_symbol
**symp
)
2752 p
= mio_pointer_ref (symp
);
2753 if (p
->type
== P_UNKNOWN
)
2756 if (iomode
== IO_OUTPUT
)
2758 if (p
->u
.wsym
.state
== UNREFERENCED
)
2759 p
->u
.wsym
.state
= NEEDS_WRITE
;
2763 if (p
->u
.rsym
.state
== UNUSED
)
2764 p
->u
.rsym
.state
= NEEDED
;
2770 /* Save or restore a reference to a symtree node. */
2773 mio_symtree_ref (gfc_symtree
**stp
)
2778 if (iomode
== IO_OUTPUT
)
2779 mio_symbol_ref (&(*stp
)->n
.sym
);
2782 require_atom (ATOM_INTEGER
);
2783 p
= get_integer (atom_int
);
2785 /* An unused equivalence member; make a symbol and a symtree
2787 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2789 /* Since this is not used, it must have a unique name. */
2790 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2792 /* Make the symbol. */
2793 if (p
->u
.rsym
.sym
== NULL
)
2795 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2797 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2800 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2801 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2802 p
->u
.rsym
.referenced
= 1;
2804 /* If the symbol is PRIVATE and in COMMON, load_commons will
2805 generate a fixup symbol, which must be associated. */
2807 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2811 if (p
->type
== P_UNKNOWN
)
2814 if (p
->u
.rsym
.state
== UNUSED
)
2815 p
->u
.rsym
.state
= NEEDED
;
2817 if (p
->u
.rsym
.symtree
!= NULL
)
2819 *stp
= p
->u
.rsym
.symtree
;
2823 f
= XCNEW (fixup_t
);
2825 f
->next
= p
->u
.rsym
.stfixup
;
2826 p
->u
.rsym
.stfixup
= f
;
2828 f
->pointer
= (void **) stp
;
2835 mio_iterator (gfc_iterator
**ip
)
2841 if (iomode
== IO_OUTPUT
)
2848 if (peek_atom () == ATOM_RPAREN
)
2854 *ip
= gfc_get_iterator ();
2859 mio_expr (&iter
->var
);
2860 mio_expr (&iter
->start
);
2861 mio_expr (&iter
->end
);
2862 mio_expr (&iter
->step
);
2870 mio_constructor (gfc_constructor_base
*cp
)
2876 if (iomode
== IO_OUTPUT
)
2878 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2881 mio_expr (&c
->expr
);
2882 mio_iterator (&c
->iterator
);
2888 while (peek_atom () != ATOM_RPAREN
)
2890 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2893 mio_expr (&c
->expr
);
2894 mio_iterator (&c
->iterator
);
2903 static const mstring ref_types
[] = {
2904 minit ("ARRAY", REF_ARRAY
),
2905 minit ("COMPONENT", REF_COMPONENT
),
2906 minit ("SUBSTRING", REF_SUBSTRING
),
2912 mio_ref (gfc_ref
**rp
)
2919 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2924 mio_array_ref (&r
->u
.ar
);
2928 mio_symbol_ref (&r
->u
.c
.sym
);
2929 mio_component_ref (&r
->u
.c
.component
);
2933 mio_expr (&r
->u
.ss
.start
);
2934 mio_expr (&r
->u
.ss
.end
);
2935 mio_charlen (&r
->u
.ss
.length
);
2944 mio_ref_list (gfc_ref
**rp
)
2946 gfc_ref
*ref
, *head
, *tail
;
2950 if (iomode
== IO_OUTPUT
)
2952 for (ref
= *rp
; ref
; ref
= ref
->next
)
2959 while (peek_atom () != ATOM_RPAREN
)
2962 head
= tail
= gfc_get_ref ();
2965 tail
->next
= gfc_get_ref ();
2979 /* Read and write an integer value. */
2982 mio_gmp_integer (mpz_t
*integer
)
2986 if (iomode
== IO_INPUT
)
2988 if (parse_atom () != ATOM_STRING
)
2989 bad_module ("Expected integer string");
2991 mpz_init (*integer
);
2992 if (mpz_set_str (*integer
, atom_string
, 10))
2993 bad_module ("Error converting integer");
2999 p
= mpz_get_str (NULL
, 10, *integer
);
3000 write_atom (ATOM_STRING
, p
);
3007 mio_gmp_real (mpfr_t
*real
)
3012 if (iomode
== IO_INPUT
)
3014 if (parse_atom () != ATOM_STRING
)
3015 bad_module ("Expected real string");
3018 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3023 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3025 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3027 write_atom (ATOM_STRING
, p
);
3032 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3034 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3036 /* Fix negative numbers. */
3037 if (atom_string
[2] == '-')
3039 atom_string
[0] = '-';
3040 atom_string
[1] = '0';
3041 atom_string
[2] = '.';
3044 write_atom (ATOM_STRING
, atom_string
);
3052 /* Save and restore the shape of an array constructor. */
3055 mio_shape (mpz_t
**pshape
, int rank
)
3061 /* A NULL shape is represented by (). */
3064 if (iomode
== IO_OUTPUT
)
3076 if (t
== ATOM_RPAREN
)
3083 shape
= gfc_get_shape (rank
);
3087 for (n
= 0; n
< rank
; n
++)
3088 mio_gmp_integer (&shape
[n
]);
3094 static const mstring expr_types
[] = {
3095 minit ("OP", EXPR_OP
),
3096 minit ("FUNCTION", EXPR_FUNCTION
),
3097 minit ("CONSTANT", EXPR_CONSTANT
),
3098 minit ("VARIABLE", EXPR_VARIABLE
),
3099 minit ("SUBSTRING", EXPR_SUBSTRING
),
3100 minit ("STRUCTURE", EXPR_STRUCTURE
),
3101 minit ("ARRAY", EXPR_ARRAY
),
3102 minit ("NULL", EXPR_NULL
),
3103 minit ("COMPCALL", EXPR_COMPCALL
),
3107 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3108 generic operators, not in expressions. INTRINSIC_USER is also
3109 replaced by the correct function name by the time we see it. */
3111 static const mstring intrinsics
[] =
3113 minit ("UPLUS", INTRINSIC_UPLUS
),
3114 minit ("UMINUS", INTRINSIC_UMINUS
),
3115 minit ("PLUS", INTRINSIC_PLUS
),
3116 minit ("MINUS", INTRINSIC_MINUS
),
3117 minit ("TIMES", INTRINSIC_TIMES
),
3118 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3119 minit ("POWER", INTRINSIC_POWER
),
3120 minit ("CONCAT", INTRINSIC_CONCAT
),
3121 minit ("AND", INTRINSIC_AND
),
3122 minit ("OR", INTRINSIC_OR
),
3123 minit ("EQV", INTRINSIC_EQV
),
3124 minit ("NEQV", INTRINSIC_NEQV
),
3125 minit ("EQ_SIGN", INTRINSIC_EQ
),
3126 minit ("EQ", INTRINSIC_EQ_OS
),
3127 minit ("NE_SIGN", INTRINSIC_NE
),
3128 minit ("NE", INTRINSIC_NE_OS
),
3129 minit ("GT_SIGN", INTRINSIC_GT
),
3130 minit ("GT", INTRINSIC_GT_OS
),
3131 minit ("GE_SIGN", INTRINSIC_GE
),
3132 minit ("GE", INTRINSIC_GE_OS
),
3133 minit ("LT_SIGN", INTRINSIC_LT
),
3134 minit ("LT", INTRINSIC_LT_OS
),
3135 minit ("LE_SIGN", INTRINSIC_LE
),
3136 minit ("LE", INTRINSIC_LE_OS
),
3137 minit ("NOT", INTRINSIC_NOT
),
3138 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3143 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3146 fix_mio_expr (gfc_expr
*e
)
3148 gfc_symtree
*ns_st
= NULL
;
3151 if (iomode
!= IO_OUTPUT
)
3156 /* If this is a symtree for a symbol that came from a contained module
3157 namespace, it has a unique name and we should look in the current
3158 namespace to see if the required, non-contained symbol is available
3159 yet. If so, the latter should be written. */
3160 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3162 const char *name
= e
->symtree
->n
.sym
->name
;
3163 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3164 name
= dt_upper_string (name
);
3165 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3168 /* On the other hand, if the existing symbol is the module name or the
3169 new symbol is a dummy argument, do not do the promotion. */
3170 if (ns_st
&& ns_st
->n
.sym
3171 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3172 && !e
->symtree
->n
.sym
->attr
.dummy
)
3175 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
3179 /* In some circumstances, a function used in an initialization
3180 expression, in one use associated module, can fail to be
3181 coupled to its symtree when used in a specification
3182 expression in another module. */
3183 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3184 : e
->value
.function
.isym
->name
;
3185 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3190 /* This is probably a reference to a private procedure from another
3191 module. To prevent a segfault, make a generic with no specific
3192 instances. If this module is used, without the required
3193 specific coming from somewhere, the appropriate error message
3195 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3196 sym
->attr
.flavor
= FL_PROCEDURE
;
3197 sym
->attr
.generic
= 1;
3198 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3199 gfc_commit_symbol (sym
);
3204 /* Read and write expressions. The form "()" is allowed to indicate a
3208 mio_expr (gfc_expr
**ep
)
3216 if (iomode
== IO_OUTPUT
)
3225 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3230 if (t
== ATOM_RPAREN
)
3237 bad_module ("Expected expression type");
3239 e
= *ep
= gfc_get_expr ();
3240 e
->where
= gfc_current_locus
;
3241 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3244 mio_typespec (&e
->ts
);
3245 mio_integer (&e
->rank
);
3249 switch (e
->expr_type
)
3253 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3255 switch (e
->value
.op
.op
)
3257 case INTRINSIC_UPLUS
:
3258 case INTRINSIC_UMINUS
:
3260 case INTRINSIC_PARENTHESES
:
3261 mio_expr (&e
->value
.op
.op1
);
3264 case INTRINSIC_PLUS
:
3265 case INTRINSIC_MINUS
:
3266 case INTRINSIC_TIMES
:
3267 case INTRINSIC_DIVIDE
:
3268 case INTRINSIC_POWER
:
3269 case INTRINSIC_CONCAT
:
3273 case INTRINSIC_NEQV
:
3275 case INTRINSIC_EQ_OS
:
3277 case INTRINSIC_NE_OS
:
3279 case INTRINSIC_GT_OS
:
3281 case INTRINSIC_GE_OS
:
3283 case INTRINSIC_LT_OS
:
3285 case INTRINSIC_LE_OS
:
3286 mio_expr (&e
->value
.op
.op1
);
3287 mio_expr (&e
->value
.op
.op2
);
3291 bad_module ("Bad operator");
3297 mio_symtree_ref (&e
->symtree
);
3298 mio_actual_arglist (&e
->value
.function
.actual
);
3300 if (iomode
== IO_OUTPUT
)
3302 e
->value
.function
.name
3303 = mio_allocated_string (e
->value
.function
.name
);
3304 if (e
->value
.function
.esym
)
3310 mio_integer (&flag
);
3314 mio_symbol_ref (&e
->value
.function
.esym
);
3317 mio_ref_list (&e
->ref
);
3320 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3325 require_atom (ATOM_STRING
);
3326 e
->value
.function
.name
= gfc_get_string (atom_string
);
3329 mio_integer (&flag
);
3333 mio_symbol_ref (&e
->value
.function
.esym
);
3336 mio_ref_list (&e
->ref
);
3339 require_atom (ATOM_STRING
);
3340 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3348 mio_symtree_ref (&e
->symtree
);
3349 mio_ref_list (&e
->ref
);
3352 case EXPR_SUBSTRING
:
3353 e
->value
.character
.string
3354 = CONST_CAST (gfc_char_t
*,
3355 mio_allocated_wide_string (e
->value
.character
.string
,
3356 e
->value
.character
.length
));
3357 mio_ref_list (&e
->ref
);
3360 case EXPR_STRUCTURE
:
3362 mio_constructor (&e
->value
.constructor
);
3363 mio_shape (&e
->shape
, e
->rank
);
3370 mio_gmp_integer (&e
->value
.integer
);
3374 gfc_set_model_kind (e
->ts
.kind
);
3375 mio_gmp_real (&e
->value
.real
);
3379 gfc_set_model_kind (e
->ts
.kind
);
3380 mio_gmp_real (&mpc_realref (e
->value
.complex));
3381 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3385 mio_integer (&e
->value
.logical
);
3389 mio_integer (&e
->value
.character
.length
);
3390 e
->value
.character
.string
3391 = CONST_CAST (gfc_char_t
*,
3392 mio_allocated_wide_string (e
->value
.character
.string
,
3393 e
->value
.character
.length
));
3397 bad_module ("Bad type in constant expression");
3415 /* Read and write namelists. */
3418 mio_namelist (gfc_symbol
*sym
)
3420 gfc_namelist
*n
, *m
;
3421 const char *check_name
;
3425 if (iomode
== IO_OUTPUT
)
3427 for (n
= sym
->namelist
; n
; n
= n
->next
)
3428 mio_symbol_ref (&n
->sym
);
3432 /* This departure from the standard is flagged as an error.
3433 It does, in fact, work correctly. TODO: Allow it
3435 if (sym
->attr
.flavor
== FL_NAMELIST
)
3437 check_name
= find_use_name (sym
->name
, false);
3438 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3439 gfc_error ("Namelist %s cannot be renamed by USE "
3440 "association to %s", sym
->name
, check_name
);
3444 while (peek_atom () != ATOM_RPAREN
)
3446 n
= gfc_get_namelist ();
3447 mio_symbol_ref (&n
->sym
);
3449 if (sym
->namelist
== NULL
)
3456 sym
->namelist_tail
= m
;
3463 /* Save/restore lists of gfc_interface structures. When loading an
3464 interface, we are really appending to the existing list of
3465 interfaces. Checking for duplicate and ambiguous interfaces has to
3466 be done later when all symbols have been loaded. */
3469 mio_interface_rest (gfc_interface
**ip
)
3471 gfc_interface
*tail
, *p
;
3472 pointer_info
*pi
= NULL
;
3474 if (iomode
== IO_OUTPUT
)
3477 for (p
= *ip
; p
; p
= p
->next
)
3478 mio_symbol_ref (&p
->sym
);
3493 if (peek_atom () == ATOM_RPAREN
)
3496 p
= gfc_get_interface ();
3497 p
->where
= gfc_current_locus
;
3498 pi
= mio_symbol_ref (&p
->sym
);
3514 /* Save/restore a nameless operator interface. */
3517 mio_interface (gfc_interface
**ip
)
3520 mio_interface_rest (ip
);
3524 /* Save/restore a named operator interface. */
3527 mio_symbol_interface (const char **name
, const char **module
,
3531 mio_pool_string (name
);
3532 mio_pool_string (module
);
3533 mio_interface_rest (ip
);
3538 mio_namespace_ref (gfc_namespace
**nsp
)
3543 p
= mio_pointer_ref (nsp
);
3545 if (p
->type
== P_UNKNOWN
)
3546 p
->type
= P_NAMESPACE
;
3548 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3550 ns
= (gfc_namespace
*) p
->u
.pointer
;
3553 ns
= gfc_get_namespace (NULL
, 0);
3554 associate_integer_pointer (p
, ns
);
3562 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3564 static gfc_namespace
* current_f2k_derived
;
3567 mio_typebound_proc (gfc_typebound_proc
** proc
)
3570 int overriding_flag
;
3572 if (iomode
== IO_INPUT
)
3574 *proc
= gfc_get_typebound_proc (NULL
);
3575 (*proc
)->where
= gfc_current_locus
;
3581 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3583 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3584 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3585 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3586 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3587 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3588 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3589 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3591 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3592 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3593 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3595 mio_pool_string (&((*proc
)->pass_arg
));
3597 flag
= (int) (*proc
)->pass_arg_num
;
3598 mio_integer (&flag
);
3599 (*proc
)->pass_arg_num
= (unsigned) flag
;
3601 if ((*proc
)->is_generic
)
3608 if (iomode
== IO_OUTPUT
)
3609 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3611 iop
= (int) g
->is_operator
;
3613 mio_allocated_string (g
->specific_st
->name
);
3617 (*proc
)->u
.generic
= NULL
;
3618 while (peek_atom () != ATOM_RPAREN
)
3620 gfc_symtree
** sym_root
;
3622 g
= gfc_get_tbp_generic ();
3626 g
->is_operator
= (bool) iop
;
3628 require_atom (ATOM_STRING
);
3629 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3630 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3633 g
->next
= (*proc
)->u
.generic
;
3634 (*proc
)->u
.generic
= g
;
3640 else if (!(*proc
)->ppc
)
3641 mio_symtree_ref (&(*proc
)->u
.specific
);
3646 /* Walker-callback function for this purpose. */
3648 mio_typebound_symtree (gfc_symtree
* st
)
3650 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3653 if (iomode
== IO_OUTPUT
)
3656 mio_allocated_string (st
->name
);
3658 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3660 mio_typebound_proc (&st
->n
.tb
);
3664 /* IO a full symtree (in all depth). */
3666 mio_full_typebound_tree (gfc_symtree
** root
)
3670 if (iomode
== IO_OUTPUT
)
3671 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3674 while (peek_atom () == ATOM_LPAREN
)
3680 require_atom (ATOM_STRING
);
3681 st
= gfc_get_tbp_symtree (root
, atom_string
);
3684 mio_typebound_symtree (st
);
3692 mio_finalizer (gfc_finalizer
**f
)
3694 if (iomode
== IO_OUTPUT
)
3697 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3698 mio_symtree_ref (&(*f
)->proc_tree
);
3702 *f
= gfc_get_finalizer ();
3703 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3706 mio_symtree_ref (&(*f
)->proc_tree
);
3707 (*f
)->proc_sym
= NULL
;
3712 mio_f2k_derived (gfc_namespace
*f2k
)
3714 current_f2k_derived
= f2k
;
3716 /* Handle the list of finalizer procedures. */
3718 if (iomode
== IO_OUTPUT
)
3721 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3726 f2k
->finalizers
= NULL
;
3727 while (peek_atom () != ATOM_RPAREN
)
3729 gfc_finalizer
*cur
= NULL
;
3730 mio_finalizer (&cur
);
3731 cur
->next
= f2k
->finalizers
;
3732 f2k
->finalizers
= cur
;
3737 /* Handle type-bound procedures. */
3738 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3740 /* Type-bound user operators. */
3741 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3743 /* Type-bound intrinsic operators. */
3745 if (iomode
== IO_OUTPUT
)
3748 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3750 gfc_intrinsic_op realop
;
3752 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3756 realop
= (gfc_intrinsic_op
) op
;
3757 mio_intrinsic_op (&realop
);
3758 mio_typebound_proc (&f2k
->tb_op
[op
]);
3763 while (peek_atom () != ATOM_RPAREN
)
3765 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3768 mio_intrinsic_op (&op
);
3769 mio_typebound_proc (&f2k
->tb_op
[op
]);
3776 mio_full_f2k_derived (gfc_symbol
*sym
)
3780 if (iomode
== IO_OUTPUT
)
3782 if (sym
->f2k_derived
)
3783 mio_f2k_derived (sym
->f2k_derived
);
3787 if (peek_atom () != ATOM_RPAREN
)
3789 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3790 mio_f2k_derived (sym
->f2k_derived
);
3793 gcc_assert (!sym
->f2k_derived
);
3799 static const mstring omp_declare_simd_clauses
[] =
3801 minit ("INBRANCH", 0),
3802 minit ("NOTINBRANCH", 1),
3803 minit ("SIMDLEN", 2),
3804 minit ("UNIFORM", 3),
3805 minit ("LINEAR", 4),
3806 minit ("ALIGNED", 5),
3810 /* Handle !$omp declare simd. */
3813 mio_omp_declare_simd (gfc_namespace
*ns
, gfc_omp_declare_simd
**odsp
)
3815 if (iomode
== IO_OUTPUT
)
3820 else if (peek_atom () != ATOM_LPAREN
)
3823 gfc_omp_declare_simd
*ods
= *odsp
;
3826 if (iomode
== IO_OUTPUT
)
3828 write_atom (ATOM_NAME
, "OMP_DECLARE_SIMD");
3831 gfc_omp_namelist
*n
;
3833 if (ods
->clauses
->inbranch
)
3834 mio_name (0, omp_declare_simd_clauses
);
3835 if (ods
->clauses
->notinbranch
)
3836 mio_name (1, omp_declare_simd_clauses
);
3837 if (ods
->clauses
->simdlen_expr
)
3839 mio_name (2, omp_declare_simd_clauses
);
3840 mio_expr (&ods
->clauses
->simdlen_expr
);
3842 for (n
= ods
->clauses
->lists
[OMP_LIST_UNIFORM
]; n
; n
= n
->next
)
3844 mio_name (3, omp_declare_simd_clauses
);
3845 mio_symbol_ref (&n
->sym
);
3847 for (n
= ods
->clauses
->lists
[OMP_LIST_LINEAR
]; n
; n
= n
->next
)
3849 mio_name (4, omp_declare_simd_clauses
);
3850 mio_symbol_ref (&n
->sym
);
3851 mio_expr (&n
->expr
);
3853 for (n
= ods
->clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3855 mio_name (5, omp_declare_simd_clauses
);
3856 mio_symbol_ref (&n
->sym
);
3857 mio_expr (&n
->expr
);
3863 gfc_omp_namelist
**ptrs
[3] = { NULL
, NULL
, NULL
};
3865 require_atom (ATOM_NAME
);
3866 *odsp
= ods
= gfc_get_omp_declare_simd ();
3867 ods
->where
= gfc_current_locus
;
3868 ods
->proc_name
= ns
->proc_name
;
3869 if (peek_atom () == ATOM_NAME
)
3871 ods
->clauses
= gfc_get_omp_clauses ();
3872 ptrs
[0] = &ods
->clauses
->lists
[OMP_LIST_UNIFORM
];
3873 ptrs
[1] = &ods
->clauses
->lists
[OMP_LIST_LINEAR
];
3874 ptrs
[2] = &ods
->clauses
->lists
[OMP_LIST_ALIGNED
];
3876 while (peek_atom () == ATOM_NAME
)
3878 gfc_omp_namelist
*n
;
3879 int t
= mio_name (0, omp_declare_simd_clauses
);
3883 case 0: ods
->clauses
->inbranch
= true; break;
3884 case 1: ods
->clauses
->notinbranch
= true; break;
3885 case 2: mio_expr (&ods
->clauses
->simdlen_expr
); break;
3889 *ptrs
[t
- 3] = n
= gfc_get_omp_namelist ();
3890 ptrs
[t
- 3] = &n
->next
;
3891 mio_symbol_ref (&n
->sym
);
3893 mio_expr (&n
->expr
);
3899 mio_omp_declare_simd (ns
, &ods
->next
);
3905 static const mstring omp_declare_reduction_stmt
[] =
3907 minit ("ASSIGN", 0),
3914 mio_omp_udr_expr (gfc_omp_udr
*udr
, gfc_symbol
**sym1
, gfc_symbol
**sym2
,
3915 gfc_namespace
*ns
, bool is_initializer
)
3917 if (iomode
== IO_OUTPUT
)
3919 if ((*sym1
)->module
== NULL
)
3921 (*sym1
)->module
= module_name
;
3922 (*sym2
)->module
= module_name
;
3924 mio_symbol_ref (sym1
);
3925 mio_symbol_ref (sym2
);
3926 if (ns
->code
->op
== EXEC_ASSIGN
)
3928 mio_name (0, omp_declare_reduction_stmt
);
3929 mio_expr (&ns
->code
->expr1
);
3930 mio_expr (&ns
->code
->expr2
);
3935 mio_name (1, omp_declare_reduction_stmt
);
3936 mio_symtree_ref (&ns
->code
->symtree
);
3937 mio_actual_arglist (&ns
->code
->ext
.actual
);
3939 flag
= ns
->code
->resolved_isym
!= NULL
;
3940 mio_integer (&flag
);
3942 write_atom (ATOM_STRING
, ns
->code
->resolved_isym
->name
);
3944 mio_symbol_ref (&ns
->code
->resolved_sym
);
3949 pointer_info
*p1
= mio_symbol_ref (sym1
);
3950 pointer_info
*p2
= mio_symbol_ref (sym2
);
3952 gcc_assert (p1
->u
.rsym
.ns
== p2
->u
.rsym
.ns
);
3953 gcc_assert (p1
->u
.rsym
.sym
== NULL
);
3954 /* Add hidden symbols to the symtree. */
3955 pointer_info
*q
= get_integer (p1
->u
.rsym
.ns
);
3956 q
->u
.pointer
= (void *) ns
;
3957 sym
= gfc_new_symbol (is_initializer
? "omp_priv" : "omp_out", ns
);
3959 sym
->module
= gfc_get_string (p1
->u
.rsym
.module
);
3960 associate_integer_pointer (p1
, sym
);
3961 sym
->attr
.omp_udr_artificial_var
= 1;
3962 gcc_assert (p2
->u
.rsym
.sym
== NULL
);
3963 sym
= gfc_new_symbol (is_initializer
? "omp_orig" : "omp_in", ns
);
3965 sym
->module
= gfc_get_string (p2
->u
.rsym
.module
);
3966 associate_integer_pointer (p2
, sym
);
3967 sym
->attr
.omp_udr_artificial_var
= 1;
3968 if (mio_name (0, omp_declare_reduction_stmt
) == 0)
3970 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
3971 mio_expr (&ns
->code
->expr1
);
3972 mio_expr (&ns
->code
->expr2
);
3977 ns
->code
= gfc_get_code (EXEC_CALL
);
3978 mio_symtree_ref (&ns
->code
->symtree
);
3979 mio_actual_arglist (&ns
->code
->ext
.actual
);
3981 mio_integer (&flag
);
3984 require_atom (ATOM_STRING
);
3985 ns
->code
->resolved_isym
= gfc_find_subroutine (atom_string
);
3989 mio_symbol_ref (&ns
->code
->resolved_sym
);
3991 ns
->code
->loc
= gfc_current_locus
;
3997 /* Unlike most other routines, the address of the symbol node is already
3998 fixed on input and the name/module has already been filled in.
3999 If you update the symbol format here, don't forget to update read_module
4000 as well (look for "seek to the symbol's component list"). */
4003 mio_symbol (gfc_symbol
*sym
)
4005 int intmod
= INTMOD_NONE
;
4009 mio_symbol_attribute (&sym
->attr
);
4011 /* Note that components are always saved, even if they are supposed
4012 to be private. Component access is checked during searching. */
4013 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
4014 if (sym
->components
!= NULL
)
4015 sym
->component_access
4016 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
4018 mio_typespec (&sym
->ts
);
4019 if (sym
->ts
.type
== BT_CLASS
)
4020 sym
->attr
.class_ok
= 1;
4022 if (iomode
== IO_OUTPUT
)
4023 mio_namespace_ref (&sym
->formal_ns
);
4026 mio_namespace_ref (&sym
->formal_ns
);
4028 sym
->formal_ns
->proc_name
= sym
;
4031 /* Save/restore common block links. */
4032 mio_symbol_ref (&sym
->common_next
);
4034 mio_formal_arglist (&sym
->formal
);
4036 if (sym
->attr
.flavor
== FL_PARAMETER
)
4037 mio_expr (&sym
->value
);
4039 mio_array_spec (&sym
->as
);
4041 mio_symbol_ref (&sym
->result
);
4043 if (sym
->attr
.cray_pointee
)
4044 mio_symbol_ref (&sym
->cp_pointer
);
4046 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4047 mio_full_f2k_derived (sym
);
4051 /* Add the fields that say whether this is from an intrinsic module,
4052 and if so, what symbol it is within the module. */
4053 /* mio_integer (&(sym->from_intmod)); */
4054 if (iomode
== IO_OUTPUT
)
4056 intmod
= sym
->from_intmod
;
4057 mio_integer (&intmod
);
4061 mio_integer (&intmod
);
4062 sym
->from_intmod
= (intmod_id
) intmod
;
4065 mio_integer (&(sym
->intmod_sym_id
));
4067 if (sym
->attr
.flavor
== FL_DERIVED
)
4068 mio_integer (&(sym
->hash_value
));
4071 && sym
->formal_ns
->proc_name
== sym
4072 && sym
->formal_ns
->entries
== NULL
)
4073 mio_omp_declare_simd (sym
->formal_ns
, &sym
->formal_ns
->omp_declare_simd
);
4079 /************************* Top level subroutines *************************/
4081 /* Given a root symtree node and a symbol, try to find a symtree that
4082 references the symbol that is not a unique name. */
4084 static gfc_symtree
*
4085 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
4087 gfc_symtree
*s
= NULL
;
4092 s
= find_symtree_for_symbol (st
->right
, sym
);
4095 s
= find_symtree_for_symbol (st
->left
, sym
);
4099 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
4106 /* A recursive function to look for a specific symbol by name and by
4107 module. Whilst several symtrees might point to one symbol, its
4108 is sufficient for the purposes here than one exist. Note that
4109 generic interfaces are distinguished as are symbols that have been
4110 renamed in another module. */
4111 static gfc_symtree
*
4112 find_symbol (gfc_symtree
*st
, const char *name
,
4113 const char *module
, int generic
)
4116 gfc_symtree
*retval
, *s
;
4118 if (st
== NULL
|| st
->n
.sym
== NULL
)
4121 c
= strcmp (name
, st
->n
.sym
->name
);
4122 if (c
== 0 && st
->n
.sym
->module
4123 && strcmp (module
, st
->n
.sym
->module
) == 0
4124 && !check_unique_name (st
->name
))
4126 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4128 /* Detect symbols that are renamed by use association in another
4129 module by the absence of a symtree and null attr.use_rename,
4130 since the latter is not transmitted in the module file. */
4131 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
4132 || (generic
&& st
->n
.sym
->attr
.generic
))
4133 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
4137 retval
= find_symbol (st
->left
, name
, module
, generic
);
4140 retval
= find_symbol (st
->right
, name
, module
, generic
);
4146 /* Skip a list between balanced left and right parens.
4147 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4148 have been already parsed by hand, and the remaining of the content is to be
4149 skipped here. The default value is 0 (balanced parens). */
4152 skip_list (int nest_level
= 0)
4159 switch (parse_atom ())
4182 /* Load operator interfaces from the module. Interfaces are unusual
4183 in that they attach themselves to existing symbols. */
4186 load_operator_interfaces (void)
4189 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4191 pointer_info
*pi
= NULL
;
4196 while (peek_atom () != ATOM_RPAREN
)
4200 mio_internal_string (name
);
4201 mio_internal_string (module
);
4203 n
= number_use_names (name
, true);
4206 for (i
= 1; i
<= n
; i
++)
4208 /* Decide if we need to load this one or not. */
4209 p
= find_use_name_n (name
, &i
, true);
4213 while (parse_atom () != ATOM_RPAREN
);
4219 uop
= gfc_get_uop (p
);
4220 pi
= mio_interface_rest (&uop
->op
);
4224 if (gfc_find_uop (p
, NULL
))
4226 uop
= gfc_get_uop (p
);
4227 uop
->op
= gfc_get_interface ();
4228 uop
->op
->where
= gfc_current_locus
;
4229 add_fixup (pi
->integer
, &uop
->op
->sym
);
4238 /* Load interfaces from the module. Interfaces are unusual in that
4239 they attach themselves to existing symbols. */
4242 load_generic_interfaces (void)
4245 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4247 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4249 bool ambiguous_set
= false;
4253 while (peek_atom () != ATOM_RPAREN
)
4257 mio_internal_string (name
);
4258 mio_internal_string (module
);
4260 n
= number_use_names (name
, false);
4261 renamed
= n
? 1 : 0;
4264 for (i
= 1; i
<= n
; i
++)
4267 /* Decide if we need to load this one or not. */
4268 p
= find_use_name_n (name
, &i
, false);
4270 st
= find_symbol (gfc_current_ns
->sym_root
,
4271 name
, module_name
, 1);
4273 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4275 /* Skip the specific names for these cases. */
4276 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4281 /* If the symbol exists already and is being USEd without being
4282 in an ONLY clause, do not load a new symtree(11.3.2). */
4283 if (!only_flag
&& st
)
4291 if (strcmp (st
->name
, p
) != 0)
4293 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4299 /* Since we haven't found a valid generic interface, we had
4303 gfc_get_symbol (p
, NULL
, &sym
);
4304 sym
->name
= gfc_get_string (name
);
4305 sym
->module
= module_name
;
4306 sym
->attr
.flavor
= FL_PROCEDURE
;
4307 sym
->attr
.generic
= 1;
4308 sym
->attr
.use_assoc
= 1;
4313 /* Unless sym is a generic interface, this reference
4316 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4320 if (st
&& !sym
->attr
.generic
4323 && strcmp (module
, sym
->module
))
4325 ambiguous_set
= true;
4330 sym
->attr
.use_only
= only_flag
;
4331 sym
->attr
.use_rename
= renamed
;
4335 mio_interface_rest (&sym
->generic
);
4336 generic
= sym
->generic
;
4338 else if (!sym
->generic
)
4340 sym
->generic
= generic
;
4341 sym
->attr
.generic_copy
= 1;
4344 /* If a procedure that is not generic has generic interfaces
4345 that include itself, it is generic! We need to take care
4346 to retain symbols ambiguous that were already so. */
4347 if (sym
->attr
.use_assoc
4348 && !sym
->attr
.generic
4349 && sym
->attr
.flavor
== FL_PROCEDURE
)
4351 for (gen
= generic
; gen
; gen
= gen
->next
)
4353 if (gen
->sym
== sym
)
4355 sym
->attr
.generic
= 1;
4370 /* Load common blocks. */
4375 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4380 while (peek_atom () != ATOM_RPAREN
)
4385 mio_internal_string (name
);
4387 p
= gfc_get_common (name
, 1);
4389 mio_symbol_ref (&p
->head
);
4390 mio_integer (&flags
);
4394 p
->threadprivate
= 1;
4397 /* Get whether this was a bind(c) common or not. */
4398 mio_integer (&p
->is_bind_c
);
4399 /* Get the binding label. */
4400 label
= read_string ();
4402 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4412 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4413 so that unused variables are not loaded and so that the expression can
4419 gfc_equiv
*head
, *tail
, *end
, *eq
;
4423 in_load_equiv
= true;
4425 end
= gfc_current_ns
->equiv
;
4426 while (end
!= NULL
&& end
->next
!= NULL
)
4429 while (peek_atom () != ATOM_RPAREN
) {
4433 while(peek_atom () != ATOM_RPAREN
)
4436 head
= tail
= gfc_get_equiv ();
4439 tail
->eq
= gfc_get_equiv ();
4443 mio_pool_string (&tail
->module
);
4444 mio_expr (&tail
->expr
);
4447 /* Unused equivalence members have a unique name. In addition, it
4448 must be checked that the symbols are from the same module. */
4450 for (eq
= head
; eq
; eq
= eq
->eq
)
4452 if (eq
->expr
->symtree
->n
.sym
->module
4453 && head
->expr
->symtree
->n
.sym
->module
4454 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4455 eq
->expr
->symtree
->n
.sym
->module
) == 0
4456 && !check_unique_name (eq
->expr
->symtree
->name
))
4465 for (eq
= head
; eq
; eq
= head
)
4468 gfc_free_expr (eq
->expr
);
4474 gfc_current_ns
->equiv
= head
;
4485 in_load_equiv
= false;
4489 /* This function loads the sym_root of f2k_derived with the extensions to
4490 the derived type. */
4492 load_derived_extensions (void)
4495 gfc_symbol
*derived
;
4499 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4500 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4504 while (peek_atom () != ATOM_RPAREN
)
4507 mio_integer (&symbol
);
4508 info
= get_integer (symbol
);
4509 derived
= info
->u
.rsym
.sym
;
4511 /* This one is not being loaded. */
4512 if (!info
|| !derived
)
4514 while (peek_atom () != ATOM_RPAREN
)
4519 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4520 if (derived
->f2k_derived
== NULL
)
4521 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4523 while (peek_atom () != ATOM_RPAREN
)
4526 mio_internal_string (name
);
4527 mio_internal_string (module
);
4529 /* Only use one use name to find the symbol. */
4531 p
= find_use_name_n (name
, &j
, false);
4534 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4536 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4539 /* Only use the real name in f2k_derived to ensure a single
4541 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4554 /* This function loads OpenMP user defined reductions. */
4556 load_omp_udrs (void)
4559 while (peek_atom () != ATOM_RPAREN
)
4561 const char *name
, *newname
;
4565 gfc_omp_reduction_op rop
= OMP_REDUCTION_USER
;
4568 mio_pool_string (&name
);
4570 if (strncmp (name
, "operator ", sizeof ("operator ") - 1) == 0)
4572 const char *p
= name
+ sizeof ("operator ") - 1;
4573 if (strcmp (p
, "+") == 0)
4574 rop
= OMP_REDUCTION_PLUS
;
4575 else if (strcmp (p
, "*") == 0)
4576 rop
= OMP_REDUCTION_TIMES
;
4577 else if (strcmp (p
, "-") == 0)
4578 rop
= OMP_REDUCTION_MINUS
;
4579 else if (strcmp (p
, ".and.") == 0)
4580 rop
= OMP_REDUCTION_AND
;
4581 else if (strcmp (p
, ".or.") == 0)
4582 rop
= OMP_REDUCTION_OR
;
4583 else if (strcmp (p
, ".eqv.") == 0)
4584 rop
= OMP_REDUCTION_EQV
;
4585 else if (strcmp (p
, ".neqv.") == 0)
4586 rop
= OMP_REDUCTION_NEQV
;
4589 if (rop
== OMP_REDUCTION_USER
&& name
[0] == '.')
4591 size_t len
= strlen (name
+ 1);
4592 altname
= XALLOCAVEC (char, len
);
4593 gcc_assert (name
[len
] == '.');
4594 memcpy (altname
, name
+ 1, len
- 1);
4595 altname
[len
- 1] = '\0';
4598 if (rop
== OMP_REDUCTION_USER
)
4599 newname
= find_use_name (altname
? altname
: name
, !!altname
);
4600 else if (only_flag
&& find_use_operator ((gfc_intrinsic_op
) rop
) == NULL
)
4602 if (newname
== NULL
)
4607 if (altname
&& newname
!= altname
)
4609 size_t len
= strlen (newname
);
4610 altname
= XALLOCAVEC (char, len
+ 3);
4612 memcpy (altname
+ 1, newname
, len
);
4613 altname
[len
+ 1] = '.';
4614 altname
[len
+ 2] = '\0';
4615 name
= gfc_get_string (altname
);
4617 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
4618 gfc_omp_udr
*udr
= gfc_omp_udr_find (st
, &ts
);
4621 require_atom (ATOM_INTEGER
);
4622 pointer_info
*p
= get_integer (atom_int
);
4623 if (strcmp (p
->u
.rsym
.module
, udr
->omp_out
->module
))
4625 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4627 p
->u
.rsym
.module
, &gfc_current_locus
);
4628 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4630 udr
->omp_out
->module
, &udr
->where
);
4635 udr
= gfc_get_omp_udr ();
4639 udr
->where
= gfc_current_locus
;
4640 udr
->combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4641 udr
->combiner_ns
->proc_name
= gfc_current_ns
->proc_name
;
4642 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
,
4644 if (peek_atom () != ATOM_RPAREN
)
4646 udr
->initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
4647 udr
->initializer_ns
->proc_name
= gfc_current_ns
->proc_name
;
4648 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
4649 udr
->initializer_ns
, true);
4653 udr
->next
= st
->n
.omp_udr
;
4654 st
->n
.omp_udr
= udr
;
4658 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
4659 st
->n
.omp_udr
= udr
;
4667 /* Recursive function to traverse the pointer_info tree and load a
4668 needed symbol. We return nonzero if we load a symbol and stop the
4669 traversal, because the act of loading can alter the tree. */
4672 load_needed (pointer_info
*p
)
4683 rv
|= load_needed (p
->left
);
4684 rv
|= load_needed (p
->right
);
4686 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4689 p
->u
.rsym
.state
= USED
;
4691 set_module_locus (&p
->u
.rsym
.where
);
4693 sym
= p
->u
.rsym
.sym
;
4696 q
= get_integer (p
->u
.rsym
.ns
);
4698 ns
= (gfc_namespace
*) q
->u
.pointer
;
4701 /* Create an interface namespace if necessary. These are
4702 the namespaces that hold the formal parameters of module
4705 ns
= gfc_get_namespace (NULL
, 0);
4706 associate_integer_pointer (q
, ns
);
4709 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4710 doesn't go pear-shaped if the symbol is used. */
4712 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4715 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4716 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4717 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4718 if (p
->u
.rsym
.binding_label
)
4719 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4720 (p
->u
.rsym
.binding_label
));
4722 associate_integer_pointer (p
, sym
);
4726 sym
->attr
.use_assoc
= 1;
4728 /* Mark as only or rename for later diagnosis for explicitly imported
4729 but not used warnings; don't mark internal symbols such as __vtab,
4730 __def_init etc. Only mark them if they have been explicitly loaded. */
4732 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4736 /* Search the use/rename list for the variable; if the variable is
4738 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4740 if (strcmp (u
->use_name
, sym
->name
) == 0)
4742 sym
->attr
.use_only
= 1;
4748 if (p
->u
.rsym
.renamed
)
4749 sym
->attr
.use_rename
= 1;
4755 /* Recursive function for cleaning up things after a module has been read. */
4758 read_cleanup (pointer_info
*p
)
4766 read_cleanup (p
->left
);
4767 read_cleanup (p
->right
);
4769 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4772 /* Add hidden symbols to the symtree. */
4773 q
= get_integer (p
->u
.rsym
.ns
);
4774 ns
= (gfc_namespace
*) q
->u
.pointer
;
4776 if (!p
->u
.rsym
.sym
->attr
.vtype
4777 && !p
->u
.rsym
.sym
->attr
.vtab
)
4778 st
= gfc_get_unique_symtree (ns
);
4781 /* There is no reason to use 'unique_symtrees' for vtabs or
4782 vtypes - their name is fine for a symtree and reduces the
4783 namespace pollution. */
4784 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4786 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4789 st
->n
.sym
= p
->u
.rsym
.sym
;
4792 /* Fixup any symtree references. */
4793 p
->u
.rsym
.symtree
= st
;
4794 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4795 p
->u
.rsym
.stfixup
= NULL
;
4798 /* Free unused symbols. */
4799 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4800 gfc_free_symbol (p
->u
.rsym
.sym
);
4804 /* It is not quite enough to check for ambiguity in the symbols by
4805 the loaded symbol and the new symbol not being identical. */
4807 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4811 symbol_attribute attr
;
4813 if (gfc_current_ns
->proc_name
&& st_sym
->name
== gfc_current_ns
->proc_name
->name
)
4815 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4816 "current program unit", st_sym
->name
, module_name
);
4820 rsym
= info
->u
.rsym
.sym
;
4824 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4827 /* If the existing symbol is generic from a different module and
4828 the new symbol is generic there can be no ambiguity. */
4829 if (st_sym
->attr
.generic
4831 && st_sym
->module
!= module_name
)
4833 /* The new symbol's attributes have not yet been read. Since
4834 we need attr.generic, read it directly. */
4835 get_module_locus (&locus
);
4836 set_module_locus (&info
->u
.rsym
.where
);
4839 mio_symbol_attribute (&attr
);
4840 set_module_locus (&locus
);
4849 /* Read a module file. */
4854 module_locus operator_interfaces
, user_operators
, extensions
, omp_udrs
;
4856 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4858 int ambiguous
, j
, nuse
, symbol
;
4859 pointer_info
*info
, *q
;
4860 gfc_use_rename
*u
= NULL
;
4864 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4867 get_module_locus (&user_operators
);
4871 /* Skip commons, equivalences and derived type extensions for now. */
4875 get_module_locus (&extensions
);
4878 /* Skip OpenMP UDRs. */
4879 get_module_locus (&omp_udrs
);
4884 /* Create the fixup nodes for all the symbols. */
4886 while (peek_atom () != ATOM_RPAREN
)
4889 require_atom (ATOM_INTEGER
);
4890 info
= get_integer (atom_int
);
4892 info
->type
= P_SYMBOL
;
4893 info
->u
.rsym
.state
= UNUSED
;
4895 info
->u
.rsym
.true_name
= read_string ();
4896 info
->u
.rsym
.module
= read_string ();
4897 bind_label
= read_string ();
4898 if (strlen (bind_label
))
4899 info
->u
.rsym
.binding_label
= bind_label
;
4901 XDELETEVEC (bind_label
);
4903 require_atom (ATOM_INTEGER
);
4904 info
->u
.rsym
.ns
= atom_int
;
4906 get_module_locus (&info
->u
.rsym
.where
);
4908 /* See if the symbol has already been loaded by a previous module.
4909 If so, we reference the existing symbol and prevent it from
4910 being loaded again. This should not happen if the symbol being
4911 read is an index for an assumed shape dummy array (ns != 1). */
4913 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4916 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4922 info
->u
.rsym
.state
= USED
;
4923 info
->u
.rsym
.sym
= sym
;
4924 /* The current symbol has already been loaded, so we can avoid loading
4925 it again. However, if it is a derived type, some of its components
4926 can be used in expressions in the module. To avoid the module loading
4927 failing, we need to associate the module's component pointer indexes
4928 with the existing symbol's component pointers. */
4929 if (sym
->attr
.flavor
== FL_DERIVED
)
4933 /* First seek to the symbol's component list. */
4934 mio_lparen (); /* symbol opening. */
4935 skip_list (); /* skip symbol attribute. */
4937 mio_lparen (); /* component list opening. */
4938 for (c
= sym
->components
; c
; c
= c
->next
)
4941 const char *comp_name
;
4944 mio_lparen (); /* component opening. */
4946 p
= get_integer (n
);
4947 if (p
->u
.pointer
== NULL
)
4948 associate_integer_pointer (p
, c
);
4949 mio_pool_string (&comp_name
);
4950 gcc_assert (comp_name
== c
->name
);
4951 skip_list (1); /* component end. */
4953 mio_rparen (); /* component list closing. */
4955 skip_list (1); /* symbol end. */
4960 /* Some symbols do not have a namespace (eg. formal arguments),
4961 so the automatic "unique symtree" mechanism must be suppressed
4962 by marking them as referenced. */
4963 q
= get_integer (info
->u
.rsym
.ns
);
4964 if (q
->u
.pointer
== NULL
)
4966 info
->u
.rsym
.referenced
= 1;
4970 /* If possible recycle the symtree that references the symbol.
4971 If a symtree is not found and the module does not import one,
4972 a unique-name symtree is found by read_cleanup. */
4973 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4976 info
->u
.rsym
.symtree
= st
;
4977 info
->u
.rsym
.referenced
= 1;
4983 /* Parse the symtree lists. This lets us mark which symbols need to
4984 be loaded. Renaming is also done at this point by replacing the
4989 while (peek_atom () != ATOM_RPAREN
)
4991 mio_internal_string (name
);
4992 mio_integer (&ambiguous
);
4993 mio_integer (&symbol
);
4995 info
= get_integer (symbol
);
4997 /* See how many use names there are. If none, go through the start
4998 of the loop at least once. */
4999 nuse
= number_use_names (name
, false);
5000 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
5005 for (j
= 1; j
<= nuse
; j
++)
5007 /* Get the jth local name for this symbol. */
5008 p
= find_use_name_n (name
, &j
, false);
5010 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
5013 /* Exception: Always import vtabs & vtypes. */
5014 if (p
== NULL
&& name
[0] == '_'
5015 && (strncmp (name
, "__vtab_", 5) == 0
5016 || strncmp (name
, "__vtype_", 6) == 0))
5019 /* Skip symtree nodes not in an ONLY clause, unless there
5020 is an existing symtree loaded from another USE statement. */
5023 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5025 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
5026 && st
->n
.sym
->module
!= NULL
5027 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
5029 info
->u
.rsym
.symtree
= st
;
5030 info
->u
.rsym
.sym
= st
->n
.sym
;
5035 /* If a symbol of the same name and module exists already,
5036 this symbol, which is not in an ONLY clause, must not be
5037 added to the namespace(11.3.2). Note that find_symbol
5038 only returns the first occurrence that it finds. */
5039 if (!only_flag
&& !info
->u
.rsym
.renamed
5040 && strcmp (name
, module_name
) != 0
5041 && find_symbol (gfc_current_ns
->sym_root
, name
,
5045 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
5049 /* Check for ambiguous symbols. */
5050 if (check_for_ambiguous (st
->n
.sym
, info
))
5053 info
->u
.rsym
.symtree
= st
;
5057 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5059 /* Create a symtree node in the current namespace for this
5061 st
= check_unique_name (p
)
5062 ? gfc_get_unique_symtree (gfc_current_ns
)
5063 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
5064 st
->ambiguous
= ambiguous
;
5066 sym
= info
->u
.rsym
.sym
;
5068 /* Create a symbol node if it doesn't already exist. */
5071 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
5073 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
5074 sym
= info
->u
.rsym
.sym
;
5075 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
5077 if (info
->u
.rsym
.binding_label
)
5078 sym
->binding_label
=
5079 IDENTIFIER_POINTER (get_identifier
5080 (info
->u
.rsym
.binding_label
));
5086 if (strcmp (name
, p
) != 0)
5087 sym
->attr
.use_rename
= 1;
5090 || (strncmp (name
, "__vtab_", 5) != 0
5091 && strncmp (name
, "__vtype_", 6) != 0))
5092 sym
->attr
.use_only
= only_flag
;
5094 /* Store the symtree pointing to this symbol. */
5095 info
->u
.rsym
.symtree
= st
;
5097 if (info
->u
.rsym
.state
== UNUSED
)
5098 info
->u
.rsym
.state
= NEEDED
;
5099 info
->u
.rsym
.referenced
= 1;
5106 /* Load intrinsic operator interfaces. */
5107 set_module_locus (&operator_interfaces
);
5110 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5112 if (i
== INTRINSIC_USER
)
5117 u
= find_use_operator ((gfc_intrinsic_op
) i
);
5128 mio_interface (&gfc_current_ns
->op
[i
]);
5129 if (u
&& !gfc_current_ns
->op
[i
])
5135 /* Load generic and user operator interfaces. These must follow the
5136 loading of symtree because otherwise symbols can be marked as
5139 set_module_locus (&user_operators
);
5141 load_operator_interfaces ();
5142 load_generic_interfaces ();
5147 /* Load OpenMP user defined reductions. */
5148 set_module_locus (&omp_udrs
);
5151 /* At this point, we read those symbols that are needed but haven't
5152 been loaded yet. If one symbol requires another, the other gets
5153 marked as NEEDED if its previous state was UNUSED. */
5155 while (load_needed (pi_root
));
5157 /* Make sure all elements of the rename-list were found in the module. */
5159 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5164 if (u
->op
== INTRINSIC_NONE
)
5166 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
5167 u
->use_name
, &u
->where
, module_name
);
5171 if (u
->op
== INTRINSIC_USER
)
5173 gfc_error ("User operator '%s' referenced at %L not found "
5174 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
5178 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
5179 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
5183 /* Now we should be in a position to fill f2k_derived with derived type
5184 extensions, since everything has been loaded. */
5185 set_module_locus (&extensions
);
5186 load_derived_extensions ();
5188 /* Clean up symbol nodes that were never loaded, create references
5189 to hidden symbols. */
5191 read_cleanup (pi_root
);
5195 /* Given an access type that is specific to an entity and the default
5196 access, return nonzero if the entity is publicly accessible. If the
5197 element is declared as PUBLIC, then it is public; if declared
5198 PRIVATE, then private, and otherwise it is public unless the default
5199 access in this context has been declared PRIVATE. */
5202 check_access (gfc_access specific_access
, gfc_access default_access
)
5204 if (specific_access
== ACCESS_PUBLIC
)
5206 if (specific_access
== ACCESS_PRIVATE
)
5209 if (gfc_option
.flag_module_private
)
5210 return default_access
== ACCESS_PUBLIC
;
5212 return default_access
!= ACCESS_PRIVATE
;
5217 gfc_check_symbol_access (gfc_symbol
*sym
)
5219 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
5222 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
5226 /* A structure to remember which commons we've already written. */
5228 struct written_common
5230 BBT_HEADER(written_common
);
5231 const char *name
, *label
;
5234 static struct written_common
*written_commons
= NULL
;
5236 /* Comparison function used for balancing the binary tree. */
5239 compare_written_commons (void *a1
, void *b1
)
5241 const char *aname
= ((struct written_common
*) a1
)->name
;
5242 const char *alabel
= ((struct written_common
*) a1
)->label
;
5243 const char *bname
= ((struct written_common
*) b1
)->name
;
5244 const char *blabel
= ((struct written_common
*) b1
)->label
;
5245 int c
= strcmp (aname
, bname
);
5247 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
5250 /* Free a list of written commons. */
5253 free_written_common (struct written_common
*w
)
5259 free_written_common (w
->left
);
5261 free_written_common (w
->right
);
5266 /* Write a common block to the module -- recursive helper function. */
5269 write_common_0 (gfc_symtree
*st
, bool this_module
)
5275 struct written_common
*w
;
5276 bool write_me
= true;
5281 write_common_0 (st
->left
, this_module
);
5283 /* We will write out the binding label, or "" if no label given. */
5284 name
= st
->n
.common
->name
;
5286 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
5288 /* Check if we've already output this common. */
5289 w
= written_commons
;
5292 int c
= strcmp (name
, w
->name
);
5293 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
5297 w
= (c
< 0) ? w
->left
: w
->right
;
5300 if (this_module
&& p
->use_assoc
)
5305 /* Write the common to the module. */
5307 mio_pool_string (&name
);
5309 mio_symbol_ref (&p
->head
);
5310 flags
= p
->saved
? 1 : 0;
5311 if (p
->threadprivate
)
5313 mio_integer (&flags
);
5315 /* Write out whether the common block is bind(c) or not. */
5316 mio_integer (&(p
->is_bind_c
));
5318 mio_pool_string (&label
);
5321 /* Record that we have written this common. */
5322 w
= XCNEW (struct written_common
);
5325 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
5328 write_common_0 (st
->right
, this_module
);
5332 /* Write a common, by initializing the list of written commons, calling
5333 the recursive function write_common_0() and cleaning up afterwards. */
5336 write_common (gfc_symtree
*st
)
5338 written_commons
= NULL
;
5339 write_common_0 (st
, true);
5340 write_common_0 (st
, false);
5341 free_written_common (written_commons
);
5342 written_commons
= NULL
;
5346 /* Write the blank common block to the module. */
5349 write_blank_common (void)
5351 const char * name
= BLANK_COMMON_NAME
;
5353 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5354 this, but it hasn't been checked. Just making it so for now. */
5357 if (gfc_current_ns
->blank_common
.head
== NULL
)
5362 mio_pool_string (&name
);
5364 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
5365 saved
= gfc_current_ns
->blank_common
.saved
;
5366 mio_integer (&saved
);
5368 /* Write out whether the common block is bind(c) or not. */
5369 mio_integer (&is_bind_c
);
5371 /* Write out an empty binding label. */
5372 write_atom (ATOM_STRING
, "");
5378 /* Write equivalences to the module. */
5387 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5391 for (e
= eq
; e
; e
= e
->eq
)
5393 if (e
->module
== NULL
)
5394 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5395 mio_allocated_string (e
->module
);
5396 mio_expr (&e
->expr
);
5405 /* Write derived type extensions to the module. */
5408 write_dt_extensions (gfc_symtree
*st
)
5410 if (!gfc_check_symbol_access (st
->n
.sym
))
5412 if (!(st
->n
.sym
->ns
&& st
->n
.sym
->ns
->proc_name
5413 && st
->n
.sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
5417 mio_pool_string (&st
->name
);
5418 if (st
->n
.sym
->module
!= NULL
)
5419 mio_pool_string (&st
->n
.sym
->module
);
5422 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5423 if (iomode
== IO_OUTPUT
)
5424 strcpy (name
, module_name
);
5425 mio_internal_string (name
);
5426 if (iomode
== IO_INPUT
)
5427 module_name
= gfc_get_string (name
);
5433 write_derived_extensions (gfc_symtree
*st
)
5435 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
5436 && (st
->n
.sym
->f2k_derived
!= NULL
)
5437 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
5441 mio_symbol_ref (&(st
->n
.sym
));
5442 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
5443 write_dt_extensions
);
5448 /* Write a symbol to the module. */
5451 write_symbol (int n
, gfc_symbol
*sym
)
5455 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5456 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
5460 if (sym
->attr
.flavor
== FL_DERIVED
)
5463 name
= dt_upper_string (sym
->name
);
5464 mio_pool_string (&name
);
5467 mio_pool_string (&sym
->name
);
5469 mio_pool_string (&sym
->module
);
5470 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5472 label
= sym
->binding_label
;
5473 mio_pool_string (&label
);
5476 write_atom (ATOM_STRING
, "");
5478 mio_pointer_ref (&sym
->ns
);
5485 /* Recursive traversal function to write the initial set of symbols to
5486 the module. We check to see if the symbol should be written
5487 according to the access specification. */
5490 write_symbol0 (gfc_symtree
*st
)
5494 bool dont_write
= false;
5499 write_symbol0 (st
->left
);
5502 if (sym
->module
== NULL
)
5503 sym
->module
= module_name
;
5505 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5506 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5509 if (!gfc_check_symbol_access (sym
))
5514 p
= get_pointer (sym
);
5515 if (p
->type
== P_UNKNOWN
)
5518 if (p
->u
.wsym
.state
!= WRITTEN
)
5520 write_symbol (p
->integer
, sym
);
5521 p
->u
.wsym
.state
= WRITTEN
;
5525 write_symbol0 (st
->right
);
5530 write_omp_udr (gfc_omp_udr
*udr
)
5534 case OMP_REDUCTION_USER
:
5535 /* Non-operators can't be used outside of the module. */
5536 if (udr
->name
[0] != '.')
5541 size_t len
= strlen (udr
->name
+ 1);
5542 char *name
= XALLOCAVEC (char, len
);
5543 memcpy (name
, udr
->name
, len
- 1);
5544 name
[len
- 1] = '\0';
5545 st
= gfc_find_symtree (gfc_current_ns
->uop_root
, name
);
5546 /* If corresponding user operator is private, don't write
5550 gfc_user_op
*uop
= st
->n
.uop
;
5551 if (!check_access (uop
->access
, uop
->ns
->default_access
))
5556 case OMP_REDUCTION_PLUS
:
5557 case OMP_REDUCTION_MINUS
:
5558 case OMP_REDUCTION_TIMES
:
5559 case OMP_REDUCTION_AND
:
5560 case OMP_REDUCTION_OR
:
5561 case OMP_REDUCTION_EQV
:
5562 case OMP_REDUCTION_NEQV
:
5563 /* If corresponding operator is private, don't write the UDR. */
5564 if (!check_access (gfc_current_ns
->operator_access
[udr
->rop
],
5565 gfc_current_ns
->default_access
))
5571 if (udr
->ts
.type
== BT_DERIVED
|| udr
->ts
.type
== BT_CLASS
)
5573 /* If derived type is private, don't write the UDR. */
5574 if (!gfc_check_symbol_access (udr
->ts
.u
.derived
))
5579 mio_pool_string (&udr
->name
);
5580 mio_typespec (&udr
->ts
);
5581 mio_omp_udr_expr (udr
, &udr
->omp_out
, &udr
->omp_in
, udr
->combiner_ns
, false);
5582 if (udr
->initializer_ns
)
5583 mio_omp_udr_expr (udr
, &udr
->omp_priv
, &udr
->omp_orig
,
5584 udr
->initializer_ns
, true);
5590 write_omp_udrs (gfc_symtree
*st
)
5595 write_omp_udrs (st
->left
);
5597 for (udr
= st
->n
.omp_udr
; udr
; udr
= udr
->next
)
5598 write_omp_udr (udr
);
5599 write_omp_udrs (st
->right
);
5603 /* Type for the temporary tree used when writing secondary symbols. */
5605 struct sorted_pointer_info
5607 BBT_HEADER (sorted_pointer_info
);
5612 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5614 /* Recursively traverse the temporary tree, free its contents. */
5617 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5622 free_sorted_pointer_info_tree (p
->left
);
5623 free_sorted_pointer_info_tree (p
->right
);
5628 /* Comparison function for the temporary tree. */
5631 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5633 sorted_pointer_info
*spi1
, *spi2
;
5634 spi1
= (sorted_pointer_info
*)_spi1
;
5635 spi2
= (sorted_pointer_info
*)_spi2
;
5637 if (spi1
->p
->integer
< spi2
->p
->integer
)
5639 if (spi1
->p
->integer
> spi2
->p
->integer
)
5645 /* Finds the symbols that need to be written and collects them in the
5646 sorted_pi tree so that they can be traversed in an order
5647 independent of memory addresses. */
5650 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5655 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5657 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5660 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5663 find_symbols_to_write (tree
, p
->left
);
5664 find_symbols_to_write (tree
, p
->right
);
5668 /* Recursive function that traverses the tree of symbols that need to be
5669 written and writes them in order. */
5672 write_symbol1_recursion (sorted_pointer_info
*sp
)
5677 write_symbol1_recursion (sp
->left
);
5679 pointer_info
*p1
= sp
->p
;
5680 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5682 p1
->u
.wsym
.state
= WRITTEN
;
5683 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5684 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5686 write_symbol1_recursion (sp
->right
);
5690 /* Write the secondary set of symbols to the module file. These are
5691 symbols that were not public yet are needed by the public symbols
5692 or another dependent symbol. The act of writing a symbol can add
5693 symbols to the pointer_info tree, so we return nonzero if a symbol
5694 was written and pass that information upwards. The caller will
5695 then call this function again until nothing was written. It uses
5696 the utility functions and a temporary tree to ensure a reproducible
5697 ordering of the symbol output and thus the module file. */
5700 write_symbol1 (pointer_info
*p
)
5705 /* Put symbols that need to be written into a tree sorted on the
5708 sorted_pointer_info
*spi_root
= NULL
;
5709 find_symbols_to_write (&spi_root
, p
);
5711 /* No symbols to write, return. */
5715 /* Otherwise, write and free the tree again. */
5716 write_symbol1_recursion (spi_root
);
5717 free_sorted_pointer_info_tree (spi_root
);
5723 /* Write operator interfaces associated with a symbol. */
5726 write_operator (gfc_user_op
*uop
)
5728 static char nullstring
[] = "";
5729 const char *p
= nullstring
;
5731 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5734 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5738 /* Write generic interfaces from the namespace sym_root. */
5741 write_generic (gfc_symtree
*st
)
5748 write_generic (st
->left
);
5751 if (sym
&& !check_unique_name (st
->name
)
5752 && sym
->generic
&& gfc_check_symbol_access (sym
))
5755 sym
->module
= module_name
;
5757 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5760 write_generic (st
->right
);
5765 write_symtree (gfc_symtree
*st
)
5772 /* A symbol in an interface body must not be visible in the
5774 if (sym
->ns
!= gfc_current_ns
5775 && sym
->ns
->proc_name
5776 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5779 if (!gfc_check_symbol_access (sym
)
5780 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5781 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5784 if (check_unique_name (st
->name
))
5787 p
= find_pointer (sym
);
5789 gfc_internal_error ("write_symtree(): Symbol not written");
5791 mio_pool_string (&st
->name
);
5792 mio_integer (&st
->ambiguous
);
5793 mio_integer (&p
->integer
);
5802 /* Write the operator interfaces. */
5805 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5807 if (i
== INTRINSIC_USER
)
5810 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5811 gfc_current_ns
->default_access
)
5812 ? &gfc_current_ns
->op
[i
] : NULL
);
5820 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5826 write_generic (gfc_current_ns
->sym_root
);
5832 write_blank_common ();
5833 write_common (gfc_current_ns
->common_root
);
5845 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
5846 write_derived_extensions
);
5852 write_omp_udrs (gfc_current_ns
->omp_udr_root
);
5857 /* Write symbol information. First we traverse all symbols in the
5858 primary namespace, writing those that need to be written.
5859 Sometimes writing one symbol will cause another to need to be
5860 written. A list of these symbols ends up on the write stack, and
5861 we end by popping the bottom of the stack and writing the symbol
5862 until the stack is empty. */
5866 write_symbol0 (gfc_current_ns
->sym_root
);
5867 while (write_symbol1 (pi_root
))
5876 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5881 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5882 true on success, false on failure. */
5885 read_crc32_from_module_file (const char* filename
, uLong
* crc
)
5891 /* Open the file in binary mode. */
5892 if ((file
= fopen (filename
, "rb")) == NULL
)
5895 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5896 file. See RFC 1952. */
5897 if (fseek (file
, -8, SEEK_END
) != 0)
5903 /* Read the CRC32. */
5904 if (fread (buf
, 1, 4, file
) != 4)
5910 /* Close the file. */
5913 val
= (buf
[0] & 0xFF) + ((buf
[1] & 0xFF) << 8) + ((buf
[2] & 0xFF) << 16)
5914 + ((buf
[3] & 0xFF) << 24);
5917 /* For debugging, the CRC value printed in hexadecimal should match
5918 the CRC printed by "zcat -l -v filename".
5919 printf("CRC of file %s is %x\n", filename, val); */
5925 /* Given module, dump it to disk. If there was an error while
5926 processing the module, dump_flag will be set to zero and we delete
5927 the module file, even if it was already there. */
5930 gfc_dump_module (const char *name
, int dump_flag
)
5933 char *filename
, *filename_tmp
;
5936 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5937 if (gfc_option
.module_dir
!= NULL
)
5939 n
+= strlen (gfc_option
.module_dir
);
5940 filename
= (char *) alloca (n
);
5941 strcpy (filename
, gfc_option
.module_dir
);
5942 strcat (filename
, name
);
5946 filename
= (char *) alloca (n
);
5947 strcpy (filename
, name
);
5949 strcat (filename
, MODULE_EXTENSION
);
5951 /* Name of the temporary file used to write the module. */
5952 filename_tmp
= (char *) alloca (n
+ 1);
5953 strcpy (filename_tmp
, filename
);
5954 strcat (filename_tmp
, "0");
5956 /* There was an error while processing the module. We delete the
5957 module file, even if it was already there. */
5964 if (gfc_cpp_makedep ())
5965 gfc_cpp_add_target (filename
);
5967 /* Write the module to the temporary file. */
5968 module_fp
= gzopen (filename_tmp
, "w");
5969 if (module_fp
== NULL
)
5970 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5971 filename_tmp
, xstrerror (errno
));
5973 gzprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n",
5974 MOD_VERSION
, gfc_source_file
);
5976 /* Write the module itself. */
5978 module_name
= gfc_get_string (name
);
5984 free_pi_tree (pi_root
);
5989 if (gzclose (module_fp
))
5990 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5991 filename_tmp
, xstrerror (errno
));
5993 /* Read the CRC32 from the gzip trailers of the module files and
5995 if (!read_crc32_from_module_file (filename_tmp
, &crc
)
5996 || !read_crc32_from_module_file (filename
, &crc_old
)
5999 /* Module file have changed, replace the old one. */
6000 if (rename (filename_tmp
, filename
))
6001 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
6002 filename_tmp
, filename
, xstrerror (errno
));
6006 if (unlink (filename_tmp
))
6007 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
6008 filename_tmp
, xstrerror (errno
));
6014 create_intrinsic_function (const char *name
, int id
,
6015 const char *modname
, intmod_id module
,
6016 bool subroutine
, gfc_symbol
*result_type
)
6018 gfc_intrinsic_sym
*isym
;
6019 gfc_symtree
*tmp_symtree
;
6022 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6025 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6027 gfc_error ("Symbol '%s' already declared", name
);
6030 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6031 sym
= tmp_symtree
->n
.sym
;
6035 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6036 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
6037 sym
->attr
.subroutine
= 1;
6041 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
6042 isym
= gfc_intrinsic_function_by_id (isym_id
);
6044 sym
->attr
.function
= 1;
6047 sym
->ts
.type
= BT_DERIVED
;
6048 sym
->ts
.u
.derived
= result_type
;
6049 sym
->ts
.is_c_interop
= 1;
6050 isym
->ts
.f90_type
= BT_VOID
;
6051 isym
->ts
.type
= BT_DERIVED
;
6052 isym
->ts
.f90_type
= BT_VOID
;
6053 isym
->ts
.u
.derived
= result_type
;
6054 isym
->ts
.is_c_interop
= 1;
6059 sym
->attr
.flavor
= FL_PROCEDURE
;
6060 sym
->attr
.intrinsic
= 1;
6062 sym
->module
= gfc_get_string (modname
);
6063 sym
->attr
.use_assoc
= 1;
6064 sym
->from_intmod
= module
;
6065 sym
->intmod_sym_id
= id
;
6069 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6070 the current namespace for all named constants, pointer types, and
6071 procedures in the module unless the only clause was used or a rename
6072 list was provided. */
6075 import_iso_c_binding_module (void)
6077 gfc_symbol
*mod_sym
= NULL
, *return_type
;
6078 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
6079 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
6080 const char *iso_c_module_name
= "__iso_c_binding";
6083 bool want_c_ptr
= false, want_c_funptr
= false;
6085 /* Look only in the current namespace. */
6086 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
6088 if (mod_symtree
== NULL
)
6090 /* symtree doesn't already exist in current namespace. */
6091 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
6094 if (mod_symtree
!= NULL
)
6095 mod_sym
= mod_symtree
->n
.sym
;
6097 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6098 "create symbol for %s", iso_c_module_name
);
6100 mod_sym
->attr
.flavor
= FL_MODULE
;
6101 mod_sym
->attr
.intrinsic
= 1;
6102 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
6103 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
6106 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6107 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6109 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6111 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
6114 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
6117 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
6119 want_c_funptr
= true;
6120 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
6122 want_c_funptr
= true;
6123 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
6126 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6127 (iso_c_binding_symbol
)
6129 u
->local_name
[0] ? u
->local_name
6133 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
6137 = generate_isocbinding_symbol (iso_c_module_name
,
6138 (iso_c_binding_symbol
)
6140 u
->local_name
[0] ? u
->local_name
6146 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
6147 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
6148 (iso_c_binding_symbol
)
6150 NULL
, NULL
, only_flag
);
6151 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
6152 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
6153 (iso_c_binding_symbol
)
6155 NULL
, NULL
, only_flag
);
6157 /* Generate the symbols for the named constants representing
6158 the kinds for intrinsic data types. */
6159 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
6162 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6163 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
6172 #define NAMED_FUNCTION(a,b,c,d) \
6174 not_in_std = (gfc_option.allow_std & d) == 0; \
6177 #define NAMED_SUBROUTINE(a,b,c,d) \
6179 not_in_std = (gfc_option.allow_std & d) == 0; \
6182 #define NAMED_INTCST(a,b,c,d) \
6184 not_in_std = (gfc_option.allow_std & d) == 0; \
6187 #define NAMED_REALCST(a,b,c,d) \
6189 not_in_std = (gfc_option.allow_std & d) == 0; \
6192 #define NAMED_CMPXCST(a,b,c,d) \
6194 not_in_std = (gfc_option.allow_std & d) == 0; \
6197 #include "iso-c-binding.def"
6205 gfc_error ("The symbol '%s', referenced at %L, is not "
6206 "in the selected standard", name
, &u
->where
);
6212 #define NAMED_FUNCTION(a,b,c,d) \
6214 if (a == ISOCBINDING_LOC) \
6215 return_type = c_ptr->n.sym; \
6216 else if (a == ISOCBINDING_FUNLOC) \
6217 return_type = c_funptr->n.sym; \
6219 return_type = NULL; \
6220 create_intrinsic_function (u->local_name[0] \
6221 ? u->local_name : u->use_name, \
6222 a, iso_c_module_name, \
6223 INTMOD_ISO_C_BINDING, false, \
6226 #define NAMED_SUBROUTINE(a,b,c,d) \
6228 create_intrinsic_function (u->local_name[0] ? u->local_name \
6230 a, iso_c_module_name, \
6231 INTMOD_ISO_C_BINDING, true, NULL); \
6233 #include "iso-c-binding.def"
6235 case ISOCBINDING_PTR
:
6236 case ISOCBINDING_FUNPTR
:
6237 /* Already handled above. */
6240 if (i
== ISOCBINDING_NULL_PTR
)
6241 tmp_symtree
= c_ptr
;
6242 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6243 tmp_symtree
= c_funptr
;
6246 generate_isocbinding_symbol (iso_c_module_name
,
6247 (iso_c_binding_symbol
) i
,
6249 ? u
->local_name
: u
->use_name
,
6250 tmp_symtree
, false);
6254 if (!found
&& !only_flag
)
6256 /* Skip, if the symbol is not in the enabled standard. */
6259 #define NAMED_FUNCTION(a,b,c,d) \
6261 if ((gfc_option.allow_std & d) == 0) \
6264 #define NAMED_SUBROUTINE(a,b,c,d) \
6266 if ((gfc_option.allow_std & d) == 0) \
6269 #define NAMED_INTCST(a,b,c,d) \
6271 if ((gfc_option.allow_std & d) == 0) \
6274 #define NAMED_REALCST(a,b,c,d) \
6276 if ((gfc_option.allow_std & d) == 0) \
6279 #define NAMED_CMPXCST(a,b,c,d) \
6281 if ((gfc_option.allow_std & d) == 0) \
6284 #include "iso-c-binding.def"
6286 ; /* Not GFC_STD_* versioned. */
6291 #define NAMED_FUNCTION(a,b,c,d) \
6293 if (a == ISOCBINDING_LOC) \
6294 return_type = c_ptr->n.sym; \
6295 else if (a == ISOCBINDING_FUNLOC) \
6296 return_type = c_funptr->n.sym; \
6298 return_type = NULL; \
6299 create_intrinsic_function (b, a, iso_c_module_name, \
6300 INTMOD_ISO_C_BINDING, false, \
6303 #define NAMED_SUBROUTINE(a,b,c,d) \
6305 create_intrinsic_function (b, a, iso_c_module_name, \
6306 INTMOD_ISO_C_BINDING, true, NULL); \
6308 #include "iso-c-binding.def"
6310 case ISOCBINDING_PTR
:
6311 case ISOCBINDING_FUNPTR
:
6312 /* Already handled above. */
6315 if (i
== ISOCBINDING_NULL_PTR
)
6316 tmp_symtree
= c_ptr
;
6317 else if (i
== ISOCBINDING_NULL_FUNPTR
)
6318 tmp_symtree
= c_funptr
;
6321 generate_isocbinding_symbol (iso_c_module_name
,
6322 (iso_c_binding_symbol
) i
, NULL
,
6323 tmp_symtree
, false);
6328 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6333 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6334 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
6339 /* Add an integer named constant from a given module. */
6342 create_int_parameter (const char *name
, int value
, const char *modname
,
6343 intmod_id module
, int id
)
6345 gfc_symtree
*tmp_symtree
;
6348 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6349 if (tmp_symtree
!= NULL
)
6351 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6354 gfc_error ("Symbol '%s' already declared", name
);
6357 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6358 sym
= tmp_symtree
->n
.sym
;
6360 sym
->module
= gfc_get_string (modname
);
6361 sym
->attr
.flavor
= FL_PARAMETER
;
6362 sym
->ts
.type
= BT_INTEGER
;
6363 sym
->ts
.kind
= gfc_default_integer_kind
;
6364 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
6365 sym
->attr
.use_assoc
= 1;
6366 sym
->from_intmod
= module
;
6367 sym
->intmod_sym_id
= id
;
6371 /* Value is already contained by the array constructor, but not
6375 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
6376 const char *modname
, intmod_id module
, int id
)
6378 gfc_symtree
*tmp_symtree
;
6381 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6382 if (tmp_symtree
!= NULL
)
6384 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6387 gfc_error ("Symbol '%s' already declared", name
);
6390 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6391 sym
= tmp_symtree
->n
.sym
;
6393 sym
->module
= gfc_get_string (modname
);
6394 sym
->attr
.flavor
= FL_PARAMETER
;
6395 sym
->ts
.type
= BT_INTEGER
;
6396 sym
->ts
.kind
= gfc_default_integer_kind
;
6397 sym
->attr
.use_assoc
= 1;
6398 sym
->from_intmod
= module
;
6399 sym
->intmod_sym_id
= id
;
6400 sym
->attr
.dimension
= 1;
6401 sym
->as
= gfc_get_array_spec ();
6403 sym
->as
->type
= AS_EXPLICIT
;
6404 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
6405 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
6408 sym
->value
->shape
= gfc_get_shape (1);
6409 mpz_init_set_ui (sym
->value
->shape
[0], size
);
6413 /* Add an derived type for a given module. */
6416 create_derived_type (const char *name
, const char *modname
,
6417 intmod_id module
, int id
)
6419 gfc_symtree
*tmp_symtree
;
6420 gfc_symbol
*sym
, *dt_sym
;
6421 gfc_interface
*intr
, *head
;
6423 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
6424 if (tmp_symtree
!= NULL
)
6426 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
6429 gfc_error ("Symbol '%s' already declared", name
);
6432 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
6433 sym
= tmp_symtree
->n
.sym
;
6434 sym
->module
= gfc_get_string (modname
);
6435 sym
->from_intmod
= module
;
6436 sym
->intmod_sym_id
= id
;
6437 sym
->attr
.flavor
= FL_PROCEDURE
;
6438 sym
->attr
.function
= 1;
6439 sym
->attr
.generic
= 1;
6441 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6442 gfc_current_ns
, &tmp_symtree
, false);
6443 dt_sym
= tmp_symtree
->n
.sym
;
6444 dt_sym
->name
= gfc_get_string (sym
->name
);
6445 dt_sym
->attr
.flavor
= FL_DERIVED
;
6446 dt_sym
->attr
.private_comp
= 1;
6447 dt_sym
->attr
.zero_comp
= 1;
6448 dt_sym
->attr
.use_assoc
= 1;
6449 dt_sym
->module
= gfc_get_string (modname
);
6450 dt_sym
->from_intmod
= module
;
6451 dt_sym
->intmod_sym_id
= id
;
6453 head
= sym
->generic
;
6454 intr
= gfc_get_interface ();
6456 intr
->where
= gfc_current_locus
;
6458 sym
->generic
= intr
;
6459 sym
->attr
.if_source
= IFSRC_DECL
;
6463 /* Read the contents of the module file into a temporary buffer. */
6466 read_module_to_tmpbuf ()
6468 /* We don't know the uncompressed size, so enlarge the buffer as
6474 module_content
= XNEWVEC (char, cursz
);
6478 int nread
= gzread (module_fp
, module_content
+ len
, rsize
);
6483 module_content
= XRESIZEVEC (char, module_content
, cursz
);
6484 rsize
= cursz
- len
;
6487 module_content
= XRESIZEVEC (char, module_content
, len
+ 1);
6488 module_content
[len
] = '\0';
6494 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6497 use_iso_fortran_env_module (void)
6499 static char mod
[] = "iso_fortran_env";
6501 gfc_symbol
*mod_sym
;
6502 gfc_symtree
*mod_symtree
;
6506 intmod_sym symbol
[] = {
6507 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6508 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6509 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6510 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6511 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6512 #include "iso-fortran-env.def"
6513 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6516 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6517 #include "iso-fortran-env.def"
6519 /* Generate the symbol for the module itself. */
6520 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6521 if (mod_symtree
== NULL
)
6523 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6524 gcc_assert (mod_symtree
);
6525 mod_sym
= mod_symtree
->n
.sym
;
6527 mod_sym
->attr
.flavor
= FL_MODULE
;
6528 mod_sym
->attr
.intrinsic
= 1;
6529 mod_sym
->module
= gfc_get_string (mod
);
6530 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6533 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6534 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
6535 "non-intrinsic module name used previously", mod
);
6537 /* Generate the symbols for the module integer named constants. */
6539 for (i
= 0; symbol
[i
].name
; i
++)
6542 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6544 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6549 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
6550 "referenced at %L, is not in the selected "
6551 "standard", symbol
[i
].name
, &u
->where
))
6554 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6555 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6556 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
6557 "constant from intrinsic module "
6558 "ISO_FORTRAN_ENV at %L is incompatible with "
6559 "option %s", &u
->where
,
6560 gfc_option
.flag_default_integer
6561 ? "-fdefault-integer-8"
6562 : "-fdefault-real-8");
6563 switch (symbol
[i
].id
)
6565 #define NAMED_INTCST(a,b,c,d) \
6567 #include "iso-fortran-env.def"
6568 create_int_parameter (u
->local_name
[0] ? u
->local_name
6570 symbol
[i
].value
, mod
,
6571 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6574 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6576 expr = gfc_get_array_expr (BT_INTEGER, \
6577 gfc_default_integer_kind,\
6579 for (j = 0; KINDS[j].kind != 0; j++) \
6580 gfc_constructor_append_expr (&expr->value.constructor, \
6581 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6582 KINDS[j].kind), NULL); \
6583 create_int_parameter_array (u->local_name[0] ? u->local_name \
6586 INTMOD_ISO_FORTRAN_ENV, \
6589 #include "iso-fortran-env.def"
6591 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6593 #include "iso-fortran-env.def"
6594 create_derived_type (u
->local_name
[0] ? u
->local_name
6596 mod
, INTMOD_ISO_FORTRAN_ENV
,
6600 #define NAMED_FUNCTION(a,b,c,d) \
6602 #include "iso-fortran-env.def"
6603 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6606 INTMOD_ISO_FORTRAN_ENV
, false,
6616 if (!found
&& !only_flag
)
6618 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6621 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6622 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6623 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6624 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6625 "incompatible with option %s",
6626 gfc_option
.flag_default_integer
6627 ? "-fdefault-integer-8" : "-fdefault-real-8");
6629 switch (symbol
[i
].id
)
6631 #define NAMED_INTCST(a,b,c,d) \
6633 #include "iso-fortran-env.def"
6634 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6635 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6638 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6640 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6642 for (j = 0; KINDS[j].kind != 0; j++) \
6643 gfc_constructor_append_expr (&expr->value.constructor, \
6644 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6645 KINDS[j].kind), NULL); \
6646 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6647 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6649 #include "iso-fortran-env.def"
6651 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6653 #include "iso-fortran-env.def"
6654 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6658 #define NAMED_FUNCTION(a,b,c,d) \
6660 #include "iso-fortran-env.def"
6661 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6662 INTMOD_ISO_FORTRAN_ENV
, false,
6672 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6677 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6678 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6683 /* Process a USE directive. */
6686 gfc_use_module (gfc_use_list
*module
)
6691 gfc_symtree
*mod_symtree
;
6692 gfc_use_list
*use_stmt
;
6693 locus old_locus
= gfc_current_locus
;
6695 gfc_current_locus
= module
->where
;
6696 module_name
= module
->module_name
;
6697 gfc_rename_list
= module
->rename
;
6698 only_flag
= module
->only_flag
;
6700 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6702 strcpy (filename
, module_name
);
6703 strcat (filename
, MODULE_EXTENSION
);
6705 /* First, try to find an non-intrinsic module, unless the USE statement
6706 specified that the module is intrinsic. */
6708 if (!module
->intrinsic
)
6709 module_fp
= gzopen_included_file (filename
, true, true);
6711 /* Then, see if it's an intrinsic one, unless the USE statement
6712 specified that the module is non-intrinsic. */
6713 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6715 if (strcmp (module_name
, "iso_fortran_env") == 0
6716 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6717 "intrinsic module at %C"))
6719 use_iso_fortran_env_module ();
6720 free_rename (module
->rename
);
6721 module
->rename
= NULL
;
6722 gfc_current_locus
= old_locus
;
6723 module
->intrinsic
= true;
6727 if (strcmp (module_name
, "iso_c_binding") == 0
6728 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6730 import_iso_c_binding_module();
6731 free_rename (module
->rename
);
6732 module
->rename
= NULL
;
6733 gfc_current_locus
= old_locus
;
6734 module
->intrinsic
= true;
6738 module_fp
= gzopen_intrinsic_module (filename
);
6740 if (module_fp
== NULL
&& module
->intrinsic
)
6741 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6745 if (module_fp
== NULL
)
6746 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6747 filename
, xstrerror (errno
));
6749 /* Check that we haven't already USEd an intrinsic module with the
6752 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6753 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6754 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6755 "intrinsic module name used previously", module_name
);
6762 read_module_to_tmpbuf ();
6763 gzclose (module_fp
);
6765 /* Skip the first line of the module, after checking that this is
6766 a gfortran module file. */
6772 bad_module ("Unexpected end of module");
6775 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6776 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6777 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6778 " module file", filename
);
6781 if (strcmp (atom_name
, " version") != 0
6782 || module_char () != ' '
6783 || parse_atom () != ATOM_STRING
6784 || strcmp (atom_string
, MOD_VERSION
))
6785 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6786 " because it was created by a different"
6787 " version of GNU Fortran", filename
);
6796 /* Make sure we're not reading the same module that we may be building. */
6797 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6798 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6799 gfc_fatal_error ("Can't USE the same module we're building!");
6802 init_true_name_tree ();
6806 free_true_name (true_name_root
);
6807 true_name_root
= NULL
;
6809 free_pi_tree (pi_root
);
6812 XDELETEVEC (module_content
);
6813 module_content
= NULL
;
6815 use_stmt
= gfc_get_use_list ();
6816 *use_stmt
= *module
;
6817 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6818 gfc_current_ns
->use_stmts
= use_stmt
;
6820 gfc_current_locus
= old_locus
;
6824 /* Remove duplicated intrinsic operators from the rename list. */
6827 rename_list_remove_duplicate (gfc_use_rename
*list
)
6829 gfc_use_rename
*seek
, *last
;
6831 for (; list
; list
= list
->next
)
6832 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6835 for (seek
= list
->next
; seek
; seek
= last
->next
)
6837 if (list
->op
== seek
->op
)
6839 last
->next
= seek
->next
;
6849 /* Process all USE directives. */
6852 gfc_use_modules (void)
6854 gfc_use_list
*next
, *seek
, *last
;
6856 for (next
= module_list
; next
; next
= next
->next
)
6858 bool non_intrinsic
= next
->non_intrinsic
;
6859 bool intrinsic
= next
->intrinsic
;
6860 bool neither
= !non_intrinsic
&& !intrinsic
;
6862 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6864 if (next
->module_name
!= seek
->module_name
)
6867 if (seek
->non_intrinsic
)
6868 non_intrinsic
= true;
6869 else if (seek
->intrinsic
)
6875 if (intrinsic
&& neither
&& !non_intrinsic
)
6880 filename
= XALLOCAVEC (char,
6881 strlen (next
->module_name
)
6882 + strlen (MODULE_EXTENSION
) + 1);
6883 strcpy (filename
, next
->module_name
);
6884 strcat (filename
, MODULE_EXTENSION
);
6885 fp
= gfc_open_included_file (filename
, true, true);
6888 non_intrinsic
= true;
6894 for (seek
= next
->next
; seek
; seek
= last
->next
)
6896 if (next
->module_name
!= seek
->module_name
)
6902 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6903 || (next
->intrinsic
&& seek
->intrinsic
)
6906 if (!seek
->only_flag
)
6907 next
->only_flag
= false;
6910 gfc_use_rename
*r
= seek
->rename
;
6913 r
->next
= next
->rename
;
6914 next
->rename
= seek
->rename
;
6916 last
->next
= seek
->next
;
6924 for (; module_list
; module_list
= next
)
6926 next
= module_list
->next
;
6927 rename_list_remove_duplicate (module_list
->rename
);
6928 gfc_use_module (module_list
);
6931 gfc_rename_list
= NULL
;
6936 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6939 for (; use_stmts
; use_stmts
= next
)
6941 gfc_use_rename
*next_rename
;
6943 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6945 next_rename
= use_stmts
->rename
->next
;
6946 free (use_stmts
->rename
);
6948 next
= use_stmts
->next
;
6955 gfc_module_init_2 (void)
6957 last_atom
= ATOM_LPAREN
;
6958 gfc_rename_list
= NULL
;
6964 gfc_module_done_2 (void)
6966 free_rename (gfc_rename_list
);
6967 gfc_rename_list
= NULL
;