1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
5 Free Software Foundation, Inc.
6 Contributed by Andy Vaught
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
53 ( <Symbol Number (in no particular order)>
55 <Module name of symbol>
56 ( <symbol information> )
65 In general, symbols refer to other symbols by their symbol number,
66 which are zero based. Symbols are written to the module in no
71 #include "coretypes.h"
75 #include "parse.h" /* FIXME */
77 #include "constructor.h"
81 #define MODULE_EXTENSION ".mod"
83 /* Don't put any single quote (') in MOD_VERSION,
84 if yout want it to be recognized. */
85 #define MOD_VERSION "9"
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 FILE for the module we're reading or writing. */
186 static FILE *module_fp
;
188 /* MD5 context structure. */
189 static struct md5_ctx ctx
;
191 /* The name of the module we're reading (USE'ing) or writing. */
192 static const char *module_name
;
193 static gfc_use_list
*module_list
;
195 static int module_line
, module_column
, only_flag
;
196 static int prev_module_line
, prev_module_column
, prev_character
;
199 { IO_INPUT
, IO_OUTPUT
}
202 static gfc_use_rename
*gfc_rename_list
;
203 static pointer_info
*pi_root
;
204 static int symbol_number
; /* Counter for assigning symbol numbers */
206 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
207 static bool in_load_equiv
;
211 /*****************************************************************/
213 /* Pointer/integer conversion. Pointers between structures are stored
214 as integers in the module file. The next couple of subroutines
215 handle this translation for reading and writing. */
217 /* Recursively free the tree of pointer structures. */
220 free_pi_tree (pointer_info
*p
)
225 if (p
->fixup
!= NULL
)
226 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
228 free_pi_tree (p
->left
);
229 free_pi_tree (p
->right
);
231 if (iomode
== IO_INPUT
)
233 XDELETEVEC (p
->u
.rsym
.true_name
);
234 XDELETEVEC (p
->u
.rsym
.module
);
235 XDELETEVEC (p
->u
.rsym
.binding_label
);
242 /* Compare pointers when searching by pointer. Used when writing a
246 compare_pointers (void *_sn1
, void *_sn2
)
248 pointer_info
*sn1
, *sn2
;
250 sn1
= (pointer_info
*) _sn1
;
251 sn2
= (pointer_info
*) _sn2
;
253 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
255 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
262 /* Compare integers when searching by integer. Used when reading a
266 compare_integers (void *_sn1
, void *_sn2
)
268 pointer_info
*sn1
, *sn2
;
270 sn1
= (pointer_info
*) _sn1
;
271 sn2
= (pointer_info
*) _sn2
;
273 if (sn1
->integer
< sn2
->integer
)
275 if (sn1
->integer
> sn2
->integer
)
282 /* Initialize the pointer_info tree. */
291 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
293 /* Pointer 0 is the NULL pointer. */
294 p
= gfc_get_pointer_info ();
299 gfc_insert_bbt (&pi_root
, p
, compare
);
301 /* Pointer 1 is the current namespace. */
302 p
= gfc_get_pointer_info ();
303 p
->u
.pointer
= gfc_current_ns
;
305 p
->type
= P_NAMESPACE
;
307 gfc_insert_bbt (&pi_root
, p
, compare
);
313 /* During module writing, call here with a pointer to something,
314 returning the pointer_info node. */
316 static pointer_info
*
317 find_pointer (void *gp
)
324 if (p
->u
.pointer
== gp
)
326 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
333 /* Given a pointer while writing, returns the pointer_info tree node,
334 creating it if it doesn't exist. */
336 static pointer_info
*
337 get_pointer (void *gp
)
341 p
= find_pointer (gp
);
345 /* Pointer doesn't have an integer. Give it one. */
346 p
= gfc_get_pointer_info ();
349 p
->integer
= symbol_number
++;
351 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
357 /* Given an integer during reading, find it in the pointer_info tree,
358 creating the node if not found. */
360 static pointer_info
*
361 get_integer (int integer
)
371 c
= compare_integers (&t
, p
);
375 p
= (c
< 0) ? p
->left
: p
->right
;
381 p
= gfc_get_pointer_info ();
382 p
->integer
= integer
;
385 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
391 /* Recursive function to find a pointer within a tree by brute force. */
393 static pointer_info
*
394 fp2 (pointer_info
*p
, const void *target
)
401 if (p
->u
.pointer
== target
)
404 q
= fp2 (p
->left
, target
);
408 return fp2 (p
->right
, target
);
412 /* During reading, find a pointer_info node from the pointer value.
413 This amounts to a brute-force search. */
415 static pointer_info
*
416 find_pointer2 (void *p
)
418 return fp2 (pi_root
, p
);
422 /* Resolve any fixups using a known pointer. */
425 resolve_fixups (fixup_t
*f
, void *gp
)
438 /* Convert a string such that it starts with a lower-case character. Used
439 to convert the symtree name of a derived-type to the symbol name or to
440 the name of the associated generic function. */
443 dt_lower_string (const char *name
)
445 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
446 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
448 return gfc_get_string (name
);
452 /* Convert a string such that it starts with an upper-case character. Used to
453 return the symtree-name for a derived type; the symbol name itself and the
454 symtree/symbol name of the associated generic function start with a lower-
458 dt_upper_string (const char *name
)
460 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
461 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
463 return gfc_get_string (name
);
466 /* Call here during module reading when we know what pointer to
467 associate with an integer. Any fixups that exist are resolved at
471 associate_integer_pointer (pointer_info
*p
, void *gp
)
473 if (p
->u
.pointer
!= NULL
)
474 gfc_internal_error ("associate_integer_pointer(): Already associated");
478 resolve_fixups (p
->fixup
, gp
);
484 /* During module reading, given an integer and a pointer to a pointer,
485 either store the pointer from an already-known value or create a
486 fixup structure in order to store things later. Returns zero if
487 the reference has been actually stored, or nonzero if the reference
488 must be fixed later (i.e., associate_integer_pointer must be called
489 sometime later. Returns the pointer_info structure. */
491 static pointer_info
*
492 add_fixup (int integer
, void *gp
)
498 p
= get_integer (integer
);
500 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
503 *cp
= (char *) p
->u
.pointer
;
512 f
->pointer
= (void **) gp
;
519 /*****************************************************************/
521 /* Parser related subroutines */
523 /* Free the rename list left behind by a USE statement. */
526 free_rename (gfc_use_rename
*list
)
528 gfc_use_rename
*next
;
530 for (; list
; list
= next
)
538 /* Match a USE statement. */
543 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
544 gfc_use_rename
*tail
= NULL
, *new_use
;
545 interface_type type
, type2
;
548 gfc_use_list
*use_list
;
550 use_list
= gfc_get_use_list ();
552 if (gfc_match (" , ") == MATCH_YES
)
554 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
556 if (gfc_notify_std (GFC_STD_F2003
, "module "
557 "nature in USE statement at %C") == FAILURE
)
560 if (strcmp (module_nature
, "intrinsic") == 0)
561 use_list
->intrinsic
= true;
564 if (strcmp (module_nature
, "non_intrinsic") == 0)
565 use_list
->non_intrinsic
= true;
568 gfc_error ("Module nature in USE statement at %C shall "
569 "be either INTRINSIC or NON_INTRINSIC");
576 /* Help output a better error message than "Unclassifiable
578 gfc_match (" %n", module_nature
);
579 if (strcmp (module_nature
, "intrinsic") == 0
580 || strcmp (module_nature
, "non_intrinsic") == 0)
581 gfc_error ("\"::\" was expected after module nature at %C "
582 "but was not found");
589 m
= gfc_match (" ::");
590 if (m
== MATCH_YES
&&
591 gfc_notify_std (GFC_STD_F2003
,
592 "\"USE :: module\" at %C") == FAILURE
)
597 m
= gfc_match ("% ");
606 use_list
->where
= gfc_current_locus
;
608 m
= gfc_match_name (name
);
615 use_list
->module_name
= gfc_get_string (name
);
617 if (gfc_match_eos () == MATCH_YES
)
620 if (gfc_match_char (',') != MATCH_YES
)
623 if (gfc_match (" only :") == MATCH_YES
)
624 use_list
->only_flag
= true;
626 if (gfc_match_eos () == MATCH_YES
)
631 /* Get a new rename struct and add it to the rename list. */
632 new_use
= gfc_get_use_rename ();
633 new_use
->where
= gfc_current_locus
;
636 if (use_list
->rename
== NULL
)
637 use_list
->rename
= new_use
;
639 tail
->next
= new_use
;
642 /* See what kind of interface we're dealing with. Assume it is
644 new_use
->op
= INTRINSIC_NONE
;
645 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
650 case INTERFACE_NAMELESS
:
651 gfc_error ("Missing generic specification in USE statement at %C");
654 case INTERFACE_USER_OP
:
655 case INTERFACE_GENERIC
:
656 m
= gfc_match (" =>");
658 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
659 && (gfc_notify_std (GFC_STD_F2003
, "Renaming "
660 "operators in USE statements at %C")
664 if (type
== INTERFACE_USER_OP
)
665 new_use
->op
= INTRINSIC_USER
;
667 if (use_list
->only_flag
)
670 strcpy (new_use
->use_name
, name
);
673 strcpy (new_use
->local_name
, name
);
674 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
679 if (m
== MATCH_ERROR
)
687 strcpy (new_use
->local_name
, name
);
689 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
694 if (m
== MATCH_ERROR
)
698 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
699 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
701 gfc_error ("The name '%s' at %C has already been used as "
702 "an external module name.", use_list
->module_name
);
707 case INTERFACE_INTRINSIC_OP
:
715 if (gfc_match_eos () == MATCH_YES
)
717 if (gfc_match_char (',') != MATCH_YES
)
724 gfc_use_list
*last
= module_list
;
727 last
->next
= use_list
;
730 module_list
= use_list
;
735 gfc_syntax_error (ST_USE
);
738 free_rename (use_list
->rename
);
744 /* Given a name and a number, inst, return the inst name
745 under which to load this symbol. Returns NULL if this
746 symbol shouldn't be loaded. If inst is zero, returns
747 the number of instances of this name. If interface is
748 true, a user-defined operator is sought, otherwise only
749 non-operators are sought. */
752 find_use_name_n (const char *name
, int *inst
, bool interface
)
755 const char *low_name
= NULL
;
758 /* For derived types. */
759 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
760 low_name
= dt_lower_string (name
);
763 for (u
= gfc_rename_list
; u
; u
= u
->next
)
765 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
766 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
767 || (u
->op
== INTRINSIC_USER
&& !interface
)
768 || (u
->op
!= INTRINSIC_USER
&& interface
))
781 return only_flag
? NULL
: name
;
787 if (u
->local_name
[0] == '\0')
789 return dt_upper_string (u
->local_name
);
792 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
796 /* Given a name, return the name under which to load this symbol.
797 Returns NULL if this symbol shouldn't be loaded. */
800 find_use_name (const char *name
, bool interface
)
803 return find_use_name_n (name
, &i
, interface
);
807 /* Given a real name, return the number of use names associated with it. */
810 number_use_names (const char *name
, bool interface
)
813 find_use_name_n (name
, &i
, interface
);
818 /* Try to find the operator in the current list. */
820 static gfc_use_rename
*
821 find_use_operator (gfc_intrinsic_op op
)
825 for (u
= gfc_rename_list
; u
; u
= u
->next
)
833 /*****************************************************************/
835 /* The next couple of subroutines maintain a tree used to avoid a
836 brute-force search for a combination of true name and module name.
837 While symtree names, the name that a particular symbol is known by
838 can changed with USE statements, we still have to keep track of the
839 true names to generate the correct reference, and also avoid
840 loading the same real symbol twice in a program unit.
842 When we start reading, the true name tree is built and maintained
843 as symbols are read. The tree is searched as we load new symbols
844 to see if it already exists someplace in the namespace. */
846 typedef struct true_name
848 BBT_HEADER (true_name
);
854 static true_name
*true_name_root
;
857 /* Compare two true_name structures. */
860 compare_true_names (void *_t1
, void *_t2
)
865 t1
= (true_name
*) _t1
;
866 t2
= (true_name
*) _t2
;
868 c
= ((t1
->sym
->module
> t2
->sym
->module
)
869 - (t1
->sym
->module
< t2
->sym
->module
));
873 return strcmp (t1
->name
, t2
->name
);
877 /* Given a true name, search the true name tree to see if it exists
878 within the main namespace. */
881 find_true_name (const char *name
, const char *module
)
887 t
.name
= gfc_get_string (name
);
889 sym
.module
= gfc_get_string (module
);
897 c
= compare_true_names ((void *) (&t
), (void *) p
);
901 p
= (c
< 0) ? p
->left
: p
->right
;
908 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
911 add_true_name (gfc_symbol
*sym
)
915 t
= XCNEW (true_name
);
917 if (sym
->attr
.flavor
== FL_DERIVED
)
918 t
->name
= dt_upper_string (sym
->name
);
922 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
926 /* Recursive function to build the initial true name tree by
927 recursively traversing the current namespace. */
930 build_tnt (gfc_symtree
*st
)
936 build_tnt (st
->left
);
937 build_tnt (st
->right
);
939 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
940 name
= dt_upper_string (st
->n
.sym
->name
);
942 name
= st
->n
.sym
->name
;
944 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
947 add_true_name (st
->n
.sym
);
951 /* Initialize the true name tree with the current namespace. */
954 init_true_name_tree (void)
956 true_name_root
= NULL
;
957 build_tnt (gfc_current_ns
->sym_root
);
961 /* Recursively free a true name tree node. */
964 free_true_name (true_name
*t
)
968 free_true_name (t
->left
);
969 free_true_name (t
->right
);
975 /*****************************************************************/
977 /* Module reading and writing. */
981 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
985 static atom_type last_atom
;
988 /* The name buffer must be at least as long as a symbol name. Right
989 now it's not clear how we're going to store numeric constants--
990 probably as a hexadecimal string, since this will allow the exact
991 number to be preserved (this can't be done by a decimal
992 representation). Worry about that later. TODO! */
994 #define MAX_ATOM_SIZE 100
997 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1000 /* Report problems with a module. Error reporting is not very
1001 elaborate, since this sorts of errors shouldn't really happen.
1002 This subroutine never returns. */
1004 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1007 bad_module (const char *msgid
)
1014 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1015 module_name
, module_line
, module_column
, msgid
);
1018 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1019 module_name
, module_line
, module_column
, msgid
);
1022 gfc_fatal_error ("Module %s at line %d column %d: %s",
1023 module_name
, module_line
, module_column
, msgid
);
1029 /* Set the module's input pointer. */
1032 set_module_locus (module_locus
*m
)
1034 module_column
= m
->column
;
1035 module_line
= m
->line
;
1036 fsetpos (module_fp
, &m
->pos
);
1040 /* Get the module's input pointer so that we can restore it later. */
1043 get_module_locus (module_locus
*m
)
1045 m
->column
= module_column
;
1046 m
->line
= module_line
;
1047 fgetpos (module_fp
, &m
->pos
);
1051 /* Get the next character in the module, updating our reckoning of
1059 c
= getc (module_fp
);
1062 bad_module ("Unexpected EOF");
1064 prev_module_line
= module_line
;
1065 prev_module_column
= module_column
;
1078 /* Unget a character while remembering the line and column. Works for
1079 a single character only. */
1082 module_unget_char (void)
1084 module_line
= prev_module_line
;
1085 module_column
= prev_module_column
;
1086 ungetc (prev_character
, module_fp
);
1089 /* Parse a string constant. The delimiter is guaranteed to be a
1099 atom_string
= XNEWVEC (char, cursz
);
1107 int c2
= module_char ();
1110 module_unget_char ();
1118 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1120 atom_string
[len
] = c
;
1124 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1125 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1129 /* Parse a small integer. */
1132 parse_integer (int c
)
1141 module_unget_char ();
1145 atom_int
= 10 * atom_int
+ c
- '0';
1146 if (atom_int
> 99999999)
1147 bad_module ("Integer overflow");
1169 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1171 module_unget_char ();
1176 if (++len
> GFC_MAX_SYMBOL_LEN
)
1177 bad_module ("Name too long");
1185 /* Read the next atom in the module's input stream. */
1196 while (c
== ' ' || c
== '\r' || c
== '\n');
1221 return ATOM_INTEGER
;
1279 bad_module ("Bad name");
1286 /* Peek at the next atom on the input. */
1297 while (c
== ' ' || c
== '\r' || c
== '\n');
1302 module_unget_char ();
1306 module_unget_char ();
1310 module_unget_char ();
1323 module_unget_char ();
1324 return ATOM_INTEGER
;
1378 module_unget_char ();
1382 bad_module ("Bad name");
1387 /* Read the next atom from the input, requiring that it be a
1391 require_atom (atom_type type
)
1397 column
= module_column
;
1406 p
= _("Expected name");
1409 p
= _("Expected left parenthesis");
1412 p
= _("Expected right parenthesis");
1415 p
= _("Expected integer");
1418 p
= _("Expected string");
1421 gfc_internal_error ("require_atom(): bad atom type required");
1424 module_column
= column
;
1431 /* Given a pointer to an mstring array, require that the current input
1432 be one of the strings in the array. We return the enum value. */
1435 find_enum (const mstring
*m
)
1439 i
= gfc_string2code (m
, atom_name
);
1443 bad_module ("find_enum(): Enum not found");
1449 /* Read a string. The caller is responsible for freeing. */
1455 require_atom (ATOM_STRING
);
1462 /**************** Module output subroutines ***************************/
1464 /* Output a character to a module file. */
1467 write_char (char out
)
1469 if (putc (out
, module_fp
) == EOF
)
1470 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1472 /* Add this to our MD5. */
1473 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1485 /* Write an atom to a module. The line wrapping isn't perfect, but it
1486 should work most of the time. This isn't that big of a deal, since
1487 the file really isn't meant to be read by people anyway. */
1490 write_atom (atom_type atom
, const void *v
)
1500 p
= (const char *) v
;
1512 i
= *((const int *) v
);
1514 gfc_internal_error ("write_atom(): Writing negative integer");
1516 sprintf (buffer
, "%d", i
);
1521 gfc_internal_error ("write_atom(): Trying to write dab atom");
1525 if(p
== NULL
|| *p
== '\0')
1530 if (atom
!= ATOM_RPAREN
)
1532 if (module_column
+ len
> 72)
1537 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1542 if (atom
== ATOM_STRING
)
1545 while (p
!= NULL
&& *p
)
1547 if (atom
== ATOM_STRING
&& *p
== '\'')
1552 if (atom
== ATOM_STRING
)
1560 /***************** Mid-level I/O subroutines *****************/
1562 /* These subroutines let their caller read or write atoms without
1563 caring about which of the two is actually happening. This lets a
1564 subroutine concentrate on the actual format of the data being
1567 static void mio_expr (gfc_expr
**);
1568 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1569 pointer_info
*mio_interface_rest (gfc_interface
**);
1570 static void mio_symtree_ref (gfc_symtree
**);
1572 /* Read or write an enumerated value. On writing, we return the input
1573 value for the convenience of callers. We avoid using an integer
1574 pointer because enums are sometimes inside bitfields. */
1577 mio_name (int t
, const mstring
*m
)
1579 if (iomode
== IO_OUTPUT
)
1580 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1583 require_atom (ATOM_NAME
);
1590 /* Specialization of mio_name. */
1592 #define DECL_MIO_NAME(TYPE) \
1593 static inline TYPE \
1594 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1596 return (TYPE) mio_name ((int) t, m); \
1598 #define MIO_NAME(TYPE) mio_name_##TYPE
1603 if (iomode
== IO_OUTPUT
)
1604 write_atom (ATOM_LPAREN
, NULL
);
1606 require_atom (ATOM_LPAREN
);
1613 if (iomode
== IO_OUTPUT
)
1614 write_atom (ATOM_RPAREN
, NULL
);
1616 require_atom (ATOM_RPAREN
);
1621 mio_integer (int *ip
)
1623 if (iomode
== IO_OUTPUT
)
1624 write_atom (ATOM_INTEGER
, ip
);
1627 require_atom (ATOM_INTEGER
);
1633 /* Read or write a gfc_intrinsic_op value. */
1636 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1638 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1639 if (iomode
== IO_OUTPUT
)
1641 int converted
= (int) *op
;
1642 write_atom (ATOM_INTEGER
, &converted
);
1646 require_atom (ATOM_INTEGER
);
1647 *op
= (gfc_intrinsic_op
) atom_int
;
1652 /* Read or write a character pointer that points to a string on the heap. */
1655 mio_allocated_string (const char *s
)
1657 if (iomode
== IO_OUTPUT
)
1659 write_atom (ATOM_STRING
, s
);
1664 require_atom (ATOM_STRING
);
1670 /* Functions for quoting and unquoting strings. */
1673 quote_string (const gfc_char_t
*s
, const size_t slength
)
1675 const gfc_char_t
*p
;
1679 /* Calculate the length we'll need: a backslash takes two ("\\"),
1680 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1681 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1685 else if (!gfc_wide_is_printable (*p
))
1691 q
= res
= XCNEWVEC (char, len
+ 1);
1692 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1695 *q
++ = '\\', *q
++ = '\\';
1696 else if (!gfc_wide_is_printable (*p
))
1698 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1699 (unsigned HOST_WIDE_INT
) *p
);
1703 *q
++ = (unsigned char) *p
;
1711 unquote_string (const char *s
)
1717 for (p
= s
, len
= 0; *p
; p
++, len
++)
1724 else if (p
[1] == 'U')
1725 p
+= 9; /* That is a "\U????????". */
1727 gfc_internal_error ("unquote_string(): got bad string");
1730 res
= gfc_get_wide_string (len
+ 1);
1731 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1736 res
[i
] = (unsigned char) *p
;
1737 else if (p
[1] == '\\')
1739 res
[i
] = (unsigned char) '\\';
1744 /* We read the 8-digits hexadecimal constant that follows. */
1749 gcc_assert (p
[1] == 'U');
1750 for (j
= 0; j
< 8; j
++)
1753 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1767 /* Read or write a character pointer that points to a wide string on the
1768 heap, performing quoting/unquoting of nonprintable characters using the
1769 form \U???????? (where each ? is a hexadecimal digit).
1770 Length is the length of the string, only known and used in output mode. */
1772 static const gfc_char_t
*
1773 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1775 if (iomode
== IO_OUTPUT
)
1777 char *quoted
= quote_string (s
, length
);
1778 write_atom (ATOM_STRING
, quoted
);
1784 gfc_char_t
*unquoted
;
1786 require_atom (ATOM_STRING
);
1787 unquoted
= unquote_string (atom_string
);
1794 /* Read or write a string that is in static memory. */
1797 mio_pool_string (const char **stringp
)
1799 /* TODO: one could write the string only once, and refer to it via a
1802 /* As a special case we have to deal with a NULL string. This
1803 happens for the 'module' member of 'gfc_symbol's that are not in a
1804 module. We read / write these as the empty string. */
1805 if (iomode
== IO_OUTPUT
)
1807 const char *p
= *stringp
== NULL
? "" : *stringp
;
1808 write_atom (ATOM_STRING
, p
);
1812 require_atom (ATOM_STRING
);
1813 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1819 /* Read or write a string that is inside of some already-allocated
1823 mio_internal_string (char *string
)
1825 if (iomode
== IO_OUTPUT
)
1826 write_atom (ATOM_STRING
, string
);
1829 require_atom (ATOM_STRING
);
1830 strcpy (string
, atom_string
);
1837 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1838 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1839 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1840 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1841 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1842 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1843 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1844 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1845 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1846 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1851 static const mstring attr_bits
[] =
1853 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1854 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1855 minit ("DIMENSION", AB_DIMENSION
),
1856 minit ("CODIMENSION", AB_CODIMENSION
),
1857 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1858 minit ("EXTERNAL", AB_EXTERNAL
),
1859 minit ("INTRINSIC", AB_INTRINSIC
),
1860 minit ("OPTIONAL", AB_OPTIONAL
),
1861 minit ("POINTER", AB_POINTER
),
1862 minit ("VOLATILE", AB_VOLATILE
),
1863 minit ("TARGET", AB_TARGET
),
1864 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1865 minit ("DUMMY", AB_DUMMY
),
1866 minit ("RESULT", AB_RESULT
),
1867 minit ("DATA", AB_DATA
),
1868 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1869 minit ("IN_COMMON", AB_IN_COMMON
),
1870 minit ("FUNCTION", AB_FUNCTION
),
1871 minit ("SUBROUTINE", AB_SUBROUTINE
),
1872 minit ("SEQUENCE", AB_SEQUENCE
),
1873 minit ("ELEMENTAL", AB_ELEMENTAL
),
1874 minit ("PURE", AB_PURE
),
1875 minit ("RECURSIVE", AB_RECURSIVE
),
1876 minit ("GENERIC", AB_GENERIC
),
1877 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1878 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1879 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1880 minit ("IS_BIND_C", AB_IS_BIND_C
),
1881 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1882 minit ("IS_ISO_C", AB_IS_ISO_C
),
1883 minit ("VALUE", AB_VALUE
),
1884 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1885 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1886 minit ("LOCK_COMP", AB_LOCK_COMP
),
1887 minit ("POINTER_COMP", AB_POINTER_COMP
),
1888 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1889 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1890 minit ("ZERO_COMP", AB_ZERO_COMP
),
1891 minit ("PROTECTED", AB_PROTECTED
),
1892 minit ("ABSTRACT", AB_ABSTRACT
),
1893 minit ("IS_CLASS", AB_IS_CLASS
),
1894 minit ("PROCEDURE", AB_PROCEDURE
),
1895 minit ("PROC_POINTER", AB_PROC_POINTER
),
1896 minit ("VTYPE", AB_VTYPE
),
1897 minit ("VTAB", AB_VTAB
),
1898 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
1899 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
1903 /* For binding attributes. */
1904 static const mstring binding_passing
[] =
1907 minit ("NOPASS", 1),
1910 static const mstring binding_overriding
[] =
1912 minit ("OVERRIDABLE", 0),
1913 minit ("NON_OVERRIDABLE", 1),
1914 minit ("DEFERRED", 2),
1917 static const mstring binding_generic
[] =
1919 minit ("SPECIFIC", 0),
1920 minit ("GENERIC", 1),
1923 static const mstring binding_ppc
[] =
1925 minit ("NO_PPC", 0),
1930 /* Specialization of mio_name. */
1931 DECL_MIO_NAME (ab_attribute
)
1932 DECL_MIO_NAME (ar_type
)
1933 DECL_MIO_NAME (array_type
)
1935 DECL_MIO_NAME (expr_t
)
1936 DECL_MIO_NAME (gfc_access
)
1937 DECL_MIO_NAME (gfc_intrinsic_op
)
1938 DECL_MIO_NAME (ifsrc
)
1939 DECL_MIO_NAME (save_state
)
1940 DECL_MIO_NAME (procedure_type
)
1941 DECL_MIO_NAME (ref_type
)
1942 DECL_MIO_NAME (sym_flavor
)
1943 DECL_MIO_NAME (sym_intent
)
1944 #undef DECL_MIO_NAME
1946 /* Symbol attributes are stored in list with the first three elements
1947 being the enumerated fields, while the remaining elements (if any)
1948 indicate the individual attribute bits. The access field is not
1949 saved-- it controls what symbols are exported when a module is
1953 mio_symbol_attribute (symbol_attribute
*attr
)
1956 unsigned ext_attr
,extension_level
;
1960 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1961 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1962 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1963 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1964 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1966 ext_attr
= attr
->ext_attr
;
1967 mio_integer ((int *) &ext_attr
);
1968 attr
->ext_attr
= ext_attr
;
1970 extension_level
= attr
->extension
;
1971 mio_integer ((int *) &extension_level
);
1972 attr
->extension
= extension_level
;
1974 if (iomode
== IO_OUTPUT
)
1976 if (attr
->allocatable
)
1977 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1978 if (attr
->asynchronous
)
1979 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
1980 if (attr
->dimension
)
1981 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1982 if (attr
->codimension
)
1983 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
1984 if (attr
->contiguous
)
1985 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
1987 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1988 if (attr
->intrinsic
)
1989 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1991 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1993 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1994 if (attr
->class_pointer
)
1995 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
1996 if (attr
->is_protected
)
1997 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
1999 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2000 if (attr
->volatile_
)
2001 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2003 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2004 if (attr
->threadprivate
)
2005 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2007 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2009 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2010 /* We deliberately don't preserve the "entry" flag. */
2013 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2014 if (attr
->in_namelist
)
2015 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2016 if (attr
->in_common
)
2017 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2020 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2021 if (attr
->subroutine
)
2022 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2024 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2026 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2029 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2030 if (attr
->elemental
)
2031 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2033 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2034 if (attr
->implicit_pure
)
2035 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2036 if (attr
->recursive
)
2037 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2038 if (attr
->always_explicit
)
2039 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2040 if (attr
->cray_pointer
)
2041 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2042 if (attr
->cray_pointee
)
2043 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2044 if (attr
->is_bind_c
)
2045 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2046 if (attr
->is_c_interop
)
2047 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2049 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2050 if (attr
->alloc_comp
)
2051 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2052 if (attr
->pointer_comp
)
2053 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2054 if (attr
->proc_pointer_comp
)
2055 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2056 if (attr
->private_comp
)
2057 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2058 if (attr
->coarray_comp
)
2059 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2060 if (attr
->lock_comp
)
2061 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2062 if (attr
->zero_comp
)
2063 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2065 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2066 if (attr
->procedure
)
2067 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2068 if (attr
->proc_pointer
)
2069 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2071 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2073 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2083 if (t
== ATOM_RPAREN
)
2086 bad_module ("Expected attribute bit name");
2088 switch ((ab_attribute
) find_enum (attr_bits
))
2090 case AB_ALLOCATABLE
:
2091 attr
->allocatable
= 1;
2093 case AB_ASYNCHRONOUS
:
2094 attr
->asynchronous
= 1;
2097 attr
->dimension
= 1;
2099 case AB_CODIMENSION
:
2100 attr
->codimension
= 1;
2103 attr
->contiguous
= 1;
2109 attr
->intrinsic
= 1;
2117 case AB_CLASS_POINTER
:
2118 attr
->class_pointer
= 1;
2121 attr
->is_protected
= 1;
2127 attr
->volatile_
= 1;
2132 case AB_THREADPRIVATE
:
2133 attr
->threadprivate
= 1;
2144 case AB_IN_NAMELIST
:
2145 attr
->in_namelist
= 1;
2148 attr
->in_common
= 1;
2154 attr
->subroutine
= 1;
2166 attr
->elemental
= 1;
2171 case AB_IMPLICIT_PURE
:
2172 attr
->implicit_pure
= 1;
2175 attr
->recursive
= 1;
2177 case AB_ALWAYS_EXPLICIT
:
2178 attr
->always_explicit
= 1;
2180 case AB_CRAY_POINTER
:
2181 attr
->cray_pointer
= 1;
2183 case AB_CRAY_POINTEE
:
2184 attr
->cray_pointee
= 1;
2187 attr
->is_bind_c
= 1;
2189 case AB_IS_C_INTEROP
:
2190 attr
->is_c_interop
= 1;
2196 attr
->alloc_comp
= 1;
2198 case AB_COARRAY_COMP
:
2199 attr
->coarray_comp
= 1;
2202 attr
->lock_comp
= 1;
2204 case AB_POINTER_COMP
:
2205 attr
->pointer_comp
= 1;
2207 case AB_PROC_POINTER_COMP
:
2208 attr
->proc_pointer_comp
= 1;
2210 case AB_PRIVATE_COMP
:
2211 attr
->private_comp
= 1;
2214 attr
->zero_comp
= 1;
2220 attr
->procedure
= 1;
2222 case AB_PROC_POINTER
:
2223 attr
->proc_pointer
= 1;
2237 static const mstring bt_types
[] = {
2238 minit ("INTEGER", BT_INTEGER
),
2239 minit ("REAL", BT_REAL
),
2240 minit ("COMPLEX", BT_COMPLEX
),
2241 minit ("LOGICAL", BT_LOGICAL
),
2242 minit ("CHARACTER", BT_CHARACTER
),
2243 minit ("DERIVED", BT_DERIVED
),
2244 minit ("CLASS", BT_CLASS
),
2245 minit ("PROCEDURE", BT_PROCEDURE
),
2246 minit ("UNKNOWN", BT_UNKNOWN
),
2247 minit ("VOID", BT_VOID
),
2248 minit ("ASSUMED", BT_ASSUMED
),
2254 mio_charlen (gfc_charlen
**clp
)
2260 if (iomode
== IO_OUTPUT
)
2264 mio_expr (&cl
->length
);
2268 if (peek_atom () != ATOM_RPAREN
)
2270 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2271 mio_expr (&cl
->length
);
2280 /* See if a name is a generated name. */
2283 check_unique_name (const char *name
)
2285 return *name
== '@';
2290 mio_typespec (gfc_typespec
*ts
)
2294 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2296 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2297 mio_integer (&ts
->kind
);
2299 mio_symbol_ref (&ts
->u
.derived
);
2301 mio_symbol_ref (&ts
->interface
);
2303 /* Add info for C interop and is_iso_c. */
2304 mio_integer (&ts
->is_c_interop
);
2305 mio_integer (&ts
->is_iso_c
);
2307 /* If the typespec is for an identifier either from iso_c_binding, or
2308 a constant that was initialized to an identifier from it, use the
2309 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2311 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2313 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2315 if (ts
->type
!= BT_CHARACTER
)
2317 /* ts->u.cl is only valid for BT_CHARACTER. */
2322 mio_charlen (&ts
->u
.cl
);
2324 /* So as not to disturb the existing API, use an ATOM_NAME to
2325 transmit deferred characteristic for characters (F2003). */
2326 if (iomode
== IO_OUTPUT
)
2328 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2329 write_atom (ATOM_NAME
, "DEFERRED_CL");
2331 else if (peek_atom () != ATOM_RPAREN
)
2333 if (parse_atom () != ATOM_NAME
)
2334 bad_module ("Expected string");
2342 static const mstring array_spec_types
[] = {
2343 minit ("EXPLICIT", AS_EXPLICIT
),
2344 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2345 minit ("DEFERRED", AS_DEFERRED
),
2346 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2352 mio_array_spec (gfc_array_spec
**asp
)
2359 if (iomode
== IO_OUTPUT
)
2367 if (peek_atom () == ATOM_RPAREN
)
2373 *asp
= as
= gfc_get_array_spec ();
2376 mio_integer (&as
->rank
);
2377 mio_integer (&as
->corank
);
2378 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2380 if (iomode
== IO_INPUT
&& as
->corank
)
2381 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2383 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2385 mio_expr (&as
->lower
[i
]);
2386 mio_expr (&as
->upper
[i
]);
2394 /* Given a pointer to an array reference structure (which lives in a
2395 gfc_ref structure), find the corresponding array specification
2396 structure. Storing the pointer in the ref structure doesn't quite
2397 work when loading from a module. Generating code for an array
2398 reference also needs more information than just the array spec. */
2400 static const mstring array_ref_types
[] = {
2401 minit ("FULL", AR_FULL
),
2402 minit ("ELEMENT", AR_ELEMENT
),
2403 minit ("SECTION", AR_SECTION
),
2409 mio_array_ref (gfc_array_ref
*ar
)
2414 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2415 mio_integer (&ar
->dimen
);
2423 for (i
= 0; i
< ar
->dimen
; i
++)
2424 mio_expr (&ar
->start
[i
]);
2429 for (i
= 0; i
< ar
->dimen
; i
++)
2431 mio_expr (&ar
->start
[i
]);
2432 mio_expr (&ar
->end
[i
]);
2433 mio_expr (&ar
->stride
[i
]);
2439 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2442 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2443 we can't call mio_integer directly. Instead loop over each element
2444 and cast it to/from an integer. */
2445 if (iomode
== IO_OUTPUT
)
2447 for (i
= 0; i
< ar
->dimen
; i
++)
2449 int tmp
= (int)ar
->dimen_type
[i
];
2450 write_atom (ATOM_INTEGER
, &tmp
);
2455 for (i
= 0; i
< ar
->dimen
; i
++)
2457 require_atom (ATOM_INTEGER
);
2458 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2462 if (iomode
== IO_INPUT
)
2464 ar
->where
= gfc_current_locus
;
2466 for (i
= 0; i
< ar
->dimen
; i
++)
2467 ar
->c_where
[i
] = gfc_current_locus
;
2474 /* Saves or restores a pointer. The pointer is converted back and
2475 forth from an integer. We return the pointer_info pointer so that
2476 the caller can take additional action based on the pointer type. */
2478 static pointer_info
*
2479 mio_pointer_ref (void *gp
)
2483 if (iomode
== IO_OUTPUT
)
2485 p
= get_pointer (*((char **) gp
));
2486 write_atom (ATOM_INTEGER
, &p
->integer
);
2490 require_atom (ATOM_INTEGER
);
2491 p
= add_fixup (atom_int
, gp
);
2498 /* Save and load references to components that occur within
2499 expressions. We have to describe these references by a number and
2500 by name. The number is necessary for forward references during
2501 reading, and the name is necessary if the symbol already exists in
2502 the namespace and is not loaded again. */
2505 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2507 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2511 p
= mio_pointer_ref (cp
);
2512 if (p
->type
== P_UNKNOWN
)
2513 p
->type
= P_COMPONENT
;
2515 if (iomode
== IO_OUTPUT
)
2516 mio_pool_string (&(*cp
)->name
);
2519 mio_internal_string (name
);
2521 if (sym
&& sym
->attr
.is_class
)
2522 sym
= sym
->components
->ts
.u
.derived
;
2524 /* It can happen that a component reference can be read before the
2525 associated derived type symbol has been loaded. Return now and
2526 wait for a later iteration of load_needed. */
2530 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2532 /* Symbol already loaded, so search by name. */
2533 q
= gfc_find_component (sym
, name
, true, true);
2536 associate_integer_pointer (p
, q
);
2539 /* Make sure this symbol will eventually be loaded. */
2540 p
= find_pointer2 (sym
);
2541 if (p
->u
.rsym
.state
== UNUSED
)
2542 p
->u
.rsym
.state
= NEEDED
;
2547 static void mio_namespace_ref (gfc_namespace
**nsp
);
2548 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2549 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2552 mio_component (gfc_component
*c
, int vtype
)
2556 gfc_formal_arglist
*formal
;
2560 if (iomode
== IO_OUTPUT
)
2562 p
= get_pointer (c
);
2563 mio_integer (&p
->integer
);
2568 p
= get_integer (n
);
2569 associate_integer_pointer (p
, c
);
2572 if (p
->type
== P_UNKNOWN
)
2573 p
->type
= P_COMPONENT
;
2575 mio_pool_string (&c
->name
);
2576 mio_typespec (&c
->ts
);
2577 mio_array_spec (&c
->as
);
2579 mio_symbol_attribute (&c
->attr
);
2580 if (c
->ts
.type
== BT_CLASS
)
2581 c
->attr
.class_ok
= 1;
2582 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2585 mio_expr (&c
->initializer
);
2587 if (c
->attr
.proc_pointer
)
2589 if (iomode
== IO_OUTPUT
)
2592 while (formal
&& !formal
->sym
)
2593 formal
= formal
->next
;
2596 mio_namespace_ref (&formal
->sym
->ns
);
2598 mio_namespace_ref (&c
->formal_ns
);
2602 mio_namespace_ref (&c
->formal_ns
);
2603 /* TODO: if (c->formal_ns)
2605 c->formal_ns->proc_name = c;
2610 mio_formal_arglist (&c
->formal
);
2612 mio_typebound_proc (&c
->tb
);
2620 mio_component_list (gfc_component
**cp
, int vtype
)
2622 gfc_component
*c
, *tail
;
2626 if (iomode
== IO_OUTPUT
)
2628 for (c
= *cp
; c
; c
= c
->next
)
2629 mio_component (c
, vtype
);
2638 if (peek_atom () == ATOM_RPAREN
)
2641 c
= gfc_get_component ();
2642 mio_component (c
, vtype
);
2658 mio_actual_arg (gfc_actual_arglist
*a
)
2661 mio_pool_string (&a
->name
);
2662 mio_expr (&a
->expr
);
2668 mio_actual_arglist (gfc_actual_arglist
**ap
)
2670 gfc_actual_arglist
*a
, *tail
;
2674 if (iomode
== IO_OUTPUT
)
2676 for (a
= *ap
; a
; a
= a
->next
)
2686 if (peek_atom () != ATOM_LPAREN
)
2689 a
= gfc_get_actual_arglist ();
2705 /* Read and write formal argument lists. */
2708 mio_formal_arglist (gfc_formal_arglist
**formal
)
2710 gfc_formal_arglist
*f
, *tail
;
2714 if (iomode
== IO_OUTPUT
)
2716 for (f
= *formal
; f
; f
= f
->next
)
2717 mio_symbol_ref (&f
->sym
);
2721 *formal
= tail
= NULL
;
2723 while (peek_atom () != ATOM_RPAREN
)
2725 f
= gfc_get_formal_arglist ();
2726 mio_symbol_ref (&f
->sym
);
2728 if (*formal
== NULL
)
2741 /* Save or restore a reference to a symbol node. */
2744 mio_symbol_ref (gfc_symbol
**symp
)
2748 p
= mio_pointer_ref (symp
);
2749 if (p
->type
== P_UNKNOWN
)
2752 if (iomode
== IO_OUTPUT
)
2754 if (p
->u
.wsym
.state
== UNREFERENCED
)
2755 p
->u
.wsym
.state
= NEEDS_WRITE
;
2759 if (p
->u
.rsym
.state
== UNUSED
)
2760 p
->u
.rsym
.state
= NEEDED
;
2766 /* Save or restore a reference to a symtree node. */
2769 mio_symtree_ref (gfc_symtree
**stp
)
2774 if (iomode
== IO_OUTPUT
)
2775 mio_symbol_ref (&(*stp
)->n
.sym
);
2778 require_atom (ATOM_INTEGER
);
2779 p
= get_integer (atom_int
);
2781 /* An unused equivalence member; make a symbol and a symtree
2783 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2785 /* Since this is not used, it must have a unique name. */
2786 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2788 /* Make the symbol. */
2789 if (p
->u
.rsym
.sym
== NULL
)
2791 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2793 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2796 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2797 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2798 p
->u
.rsym
.referenced
= 1;
2800 /* If the symbol is PRIVATE and in COMMON, load_commons will
2801 generate a fixup symbol, which must be associated. */
2803 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2807 if (p
->type
== P_UNKNOWN
)
2810 if (p
->u
.rsym
.state
== UNUSED
)
2811 p
->u
.rsym
.state
= NEEDED
;
2813 if (p
->u
.rsym
.symtree
!= NULL
)
2815 *stp
= p
->u
.rsym
.symtree
;
2819 f
= XCNEW (fixup_t
);
2821 f
->next
= p
->u
.rsym
.stfixup
;
2822 p
->u
.rsym
.stfixup
= f
;
2824 f
->pointer
= (void **) stp
;
2831 mio_iterator (gfc_iterator
**ip
)
2837 if (iomode
== IO_OUTPUT
)
2844 if (peek_atom () == ATOM_RPAREN
)
2850 *ip
= gfc_get_iterator ();
2855 mio_expr (&iter
->var
);
2856 mio_expr (&iter
->start
);
2857 mio_expr (&iter
->end
);
2858 mio_expr (&iter
->step
);
2866 mio_constructor (gfc_constructor_base
*cp
)
2872 if (iomode
== IO_OUTPUT
)
2874 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2877 mio_expr (&c
->expr
);
2878 mio_iterator (&c
->iterator
);
2884 while (peek_atom () != ATOM_RPAREN
)
2886 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2889 mio_expr (&c
->expr
);
2890 mio_iterator (&c
->iterator
);
2899 static const mstring ref_types
[] = {
2900 minit ("ARRAY", REF_ARRAY
),
2901 minit ("COMPONENT", REF_COMPONENT
),
2902 minit ("SUBSTRING", REF_SUBSTRING
),
2908 mio_ref (gfc_ref
**rp
)
2915 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2920 mio_array_ref (&r
->u
.ar
);
2924 mio_symbol_ref (&r
->u
.c
.sym
);
2925 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2929 mio_expr (&r
->u
.ss
.start
);
2930 mio_expr (&r
->u
.ss
.end
);
2931 mio_charlen (&r
->u
.ss
.length
);
2940 mio_ref_list (gfc_ref
**rp
)
2942 gfc_ref
*ref
, *head
, *tail
;
2946 if (iomode
== IO_OUTPUT
)
2948 for (ref
= *rp
; ref
; ref
= ref
->next
)
2955 while (peek_atom () != ATOM_RPAREN
)
2958 head
= tail
= gfc_get_ref ();
2961 tail
->next
= gfc_get_ref ();
2975 /* Read and write an integer value. */
2978 mio_gmp_integer (mpz_t
*integer
)
2982 if (iomode
== IO_INPUT
)
2984 if (parse_atom () != ATOM_STRING
)
2985 bad_module ("Expected integer string");
2987 mpz_init (*integer
);
2988 if (mpz_set_str (*integer
, atom_string
, 10))
2989 bad_module ("Error converting integer");
2995 p
= mpz_get_str (NULL
, 10, *integer
);
2996 write_atom (ATOM_STRING
, p
);
3003 mio_gmp_real (mpfr_t
*real
)
3008 if (iomode
== IO_INPUT
)
3010 if (parse_atom () != ATOM_STRING
)
3011 bad_module ("Expected real string");
3014 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3019 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3021 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3023 write_atom (ATOM_STRING
, p
);
3028 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3030 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3032 /* Fix negative numbers. */
3033 if (atom_string
[2] == '-')
3035 atom_string
[0] = '-';
3036 atom_string
[1] = '0';
3037 atom_string
[2] = '.';
3040 write_atom (ATOM_STRING
, atom_string
);
3048 /* Save and restore the shape of an array constructor. */
3051 mio_shape (mpz_t
**pshape
, int rank
)
3057 /* A NULL shape is represented by (). */
3060 if (iomode
== IO_OUTPUT
)
3072 if (t
== ATOM_RPAREN
)
3079 shape
= gfc_get_shape (rank
);
3083 for (n
= 0; n
< rank
; n
++)
3084 mio_gmp_integer (&shape
[n
]);
3090 static const mstring expr_types
[] = {
3091 minit ("OP", EXPR_OP
),
3092 minit ("FUNCTION", EXPR_FUNCTION
),
3093 minit ("CONSTANT", EXPR_CONSTANT
),
3094 minit ("VARIABLE", EXPR_VARIABLE
),
3095 minit ("SUBSTRING", EXPR_SUBSTRING
),
3096 minit ("STRUCTURE", EXPR_STRUCTURE
),
3097 minit ("ARRAY", EXPR_ARRAY
),
3098 minit ("NULL", EXPR_NULL
),
3099 minit ("COMPCALL", EXPR_COMPCALL
),
3103 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3104 generic operators, not in expressions. INTRINSIC_USER is also
3105 replaced by the correct function name by the time we see it. */
3107 static const mstring intrinsics
[] =
3109 minit ("UPLUS", INTRINSIC_UPLUS
),
3110 minit ("UMINUS", INTRINSIC_UMINUS
),
3111 minit ("PLUS", INTRINSIC_PLUS
),
3112 minit ("MINUS", INTRINSIC_MINUS
),
3113 minit ("TIMES", INTRINSIC_TIMES
),
3114 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3115 minit ("POWER", INTRINSIC_POWER
),
3116 minit ("CONCAT", INTRINSIC_CONCAT
),
3117 minit ("AND", INTRINSIC_AND
),
3118 minit ("OR", INTRINSIC_OR
),
3119 minit ("EQV", INTRINSIC_EQV
),
3120 minit ("NEQV", INTRINSIC_NEQV
),
3121 minit ("EQ_SIGN", INTRINSIC_EQ
),
3122 minit ("EQ", INTRINSIC_EQ_OS
),
3123 minit ("NE_SIGN", INTRINSIC_NE
),
3124 minit ("NE", INTRINSIC_NE_OS
),
3125 minit ("GT_SIGN", INTRINSIC_GT
),
3126 minit ("GT", INTRINSIC_GT_OS
),
3127 minit ("GE_SIGN", INTRINSIC_GE
),
3128 minit ("GE", INTRINSIC_GE_OS
),
3129 minit ("LT_SIGN", INTRINSIC_LT
),
3130 minit ("LT", INTRINSIC_LT_OS
),
3131 minit ("LE_SIGN", INTRINSIC_LE
),
3132 minit ("LE", INTRINSIC_LE_OS
),
3133 minit ("NOT", INTRINSIC_NOT
),
3134 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3139 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3142 fix_mio_expr (gfc_expr
*e
)
3144 gfc_symtree
*ns_st
= NULL
;
3147 if (iomode
!= IO_OUTPUT
)
3152 /* If this is a symtree for a symbol that came from a contained module
3153 namespace, it has a unique name and we should look in the current
3154 namespace to see if the required, non-contained symbol is available
3155 yet. If so, the latter should be written. */
3156 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3158 const char *name
= e
->symtree
->n
.sym
->name
;
3159 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3160 name
= dt_upper_string (name
);
3161 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3164 /* On the other hand, if the existing symbol is the module name or the
3165 new symbol is a dummy argument, do not do the promotion. */
3166 if (ns_st
&& ns_st
->n
.sym
3167 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3168 && !e
->symtree
->n
.sym
->attr
.dummy
)
3171 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
3175 /* In some circumstances, a function used in an initialization
3176 expression, in one use associated module, can fail to be
3177 coupled to its symtree when used in a specification
3178 expression in another module. */
3179 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3180 : e
->value
.function
.isym
->name
;
3181 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3186 /* This is probably a reference to a private procedure from another
3187 module. To prevent a segfault, make a generic with no specific
3188 instances. If this module is used, without the required
3189 specific coming from somewhere, the appropriate error message
3191 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3192 sym
->attr
.flavor
= FL_PROCEDURE
;
3193 sym
->attr
.generic
= 1;
3194 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3195 gfc_commit_symbol (sym
);
3200 /* Read and write expressions. The form "()" is allowed to indicate a
3204 mio_expr (gfc_expr
**ep
)
3212 if (iomode
== IO_OUTPUT
)
3221 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3226 if (t
== ATOM_RPAREN
)
3233 bad_module ("Expected expression type");
3235 e
= *ep
= gfc_get_expr ();
3236 e
->where
= gfc_current_locus
;
3237 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3240 mio_typespec (&e
->ts
);
3241 mio_integer (&e
->rank
);
3245 switch (e
->expr_type
)
3249 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3251 switch (e
->value
.op
.op
)
3253 case INTRINSIC_UPLUS
:
3254 case INTRINSIC_UMINUS
:
3256 case INTRINSIC_PARENTHESES
:
3257 mio_expr (&e
->value
.op
.op1
);
3260 case INTRINSIC_PLUS
:
3261 case INTRINSIC_MINUS
:
3262 case INTRINSIC_TIMES
:
3263 case INTRINSIC_DIVIDE
:
3264 case INTRINSIC_POWER
:
3265 case INTRINSIC_CONCAT
:
3269 case INTRINSIC_NEQV
:
3271 case INTRINSIC_EQ_OS
:
3273 case INTRINSIC_NE_OS
:
3275 case INTRINSIC_GT_OS
:
3277 case INTRINSIC_GE_OS
:
3279 case INTRINSIC_LT_OS
:
3281 case INTRINSIC_LE_OS
:
3282 mio_expr (&e
->value
.op
.op1
);
3283 mio_expr (&e
->value
.op
.op2
);
3287 bad_module ("Bad operator");
3293 mio_symtree_ref (&e
->symtree
);
3294 mio_actual_arglist (&e
->value
.function
.actual
);
3296 if (iomode
== IO_OUTPUT
)
3298 e
->value
.function
.name
3299 = mio_allocated_string (e
->value
.function
.name
);
3300 flag
= e
->value
.function
.esym
!= NULL
;
3301 mio_integer (&flag
);
3303 mio_symbol_ref (&e
->value
.function
.esym
);
3305 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3309 require_atom (ATOM_STRING
);
3310 e
->value
.function
.name
= gfc_get_string (atom_string
);
3313 mio_integer (&flag
);
3315 mio_symbol_ref (&e
->value
.function
.esym
);
3318 require_atom (ATOM_STRING
);
3319 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3327 mio_symtree_ref (&e
->symtree
);
3328 mio_ref_list (&e
->ref
);
3331 case EXPR_SUBSTRING
:
3332 e
->value
.character
.string
3333 = CONST_CAST (gfc_char_t
*,
3334 mio_allocated_wide_string (e
->value
.character
.string
,
3335 e
->value
.character
.length
));
3336 mio_ref_list (&e
->ref
);
3339 case EXPR_STRUCTURE
:
3341 mio_constructor (&e
->value
.constructor
);
3342 mio_shape (&e
->shape
, e
->rank
);
3349 mio_gmp_integer (&e
->value
.integer
);
3353 gfc_set_model_kind (e
->ts
.kind
);
3354 mio_gmp_real (&e
->value
.real
);
3358 gfc_set_model_kind (e
->ts
.kind
);
3359 mio_gmp_real (&mpc_realref (e
->value
.complex));
3360 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3364 mio_integer (&e
->value
.logical
);
3368 mio_integer (&e
->value
.character
.length
);
3369 e
->value
.character
.string
3370 = CONST_CAST (gfc_char_t
*,
3371 mio_allocated_wide_string (e
->value
.character
.string
,
3372 e
->value
.character
.length
));
3376 bad_module ("Bad type in constant expression");
3394 /* Read and write namelists. */
3397 mio_namelist (gfc_symbol
*sym
)
3399 gfc_namelist
*n
, *m
;
3400 const char *check_name
;
3404 if (iomode
== IO_OUTPUT
)
3406 for (n
= sym
->namelist
; n
; n
= n
->next
)
3407 mio_symbol_ref (&n
->sym
);
3411 /* This departure from the standard is flagged as an error.
3412 It does, in fact, work correctly. TODO: Allow it
3414 if (sym
->attr
.flavor
== FL_NAMELIST
)
3416 check_name
= find_use_name (sym
->name
, false);
3417 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3418 gfc_error ("Namelist %s cannot be renamed by USE "
3419 "association to %s", sym
->name
, check_name
);
3423 while (peek_atom () != ATOM_RPAREN
)
3425 n
= gfc_get_namelist ();
3426 mio_symbol_ref (&n
->sym
);
3428 if (sym
->namelist
== NULL
)
3435 sym
->namelist_tail
= m
;
3442 /* Save/restore lists of gfc_interface structures. When loading an
3443 interface, we are really appending to the existing list of
3444 interfaces. Checking for duplicate and ambiguous interfaces has to
3445 be done later when all symbols have been loaded. */
3448 mio_interface_rest (gfc_interface
**ip
)
3450 gfc_interface
*tail
, *p
;
3451 pointer_info
*pi
= NULL
;
3453 if (iomode
== IO_OUTPUT
)
3456 for (p
= *ip
; p
; p
= p
->next
)
3457 mio_symbol_ref (&p
->sym
);
3472 if (peek_atom () == ATOM_RPAREN
)
3475 p
= gfc_get_interface ();
3476 p
->where
= gfc_current_locus
;
3477 pi
= mio_symbol_ref (&p
->sym
);
3493 /* Save/restore a nameless operator interface. */
3496 mio_interface (gfc_interface
**ip
)
3499 mio_interface_rest (ip
);
3503 /* Save/restore a named operator interface. */
3506 mio_symbol_interface (const char **name
, const char **module
,
3510 mio_pool_string (name
);
3511 mio_pool_string (module
);
3512 mio_interface_rest (ip
);
3517 mio_namespace_ref (gfc_namespace
**nsp
)
3522 p
= mio_pointer_ref (nsp
);
3524 if (p
->type
== P_UNKNOWN
)
3525 p
->type
= P_NAMESPACE
;
3527 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3529 ns
= (gfc_namespace
*) p
->u
.pointer
;
3532 ns
= gfc_get_namespace (NULL
, 0);
3533 associate_integer_pointer (p
, ns
);
3541 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3543 static gfc_namespace
* current_f2k_derived
;
3546 mio_typebound_proc (gfc_typebound_proc
** proc
)
3549 int overriding_flag
;
3551 if (iomode
== IO_INPUT
)
3553 *proc
= gfc_get_typebound_proc (NULL
);
3554 (*proc
)->where
= gfc_current_locus
;
3560 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3562 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3563 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3564 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3565 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3566 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3567 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3568 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3570 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3571 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3572 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3574 mio_pool_string (&((*proc
)->pass_arg
));
3576 flag
= (int) (*proc
)->pass_arg_num
;
3577 mio_integer (&flag
);
3578 (*proc
)->pass_arg_num
= (unsigned) flag
;
3580 if ((*proc
)->is_generic
)
3587 if (iomode
== IO_OUTPUT
)
3588 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3590 iop
= (int) g
->is_operator
;
3592 mio_allocated_string (g
->specific_st
->name
);
3596 (*proc
)->u
.generic
= NULL
;
3597 while (peek_atom () != ATOM_RPAREN
)
3599 gfc_symtree
** sym_root
;
3601 g
= gfc_get_tbp_generic ();
3605 g
->is_operator
= (bool) iop
;
3607 require_atom (ATOM_STRING
);
3608 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3609 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3612 g
->next
= (*proc
)->u
.generic
;
3613 (*proc
)->u
.generic
= g
;
3619 else if (!(*proc
)->ppc
)
3620 mio_symtree_ref (&(*proc
)->u
.specific
);
3625 /* Walker-callback function for this purpose. */
3627 mio_typebound_symtree (gfc_symtree
* st
)
3629 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3632 if (iomode
== IO_OUTPUT
)
3635 mio_allocated_string (st
->name
);
3637 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3639 mio_typebound_proc (&st
->n
.tb
);
3643 /* IO a full symtree (in all depth). */
3645 mio_full_typebound_tree (gfc_symtree
** root
)
3649 if (iomode
== IO_OUTPUT
)
3650 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3653 while (peek_atom () == ATOM_LPAREN
)
3659 require_atom (ATOM_STRING
);
3660 st
= gfc_get_tbp_symtree (root
, atom_string
);
3663 mio_typebound_symtree (st
);
3671 mio_finalizer (gfc_finalizer
**f
)
3673 if (iomode
== IO_OUTPUT
)
3676 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3677 mio_symtree_ref (&(*f
)->proc_tree
);
3681 *f
= gfc_get_finalizer ();
3682 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3685 mio_symtree_ref (&(*f
)->proc_tree
);
3686 (*f
)->proc_sym
= NULL
;
3691 mio_f2k_derived (gfc_namespace
*f2k
)
3693 current_f2k_derived
= f2k
;
3695 /* Handle the list of finalizer procedures. */
3697 if (iomode
== IO_OUTPUT
)
3700 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3705 f2k
->finalizers
= NULL
;
3706 while (peek_atom () != ATOM_RPAREN
)
3708 gfc_finalizer
*cur
= NULL
;
3709 mio_finalizer (&cur
);
3710 cur
->next
= f2k
->finalizers
;
3711 f2k
->finalizers
= cur
;
3716 /* Handle type-bound procedures. */
3717 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3719 /* Type-bound user operators. */
3720 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3722 /* Type-bound intrinsic operators. */
3724 if (iomode
== IO_OUTPUT
)
3727 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3729 gfc_intrinsic_op realop
;
3731 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3735 realop
= (gfc_intrinsic_op
) op
;
3736 mio_intrinsic_op (&realop
);
3737 mio_typebound_proc (&f2k
->tb_op
[op
]);
3742 while (peek_atom () != ATOM_RPAREN
)
3744 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3747 mio_intrinsic_op (&op
);
3748 mio_typebound_proc (&f2k
->tb_op
[op
]);
3755 mio_full_f2k_derived (gfc_symbol
*sym
)
3759 if (iomode
== IO_OUTPUT
)
3761 if (sym
->f2k_derived
)
3762 mio_f2k_derived (sym
->f2k_derived
);
3766 if (peek_atom () != ATOM_RPAREN
)
3768 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3769 mio_f2k_derived (sym
->f2k_derived
);
3772 gcc_assert (!sym
->f2k_derived
);
3779 /* Unlike most other routines, the address of the symbol node is already
3780 fixed on input and the name/module has already been filled in. */
3783 mio_symbol (gfc_symbol
*sym
)
3785 int intmod
= INTMOD_NONE
;
3789 mio_symbol_attribute (&sym
->attr
);
3790 mio_typespec (&sym
->ts
);
3791 if (sym
->ts
.type
== BT_CLASS
)
3792 sym
->attr
.class_ok
= 1;
3794 if (iomode
== IO_OUTPUT
)
3795 mio_namespace_ref (&sym
->formal_ns
);
3798 mio_namespace_ref (&sym
->formal_ns
);
3801 sym
->formal_ns
->proc_name
= sym
;
3806 /* Save/restore common block links. */
3807 mio_symbol_ref (&sym
->common_next
);
3809 mio_formal_arglist (&sym
->formal
);
3811 if (sym
->attr
.flavor
== FL_PARAMETER
)
3812 mio_expr (&sym
->value
);
3814 mio_array_spec (&sym
->as
);
3816 mio_symbol_ref (&sym
->result
);
3818 if (sym
->attr
.cray_pointee
)
3819 mio_symbol_ref (&sym
->cp_pointer
);
3821 /* Note that components are always saved, even if they are supposed
3822 to be private. Component access is checked during searching. */
3824 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
3826 if (sym
->components
!= NULL
)
3827 sym
->component_access
3828 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3830 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3831 mio_full_f2k_derived (sym
);
3835 /* Add the fields that say whether this is from an intrinsic module,
3836 and if so, what symbol it is within the module. */
3837 /* mio_integer (&(sym->from_intmod)); */
3838 if (iomode
== IO_OUTPUT
)
3840 intmod
= sym
->from_intmod
;
3841 mio_integer (&intmod
);
3845 mio_integer (&intmod
);
3846 sym
->from_intmod
= (intmod_id
) intmod
;
3849 mio_integer (&(sym
->intmod_sym_id
));
3851 if (sym
->attr
.flavor
== FL_DERIVED
)
3852 mio_integer (&(sym
->hash_value
));
3858 /************************* Top level subroutines *************************/
3860 /* Given a root symtree node and a symbol, try to find a symtree that
3861 references the symbol that is not a unique name. */
3863 static gfc_symtree
*
3864 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3866 gfc_symtree
*s
= NULL
;
3871 s
= find_symtree_for_symbol (st
->right
, sym
);
3874 s
= find_symtree_for_symbol (st
->left
, sym
);
3878 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3885 /* A recursive function to look for a specific symbol by name and by
3886 module. Whilst several symtrees might point to one symbol, its
3887 is sufficient for the purposes here than one exist. Note that
3888 generic interfaces are distinguished as are symbols that have been
3889 renamed in another module. */
3890 static gfc_symtree
*
3891 find_symbol (gfc_symtree
*st
, const char *name
,
3892 const char *module
, int generic
)
3895 gfc_symtree
*retval
, *s
;
3897 if (st
== NULL
|| st
->n
.sym
== NULL
)
3900 c
= strcmp (name
, st
->n
.sym
->name
);
3901 if (c
== 0 && st
->n
.sym
->module
3902 && strcmp (module
, st
->n
.sym
->module
) == 0
3903 && !check_unique_name (st
->name
))
3905 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3907 /* Detect symbols that are renamed by use association in another
3908 module by the absence of a symtree and null attr.use_rename,
3909 since the latter is not transmitted in the module file. */
3910 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3911 || (generic
&& st
->n
.sym
->attr
.generic
))
3912 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3916 retval
= find_symbol (st
->left
, name
, module
, generic
);
3919 retval
= find_symbol (st
->right
, name
, module
, generic
);
3925 /* Skip a list between balanced left and right parens. */
3935 switch (parse_atom ())
3958 /* Load operator interfaces from the module. Interfaces are unusual
3959 in that they attach themselves to existing symbols. */
3962 load_operator_interfaces (void)
3965 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3967 pointer_info
*pi
= NULL
;
3972 while (peek_atom () != ATOM_RPAREN
)
3976 mio_internal_string (name
);
3977 mio_internal_string (module
);
3979 n
= number_use_names (name
, true);
3982 for (i
= 1; i
<= n
; i
++)
3984 /* Decide if we need to load this one or not. */
3985 p
= find_use_name_n (name
, &i
, true);
3989 while (parse_atom () != ATOM_RPAREN
);
3995 uop
= gfc_get_uop (p
);
3996 pi
= mio_interface_rest (&uop
->op
);
4000 if (gfc_find_uop (p
, NULL
))
4002 uop
= gfc_get_uop (p
);
4003 uop
->op
= gfc_get_interface ();
4004 uop
->op
->where
= gfc_current_locus
;
4005 add_fixup (pi
->integer
, &uop
->op
->sym
);
4014 /* Load interfaces from the module. Interfaces are unusual in that
4015 they attach themselves to existing symbols. */
4018 load_generic_interfaces (void)
4021 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4023 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4025 bool ambiguous_set
= false;
4029 while (peek_atom () != ATOM_RPAREN
)
4033 mio_internal_string (name
);
4034 mio_internal_string (module
);
4036 n
= number_use_names (name
, false);
4037 renamed
= n
? 1 : 0;
4040 for (i
= 1; i
<= n
; i
++)
4043 /* Decide if we need to load this one or not. */
4044 p
= find_use_name_n (name
, &i
, false);
4046 st
= find_symbol (gfc_current_ns
->sym_root
,
4047 name
, module_name
, 1);
4049 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4051 /* Skip the specific names for these cases. */
4052 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4057 /* If the symbol exists already and is being USEd without being
4058 in an ONLY clause, do not load a new symtree(11.3.2). */
4059 if (!only_flag
&& st
)
4067 if (strcmp (st
->name
, p
) != 0)
4069 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4075 /* Since we haven't found a valid generic interface, we had
4079 gfc_get_symbol (p
, NULL
, &sym
);
4080 sym
->name
= gfc_get_string (name
);
4081 sym
->module
= module_name
;
4082 sym
->attr
.flavor
= FL_PROCEDURE
;
4083 sym
->attr
.generic
= 1;
4084 sym
->attr
.use_assoc
= 1;
4089 /* Unless sym is a generic interface, this reference
4092 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4096 if (st
&& !sym
->attr
.generic
4099 && strcmp(module
, sym
->module
))
4101 ambiguous_set
= true;
4106 sym
->attr
.use_only
= only_flag
;
4107 sym
->attr
.use_rename
= renamed
;
4111 mio_interface_rest (&sym
->generic
);
4112 generic
= sym
->generic
;
4114 else if (!sym
->generic
)
4116 sym
->generic
= generic
;
4117 sym
->attr
.generic_copy
= 1;
4120 /* If a procedure that is not generic has generic interfaces
4121 that include itself, it is generic! We need to take care
4122 to retain symbols ambiguous that were already so. */
4123 if (sym
->attr
.use_assoc
4124 && !sym
->attr
.generic
4125 && sym
->attr
.flavor
== FL_PROCEDURE
)
4127 for (gen
= generic
; gen
; gen
= gen
->next
)
4129 if (gen
->sym
== sym
)
4131 sym
->attr
.generic
= 1;
4146 /* Load common blocks. */
4151 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4156 while (peek_atom () != ATOM_RPAREN
)
4161 mio_internal_string (name
);
4163 p
= gfc_get_common (name
, 1);
4165 mio_symbol_ref (&p
->head
);
4166 mio_integer (&flags
);
4170 p
->threadprivate
= 1;
4173 /* Get whether this was a bind(c) common or not. */
4174 mio_integer (&p
->is_bind_c
);
4175 /* Get the binding label. */
4176 label
= read_string ();
4178 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4188 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4189 so that unused variables are not loaded and so that the expression can
4195 gfc_equiv
*head
, *tail
, *end
, *eq
;
4199 in_load_equiv
= true;
4201 end
= gfc_current_ns
->equiv
;
4202 while (end
!= NULL
&& end
->next
!= NULL
)
4205 while (peek_atom () != ATOM_RPAREN
) {
4209 while(peek_atom () != ATOM_RPAREN
)
4212 head
= tail
= gfc_get_equiv ();
4215 tail
->eq
= gfc_get_equiv ();
4219 mio_pool_string (&tail
->module
);
4220 mio_expr (&tail
->expr
);
4223 /* Unused equivalence members have a unique name. In addition, it
4224 must be checked that the symbols are from the same module. */
4226 for (eq
= head
; eq
; eq
= eq
->eq
)
4228 if (eq
->expr
->symtree
->n
.sym
->module
4229 && head
->expr
->symtree
->n
.sym
->module
4230 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4231 eq
->expr
->symtree
->n
.sym
->module
) == 0
4232 && !check_unique_name (eq
->expr
->symtree
->name
))
4241 for (eq
= head
; eq
; eq
= head
)
4244 gfc_free_expr (eq
->expr
);
4250 gfc_current_ns
->equiv
= head
;
4261 in_load_equiv
= false;
4265 /* This function loads the sym_root of f2k_derived with the extensions to
4266 the derived type. */
4268 load_derived_extensions (void)
4271 gfc_symbol
*derived
;
4275 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4276 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4280 while (peek_atom () != ATOM_RPAREN
)
4283 mio_integer (&symbol
);
4284 info
= get_integer (symbol
);
4285 derived
= info
->u
.rsym
.sym
;
4287 /* This one is not being loaded. */
4288 if (!info
|| !derived
)
4290 while (peek_atom () != ATOM_RPAREN
)
4295 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4296 if (derived
->f2k_derived
== NULL
)
4297 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4299 while (peek_atom () != ATOM_RPAREN
)
4302 mio_internal_string (name
);
4303 mio_internal_string (module
);
4305 /* Only use one use name to find the symbol. */
4307 p
= find_use_name_n (name
, &j
, false);
4310 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4312 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4315 /* Only use the real name in f2k_derived to ensure a single
4317 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4330 /* Recursive function to traverse the pointer_info tree and load a
4331 needed symbol. We return nonzero if we load a symbol and stop the
4332 traversal, because the act of loading can alter the tree. */
4335 load_needed (pointer_info
*p
)
4346 rv
|= load_needed (p
->left
);
4347 rv
|= load_needed (p
->right
);
4349 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4352 p
->u
.rsym
.state
= USED
;
4354 set_module_locus (&p
->u
.rsym
.where
);
4356 sym
= p
->u
.rsym
.sym
;
4359 q
= get_integer (p
->u
.rsym
.ns
);
4361 ns
= (gfc_namespace
*) q
->u
.pointer
;
4364 /* Create an interface namespace if necessary. These are
4365 the namespaces that hold the formal parameters of module
4368 ns
= gfc_get_namespace (NULL
, 0);
4369 associate_integer_pointer (q
, ns
);
4372 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4373 doesn't go pear-shaped if the symbol is used. */
4375 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4378 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4379 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4380 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4381 if (p
->u
.rsym
.binding_label
)
4382 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4383 (p
->u
.rsym
.binding_label
));
4385 associate_integer_pointer (p
, sym
);
4389 sym
->attr
.use_assoc
= 1;
4391 /* Mark as only or rename for later diagnosis for explicitly imported
4392 but not used warnings; don't mark internal symbols such as __vtab,
4393 __def_init etc. Only mark them if they have been explicitly loaded. */
4395 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4399 /* Search the use/rename list for the variable; if the variable is
4401 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4403 if (strcmp (u
->use_name
, sym
->name
) == 0)
4405 sym
->attr
.use_only
= 1;
4411 if (p
->u
.rsym
.renamed
)
4412 sym
->attr
.use_rename
= 1;
4418 /* Recursive function for cleaning up things after a module has been read. */
4421 read_cleanup (pointer_info
*p
)
4429 read_cleanup (p
->left
);
4430 read_cleanup (p
->right
);
4432 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4435 /* Add hidden symbols to the symtree. */
4436 q
= get_integer (p
->u
.rsym
.ns
);
4437 ns
= (gfc_namespace
*) q
->u
.pointer
;
4439 if (!p
->u
.rsym
.sym
->attr
.vtype
4440 && !p
->u
.rsym
.sym
->attr
.vtab
)
4441 st
= gfc_get_unique_symtree (ns
);
4444 /* There is no reason to use 'unique_symtrees' for vtabs or
4445 vtypes - their name is fine for a symtree and reduces the
4446 namespace pollution. */
4447 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4449 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4452 st
->n
.sym
= p
->u
.rsym
.sym
;
4455 /* Fixup any symtree references. */
4456 p
->u
.rsym
.symtree
= st
;
4457 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4458 p
->u
.rsym
.stfixup
= NULL
;
4461 /* Free unused symbols. */
4462 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4463 gfc_free_symbol (p
->u
.rsym
.sym
);
4467 /* It is not quite enough to check for ambiguity in the symbols by
4468 the loaded symbol and the new symbol not being identical. */
4470 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4474 symbol_attribute attr
;
4476 if (st_sym
->ns
->proc_name
&& st_sym
->name
== st_sym
->ns
->proc_name
->name
)
4478 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4479 "current program unit", st_sym
->name
, module_name
);
4483 rsym
= info
->u
.rsym
.sym
;
4487 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4490 /* If the existing symbol is generic from a different module and
4491 the new symbol is generic there can be no ambiguity. */
4492 if (st_sym
->attr
.generic
4494 && st_sym
->module
!= module_name
)
4496 /* The new symbol's attributes have not yet been read. Since
4497 we need attr.generic, read it directly. */
4498 get_module_locus (&locus
);
4499 set_module_locus (&info
->u
.rsym
.where
);
4502 mio_symbol_attribute (&attr
);
4503 set_module_locus (&locus
);
4512 /* Read a module file. */
4517 module_locus operator_interfaces
, user_operators
, extensions
;
4519 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4521 int ambiguous
, j
, nuse
, symbol
;
4522 pointer_info
*info
, *q
;
4523 gfc_use_rename
*u
= NULL
;
4527 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4530 get_module_locus (&user_operators
);
4534 /* Skip commons, equivalences and derived type extensions for now. */
4538 get_module_locus (&extensions
);
4543 /* Create the fixup nodes for all the symbols. */
4545 while (peek_atom () != ATOM_RPAREN
)
4548 require_atom (ATOM_INTEGER
);
4549 info
= get_integer (atom_int
);
4551 info
->type
= P_SYMBOL
;
4552 info
->u
.rsym
.state
= UNUSED
;
4554 info
->u
.rsym
.true_name
= read_string ();
4555 info
->u
.rsym
.module
= read_string ();
4556 bind_label
= read_string ();
4557 if (strlen (bind_label
))
4558 info
->u
.rsym
.binding_label
= bind_label
;
4560 XDELETEVEC (bind_label
);
4562 require_atom (ATOM_INTEGER
);
4563 info
->u
.rsym
.ns
= atom_int
;
4565 get_module_locus (&info
->u
.rsym
.where
);
4568 /* See if the symbol has already been loaded by a previous module.
4569 If so, we reference the existing symbol and prevent it from
4570 being loaded again. This should not happen if the symbol being
4571 read is an index for an assumed shape dummy array (ns != 1). */
4573 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4576 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4579 info
->u
.rsym
.state
= USED
;
4580 info
->u
.rsym
.sym
= sym
;
4582 /* Some symbols do not have a namespace (eg. formal arguments),
4583 so the automatic "unique symtree" mechanism must be suppressed
4584 by marking them as referenced. */
4585 q
= get_integer (info
->u
.rsym
.ns
);
4586 if (q
->u
.pointer
== NULL
)
4588 info
->u
.rsym
.referenced
= 1;
4592 /* If possible recycle the symtree that references the symbol.
4593 If a symtree is not found and the module does not import one,
4594 a unique-name symtree is found by read_cleanup. */
4595 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4598 info
->u
.rsym
.symtree
= st
;
4599 info
->u
.rsym
.referenced
= 1;
4605 /* Parse the symtree lists. This lets us mark which symbols need to
4606 be loaded. Renaming is also done at this point by replacing the
4611 while (peek_atom () != ATOM_RPAREN
)
4613 mio_internal_string (name
);
4614 mio_integer (&ambiguous
);
4615 mio_integer (&symbol
);
4617 info
= get_integer (symbol
);
4619 /* See how many use names there are. If none, go through the start
4620 of the loop at least once. */
4621 nuse
= number_use_names (name
, false);
4622 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4627 for (j
= 1; j
<= nuse
; j
++)
4629 /* Get the jth local name for this symbol. */
4630 p
= find_use_name_n (name
, &j
, false);
4632 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4635 /* Exception: Always import vtabs & vtypes. */
4636 if (p
== NULL
&& name
[0] == '_'
4637 && (strncmp (name
, "__vtab_", 5) == 0
4638 || strncmp (name
, "__vtype_", 6) == 0))
4641 /* Skip symtree nodes not in an ONLY clause, unless there
4642 is an existing symtree loaded from another USE statement. */
4645 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4647 info
->u
.rsym
.symtree
= st
;
4651 /* If a symbol of the same name and module exists already,
4652 this symbol, which is not in an ONLY clause, must not be
4653 added to the namespace(11.3.2). Note that find_symbol
4654 only returns the first occurrence that it finds. */
4655 if (!only_flag
&& !info
->u
.rsym
.renamed
4656 && strcmp (name
, module_name
) != 0
4657 && find_symbol (gfc_current_ns
->sym_root
, name
,
4661 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4665 /* Check for ambiguous symbols. */
4666 if (check_for_ambiguous (st
->n
.sym
, info
))
4668 info
->u
.rsym
.symtree
= st
;
4672 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4674 /* Create a symtree node in the current namespace for this
4676 st
= check_unique_name (p
)
4677 ? gfc_get_unique_symtree (gfc_current_ns
)
4678 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4679 st
->ambiguous
= ambiguous
;
4681 sym
= info
->u
.rsym
.sym
;
4683 /* Create a symbol node if it doesn't already exist. */
4686 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4688 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
4689 sym
= info
->u
.rsym
.sym
;
4690 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4692 if (info
->u
.rsym
.binding_label
)
4693 sym
->binding_label
=
4694 IDENTIFIER_POINTER (get_identifier
4695 (info
->u
.rsym
.binding_label
));
4701 if (strcmp (name
, p
) != 0)
4702 sym
->attr
.use_rename
= 1;
4705 || (strncmp (name
, "__vtab_", 5) != 0
4706 && strncmp (name
, "__vtype_", 6) != 0))
4707 sym
->attr
.use_only
= only_flag
;
4709 /* Store the symtree pointing to this symbol. */
4710 info
->u
.rsym
.symtree
= st
;
4712 if (info
->u
.rsym
.state
== UNUSED
)
4713 info
->u
.rsym
.state
= NEEDED
;
4714 info
->u
.rsym
.referenced
= 1;
4721 /* Load intrinsic operator interfaces. */
4722 set_module_locus (&operator_interfaces
);
4725 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4727 if (i
== INTRINSIC_USER
)
4732 u
= find_use_operator ((gfc_intrinsic_op
) i
);
4743 mio_interface (&gfc_current_ns
->op
[i
]);
4744 if (u
&& !gfc_current_ns
->op
[i
])
4750 /* Load generic and user operator interfaces. These must follow the
4751 loading of symtree because otherwise symbols can be marked as
4754 set_module_locus (&user_operators
);
4756 load_operator_interfaces ();
4757 load_generic_interfaces ();
4762 /* At this point, we read those symbols that are needed but haven't
4763 been loaded yet. If one symbol requires another, the other gets
4764 marked as NEEDED if its previous state was UNUSED. */
4766 while (load_needed (pi_root
));
4768 /* Make sure all elements of the rename-list were found in the module. */
4770 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4775 if (u
->op
== INTRINSIC_NONE
)
4777 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4778 u
->use_name
, &u
->where
, module_name
);
4782 if (u
->op
== INTRINSIC_USER
)
4784 gfc_error ("User operator '%s' referenced at %L not found "
4785 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4789 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4790 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4794 /* Now we should be in a position to fill f2k_derived with derived type
4795 extensions, since everything has been loaded. */
4796 set_module_locus (&extensions
);
4797 load_derived_extensions ();
4799 /* Clean up symbol nodes that were never loaded, create references
4800 to hidden symbols. */
4802 read_cleanup (pi_root
);
4806 /* Given an access type that is specific to an entity and the default
4807 access, return nonzero if the entity is publicly accessible. If the
4808 element is declared as PUBLIC, then it is public; if declared
4809 PRIVATE, then private, and otherwise it is public unless the default
4810 access in this context has been declared PRIVATE. */
4813 check_access (gfc_access specific_access
, gfc_access default_access
)
4815 if (specific_access
== ACCESS_PUBLIC
)
4817 if (specific_access
== ACCESS_PRIVATE
)
4820 if (gfc_option
.flag_module_private
)
4821 return default_access
== ACCESS_PUBLIC
;
4823 return default_access
!= ACCESS_PRIVATE
;
4828 gfc_check_symbol_access (gfc_symbol
*sym
)
4830 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
4833 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
4837 /* A structure to remember which commons we've already written. */
4839 struct written_common
4841 BBT_HEADER(written_common
);
4842 const char *name
, *label
;
4845 static struct written_common
*written_commons
= NULL
;
4847 /* Comparison function used for balancing the binary tree. */
4850 compare_written_commons (void *a1
, void *b1
)
4852 const char *aname
= ((struct written_common
*) a1
)->name
;
4853 const char *alabel
= ((struct written_common
*) a1
)->label
;
4854 const char *bname
= ((struct written_common
*) b1
)->name
;
4855 const char *blabel
= ((struct written_common
*) b1
)->label
;
4856 int c
= strcmp (aname
, bname
);
4858 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4861 /* Free a list of written commons. */
4864 free_written_common (struct written_common
*w
)
4870 free_written_common (w
->left
);
4872 free_written_common (w
->right
);
4877 /* Write a common block to the module -- recursive helper function. */
4880 write_common_0 (gfc_symtree
*st
, bool this_module
)
4886 struct written_common
*w
;
4887 bool write_me
= true;
4892 write_common_0 (st
->left
, this_module
);
4894 /* We will write out the binding label, or "" if no label given. */
4895 name
= st
->n
.common
->name
;
4897 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
4899 /* Check if we've already output this common. */
4900 w
= written_commons
;
4903 int c
= strcmp (name
, w
->name
);
4904 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4908 w
= (c
< 0) ? w
->left
: w
->right
;
4911 if (this_module
&& p
->use_assoc
)
4916 /* Write the common to the module. */
4918 mio_pool_string (&name
);
4920 mio_symbol_ref (&p
->head
);
4921 flags
= p
->saved
? 1 : 0;
4922 if (p
->threadprivate
)
4924 mio_integer (&flags
);
4926 /* Write out whether the common block is bind(c) or not. */
4927 mio_integer (&(p
->is_bind_c
));
4929 mio_pool_string (&label
);
4932 /* Record that we have written this common. */
4933 w
= XCNEW (struct written_common
);
4936 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4939 write_common_0 (st
->right
, this_module
);
4943 /* Write a common, by initializing the list of written commons, calling
4944 the recursive function write_common_0() and cleaning up afterwards. */
4947 write_common (gfc_symtree
*st
)
4949 written_commons
= NULL
;
4950 write_common_0 (st
, true);
4951 write_common_0 (st
, false);
4952 free_written_common (written_commons
);
4953 written_commons
= NULL
;
4957 /* Write the blank common block to the module. */
4960 write_blank_common (void)
4962 const char * name
= BLANK_COMMON_NAME
;
4964 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4965 this, but it hasn't been checked. Just making it so for now. */
4968 if (gfc_current_ns
->blank_common
.head
== NULL
)
4973 mio_pool_string (&name
);
4975 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
4976 saved
= gfc_current_ns
->blank_common
.saved
;
4977 mio_integer (&saved
);
4979 /* Write out whether the common block is bind(c) or not. */
4980 mio_integer (&is_bind_c
);
4982 /* Write out an empty binding label. */
4983 write_atom (ATOM_STRING
, "");
4989 /* Write equivalences to the module. */
4998 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5002 for (e
= eq
; e
; e
= e
->eq
)
5004 if (e
->module
== NULL
)
5005 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5006 mio_allocated_string (e
->module
);
5007 mio_expr (&e
->expr
);
5016 /* Write derived type extensions to the module. */
5019 write_dt_extensions (gfc_symtree
*st
)
5021 if (!gfc_check_symbol_access (st
->n
.sym
))
5023 if (!(st
->n
.sym
->ns
&& st
->n
.sym
->ns
->proc_name
5024 && st
->n
.sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
5028 mio_pool_string (&st
->name
);
5029 if (st
->n
.sym
->module
!= NULL
)
5030 mio_pool_string (&st
->n
.sym
->module
);
5033 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5034 if (iomode
== IO_OUTPUT
)
5035 strcpy (name
, module_name
);
5036 mio_internal_string (name
);
5037 if (iomode
== IO_INPUT
)
5038 module_name
= gfc_get_string (name
);
5044 write_derived_extensions (gfc_symtree
*st
)
5046 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
5047 && (st
->n
.sym
->f2k_derived
!= NULL
)
5048 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
5052 mio_symbol_ref (&(st
->n
.sym
));
5053 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
5054 write_dt_extensions
);
5059 /* Write a symbol to the module. */
5062 write_symbol (int n
, gfc_symbol
*sym
)
5066 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5067 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
5071 if (sym
->attr
.flavor
== FL_DERIVED
)
5074 name
= dt_upper_string (sym
->name
);
5075 mio_pool_string (&name
);
5078 mio_pool_string (&sym
->name
);
5080 mio_pool_string (&sym
->module
);
5081 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5083 label
= sym
->binding_label
;
5084 mio_pool_string (&label
);
5087 write_atom (ATOM_STRING
, "");
5089 mio_pointer_ref (&sym
->ns
);
5096 /* Recursive traversal function to write the initial set of symbols to
5097 the module. We check to see if the symbol should be written
5098 according to the access specification. */
5101 write_symbol0 (gfc_symtree
*st
)
5105 bool dont_write
= false;
5110 write_symbol0 (st
->left
);
5113 if (sym
->module
== NULL
)
5114 sym
->module
= module_name
;
5116 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5117 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5120 if (!gfc_check_symbol_access (sym
))
5125 p
= get_pointer (sym
);
5126 if (p
->type
== P_UNKNOWN
)
5129 if (p
->u
.wsym
.state
!= WRITTEN
)
5131 write_symbol (p
->integer
, sym
);
5132 p
->u
.wsym
.state
= WRITTEN
;
5136 write_symbol0 (st
->right
);
5140 /* Recursive traversal function to write the secondary set of symbols
5141 to the module file. These are symbols that were not public yet are
5142 needed by the public symbols or another dependent symbol. The act
5143 of writing a symbol can modify the pointer_info tree, so we cease
5144 traversal if we find a symbol to write. We return nonzero if a
5145 symbol was written and pass that information upwards. */
5148 write_symbol1 (pointer_info
*p
)
5155 result
= write_symbol1 (p
->left
);
5157 if (!(p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
))
5159 p
->u
.wsym
.state
= WRITTEN
;
5160 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
5164 result
|= write_symbol1 (p
->right
);
5169 /* Write operator interfaces associated with a symbol. */
5172 write_operator (gfc_user_op
*uop
)
5174 static char nullstring
[] = "";
5175 const char *p
= nullstring
;
5177 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5180 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5184 /* Write generic interfaces from the namespace sym_root. */
5187 write_generic (gfc_symtree
*st
)
5194 write_generic (st
->left
);
5195 write_generic (st
->right
);
5198 if (!sym
|| check_unique_name (st
->name
))
5201 if (sym
->generic
== NULL
|| !gfc_check_symbol_access (sym
))
5204 if (sym
->module
== NULL
)
5205 sym
->module
= module_name
;
5207 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5212 write_symtree (gfc_symtree
*st
)
5219 /* A symbol in an interface body must not be visible in the
5221 if (sym
->ns
!= gfc_current_ns
5222 && sym
->ns
->proc_name
5223 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5226 if (!gfc_check_symbol_access (sym
)
5227 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5228 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5231 if (check_unique_name (st
->name
))
5234 p
= find_pointer (sym
);
5236 gfc_internal_error ("write_symtree(): Symbol not written");
5238 mio_pool_string (&st
->name
);
5239 mio_integer (&st
->ambiguous
);
5240 mio_integer (&p
->integer
);
5249 /* Write the operator interfaces. */
5252 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5254 if (i
== INTRINSIC_USER
)
5257 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5258 gfc_current_ns
->default_access
)
5259 ? &gfc_current_ns
->op
[i
] : NULL
);
5267 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5273 write_generic (gfc_current_ns
->sym_root
);
5279 write_blank_common ();
5280 write_common (gfc_current_ns
->common_root
);
5292 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
5293 write_derived_extensions
);
5298 /* Write symbol information. First we traverse all symbols in the
5299 primary namespace, writing those that need to be written.
5300 Sometimes writing one symbol will cause another to need to be
5301 written. A list of these symbols ends up on the write stack, and
5302 we end by popping the bottom of the stack and writing the symbol
5303 until the stack is empty. */
5307 write_symbol0 (gfc_current_ns
->sym_root
);
5308 while (write_symbol1 (pi_root
))
5317 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5322 /* Read a MD5 sum from the header of a module file. If the file cannot
5323 be opened, or we have any other error, we return -1. */
5326 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
5332 /* Open the file. */
5333 if ((file
= fopen (filename
, "r")) == NULL
)
5336 /* Read the first line. */
5337 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5343 /* The file also needs to be overwritten if the version number changed. */
5344 n
= strlen ("GFORTRAN module version '" MOD_VERSION
"' created");
5345 if (strncmp (buf
, "GFORTRAN module version '" MOD_VERSION
"' created", n
) != 0)
5351 /* Read a second line. */
5352 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5358 /* Close the file. */
5361 /* If the header is not what we expect, or is too short, bail out. */
5362 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
5365 /* Now, we have a real MD5, read it into the array. */
5366 for (n
= 0; n
< 16; n
++)
5370 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
5380 /* Given module, dump it to disk. If there was an error while
5381 processing the module, dump_flag will be set to zero and we delete
5382 the module file, even if it was already there. */
5385 gfc_dump_module (const char *name
, int dump_flag
)
5388 char *filename
, *filename_tmp
;
5390 unsigned char md5_new
[16], md5_old
[16];
5392 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5393 if (gfc_option
.module_dir
!= NULL
)
5395 n
+= strlen (gfc_option
.module_dir
);
5396 filename
= (char *) alloca (n
);
5397 strcpy (filename
, gfc_option
.module_dir
);
5398 strcat (filename
, name
);
5402 filename
= (char *) alloca (n
);
5403 strcpy (filename
, name
);
5405 strcat (filename
, MODULE_EXTENSION
);
5407 /* Name of the temporary file used to write the module. */
5408 filename_tmp
= (char *) alloca (n
+ 1);
5409 strcpy (filename_tmp
, filename
);
5410 strcat (filename_tmp
, "0");
5412 /* There was an error while processing the module. We delete the
5413 module file, even if it was already there. */
5420 if (gfc_cpp_makedep ())
5421 gfc_cpp_add_target (filename
);
5423 /* Write the module to the temporary file. */
5424 module_fp
= fopen (filename_tmp
, "w");
5425 if (module_fp
== NULL
)
5426 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5427 filename_tmp
, xstrerror (errno
));
5429 /* Write the header, including space reserved for the MD5 sum. */
5430 fprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n"
5431 "MD5:", MOD_VERSION
, gfc_source_file
);
5432 fgetpos (module_fp
, &md5_pos
);
5433 fputs ("00000000000000000000000000000000 -- "
5434 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
5436 /* Initialize the MD5 context that will be used for output. */
5437 md5_init_ctx (&ctx
);
5439 /* Write the module itself. */
5441 module_name
= gfc_get_string (name
);
5447 free_pi_tree (pi_root
);
5452 /* Write the MD5 sum to the header of the module file. */
5453 md5_finish_ctx (&ctx
, md5_new
);
5454 fsetpos (module_fp
, &md5_pos
);
5455 for (n
= 0; n
< 16; n
++)
5456 fprintf (module_fp
, "%02x", md5_new
[n
]);
5458 if (fclose (module_fp
))
5459 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5460 filename_tmp
, xstrerror (errno
));
5462 /* Read the MD5 from the header of the old module file and compare. */
5463 if (read_md5_from_module_file (filename
, md5_old
) != 0
5464 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
5466 /* Module file have changed, replace the old one. */
5467 if (unlink (filename
) && errno
!= ENOENT
)
5468 gfc_fatal_error ("Can't delete module file '%s': %s", filename
,
5470 if (rename (filename_tmp
, filename
))
5471 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5472 filename_tmp
, filename
, xstrerror (errno
));
5476 if (unlink (filename_tmp
))
5477 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5478 filename_tmp
, xstrerror (errno
));
5484 create_intrinsic_function (const char *name
, gfc_isym_id id
,
5485 const char *modname
, intmod_id module
)
5487 gfc_intrinsic_sym
*isym
;
5488 gfc_symtree
*tmp_symtree
;
5491 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5494 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5496 gfc_error ("Symbol '%s' already declared", name
);
5499 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5500 sym
= tmp_symtree
->n
.sym
;
5502 isym
= gfc_intrinsic_function_by_id (id
);
5505 sym
->attr
.flavor
= FL_PROCEDURE
;
5506 sym
->attr
.intrinsic
= 1;
5508 sym
->module
= gfc_get_string (modname
);
5509 sym
->attr
.use_assoc
= 1;
5510 sym
->from_intmod
= module
;
5511 sym
->intmod_sym_id
= id
;
5515 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5516 the current namespace for all named constants, pointer types, and
5517 procedures in the module unless the only clause was used or a rename
5518 list was provided. */
5521 import_iso_c_binding_module (void)
5523 gfc_symbol
*mod_sym
= NULL
;
5524 gfc_symtree
*mod_symtree
= NULL
;
5525 const char *iso_c_module_name
= "__iso_c_binding";
5529 /* Look only in the current namespace. */
5530 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
5532 if (mod_symtree
== NULL
)
5534 /* symtree doesn't already exist in current namespace. */
5535 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
5538 if (mod_symtree
!= NULL
)
5539 mod_sym
= mod_symtree
->n
.sym
;
5541 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5542 "create symbol for %s", iso_c_module_name
);
5544 mod_sym
->attr
.flavor
= FL_MODULE
;
5545 mod_sym
->attr
.intrinsic
= 1;
5546 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
5547 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5550 /* Generate the symbols for the named constants representing
5551 the kinds for intrinsic data types. */
5552 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
5555 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5556 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
5565 #define NAMED_FUNCTION(a,b,c,d) \
5567 not_in_std = (gfc_option.allow_std & d) == 0; \
5570 #include "iso-c-binding.def"
5571 #undef NAMED_FUNCTION
5572 #define NAMED_INTCST(a,b,c,d) \
5574 not_in_std = (gfc_option.allow_std & d) == 0; \
5577 #include "iso-c-binding.def"
5579 #define NAMED_REALCST(a,b,c,d) \
5581 not_in_std = (gfc_option.allow_std & d) == 0; \
5584 #include "iso-c-binding.def"
5585 #undef NAMED_REALCST
5586 #define NAMED_CMPXCST(a,b,c,d) \
5588 not_in_std = (gfc_option.allow_std & d) == 0; \
5591 #include "iso-c-binding.def"
5592 #undef NAMED_CMPXCST
5600 gfc_error ("The symbol '%s', referenced at %L, is not "
5601 "in the selected standard", name
, &u
->where
);
5607 #define NAMED_FUNCTION(a,b,c,d) \
5609 create_intrinsic_function (u->local_name[0] ? u->local_name \
5612 iso_c_module_name, \
5613 INTMOD_ISO_C_BINDING); \
5615 #include "iso-c-binding.def"
5616 #undef NAMED_FUNCTION
5619 generate_isocbinding_symbol (iso_c_module_name
,
5620 (iso_c_binding_symbol
) i
,
5621 u
->local_name
[0] ? u
->local_name
5626 if (!found
&& !only_flag
)
5628 /* Skip, if the symbol is not in the enabled standard. */
5631 #define NAMED_FUNCTION(a,b,c,d) \
5633 if ((gfc_option.allow_std & d) == 0) \
5636 #include "iso-c-binding.def"
5637 #undef NAMED_FUNCTION
5639 #define NAMED_INTCST(a,b,c,d) \
5641 if ((gfc_option.allow_std & d) == 0) \
5644 #include "iso-c-binding.def"
5646 #define NAMED_REALCST(a,b,c,d) \
5648 if ((gfc_option.allow_std & d) == 0) \
5651 #include "iso-c-binding.def"
5652 #undef NAMED_REALCST
5653 #define NAMED_CMPXCST(a,b,c,d) \
5655 if ((gfc_option.allow_std & d) == 0) \
5658 #include "iso-c-binding.def"
5659 #undef NAMED_CMPXCST
5661 ; /* Not GFC_STD_* versioned. */
5666 #define NAMED_FUNCTION(a,b,c,d) \
5668 create_intrinsic_function (b, (gfc_isym_id) c, \
5669 iso_c_module_name, \
5670 INTMOD_ISO_C_BINDING); \
5672 #include "iso-c-binding.def"
5673 #undef NAMED_FUNCTION
5676 generate_isocbinding_symbol (iso_c_module_name
,
5677 (iso_c_binding_symbol
) i
, NULL
);
5682 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5687 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5688 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
5693 /* Add an integer named constant from a given module. */
5696 create_int_parameter (const char *name
, int value
, const char *modname
,
5697 intmod_id module
, int id
)
5699 gfc_symtree
*tmp_symtree
;
5702 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5703 if (tmp_symtree
!= NULL
)
5705 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5708 gfc_error ("Symbol '%s' already declared", name
);
5711 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5712 sym
= tmp_symtree
->n
.sym
;
5714 sym
->module
= gfc_get_string (modname
);
5715 sym
->attr
.flavor
= FL_PARAMETER
;
5716 sym
->ts
.type
= BT_INTEGER
;
5717 sym
->ts
.kind
= gfc_default_integer_kind
;
5718 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
5719 sym
->attr
.use_assoc
= 1;
5720 sym
->from_intmod
= module
;
5721 sym
->intmod_sym_id
= id
;
5725 /* Value is already contained by the array constructor, but not
5729 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
5730 const char *modname
, intmod_id module
, int id
)
5732 gfc_symtree
*tmp_symtree
;
5735 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5736 if (tmp_symtree
!= NULL
)
5738 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5741 gfc_error ("Symbol '%s' already declared", name
);
5744 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5745 sym
= tmp_symtree
->n
.sym
;
5747 sym
->module
= gfc_get_string (modname
);
5748 sym
->attr
.flavor
= FL_PARAMETER
;
5749 sym
->ts
.type
= BT_INTEGER
;
5750 sym
->ts
.kind
= gfc_default_integer_kind
;
5751 sym
->attr
.use_assoc
= 1;
5752 sym
->from_intmod
= module
;
5753 sym
->intmod_sym_id
= id
;
5754 sym
->attr
.dimension
= 1;
5755 sym
->as
= gfc_get_array_spec ();
5757 sym
->as
->type
= AS_EXPLICIT
;
5758 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5759 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
5762 sym
->value
->shape
= gfc_get_shape (1);
5763 mpz_init_set_ui (sym
->value
->shape
[0], size
);
5767 /* Add an derived type for a given module. */
5770 create_derived_type (const char *name
, const char *modname
,
5771 intmod_id module
, int id
)
5773 gfc_symtree
*tmp_symtree
;
5774 gfc_symbol
*sym
, *dt_sym
;
5775 gfc_interface
*intr
, *head
;
5777 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5778 if (tmp_symtree
!= NULL
)
5780 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5783 gfc_error ("Symbol '%s' already declared", name
);
5786 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5787 sym
= tmp_symtree
->n
.sym
;
5788 sym
->module
= gfc_get_string (modname
);
5789 sym
->from_intmod
= module
;
5790 sym
->intmod_sym_id
= id
;
5791 sym
->attr
.flavor
= FL_PROCEDURE
;
5792 sym
->attr
.function
= 1;
5793 sym
->attr
.generic
= 1;
5795 gfc_get_sym_tree (dt_upper_string (sym
->name
),
5796 gfc_current_ns
, &tmp_symtree
, false);
5797 dt_sym
= tmp_symtree
->n
.sym
;
5798 dt_sym
->name
= gfc_get_string (sym
->name
);
5799 dt_sym
->attr
.flavor
= FL_DERIVED
;
5800 dt_sym
->attr
.private_comp
= 1;
5801 dt_sym
->attr
.zero_comp
= 1;
5802 dt_sym
->attr
.use_assoc
= 1;
5803 dt_sym
->module
= gfc_get_string (modname
);
5804 dt_sym
->from_intmod
= module
;
5805 dt_sym
->intmod_sym_id
= id
;
5807 head
= sym
->generic
;
5808 intr
= gfc_get_interface ();
5810 intr
->where
= gfc_current_locus
;
5812 sym
->generic
= intr
;
5813 sym
->attr
.if_source
= IFSRC_DECL
;
5817 /* USE the ISO_FORTRAN_ENV intrinsic module. */
5820 use_iso_fortran_env_module (void)
5822 static char mod
[] = "iso_fortran_env";
5824 gfc_symbol
*mod_sym
;
5825 gfc_symtree
*mod_symtree
;
5829 intmod_sym symbol
[] = {
5830 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5831 #include "iso-fortran-env.def"
5833 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5834 #include "iso-fortran-env.def"
5835 #undef NAMED_KINDARRAY
5836 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
5837 #include "iso-fortran-env.def"
5838 #undef NAMED_DERIVED_TYPE
5839 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5840 #include "iso-fortran-env.def"
5841 #undef NAMED_FUNCTION
5842 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
5845 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5846 #include "iso-fortran-env.def"
5849 /* Generate the symbol for the module itself. */
5850 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
5851 if (mod_symtree
== NULL
)
5853 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
5854 gcc_assert (mod_symtree
);
5855 mod_sym
= mod_symtree
->n
.sym
;
5857 mod_sym
->attr
.flavor
= FL_MODULE
;
5858 mod_sym
->attr
.intrinsic
= 1;
5859 mod_sym
->module
= gfc_get_string (mod
);
5860 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
5863 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
5864 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5865 "non-intrinsic module name used previously", mod
);
5867 /* Generate the symbols for the module integer named constants. */
5869 for (i
= 0; symbol
[i
].name
; i
++)
5872 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5874 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
5879 if (gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
5880 "referenced at %L, is not in the selected "
5881 "standard", symbol
[i
].name
,
5882 &u
->where
) == FAILURE
)
5885 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5886 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5887 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5888 "constant from intrinsic module "
5889 "ISO_FORTRAN_ENV at %L is incompatible with "
5890 "option %s", &u
->where
,
5891 gfc_option
.flag_default_integer
5892 ? "-fdefault-integer-8"
5893 : "-fdefault-real-8");
5894 switch (symbol
[i
].id
)
5896 #define NAMED_INTCST(a,b,c,d) \
5898 #include "iso-fortran-env.def"
5900 create_int_parameter (u
->local_name
[0] ? u
->local_name
5902 symbol
[i
].value
, mod
,
5903 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
5906 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5908 expr = gfc_get_array_expr (BT_INTEGER, \
5909 gfc_default_integer_kind,\
5911 for (j = 0; KINDS[j].kind != 0; j++) \
5912 gfc_constructor_append_expr (&expr->value.constructor, \
5913 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5914 KINDS[j].kind), NULL); \
5915 create_int_parameter_array (u->local_name[0] ? u->local_name \
5918 INTMOD_ISO_FORTRAN_ENV, \
5921 #include "iso-fortran-env.def"
5922 #undef NAMED_KINDARRAY
5924 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5926 #include "iso-fortran-env.def"
5927 create_derived_type (u
->local_name
[0] ? u
->local_name
5929 mod
, INTMOD_ISO_FORTRAN_ENV
,
5932 #undef NAMED_DERIVED_TYPE
5934 #define NAMED_FUNCTION(a,b,c,d) \
5936 #include "iso-fortran-env.def"
5937 #undef NAMED_FUNCTION
5938 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
5940 (gfc_isym_id
) symbol
[i
].value
, mod
,
5941 INTMOD_ISO_FORTRAN_ENV
);
5950 if (!found
&& !only_flag
)
5952 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
5955 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5956 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5957 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5958 "from intrinsic module ISO_FORTRAN_ENV at %C is "
5959 "incompatible with option %s",
5960 gfc_option
.flag_default_integer
5961 ? "-fdefault-integer-8" : "-fdefault-real-8");
5963 switch (symbol
[i
].id
)
5965 #define NAMED_INTCST(a,b,c,d) \
5967 #include "iso-fortran-env.def"
5969 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
5970 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
5973 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5975 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
5977 for (j = 0; KINDS[j].kind != 0; j++) \
5978 gfc_constructor_append_expr (&expr->value.constructor, \
5979 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5980 KINDS[j].kind), NULL); \
5981 create_int_parameter_array (symbol[i].name, j, expr, mod, \
5982 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
5984 #include "iso-fortran-env.def"
5985 #undef NAMED_KINDARRAY
5987 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
5989 #include "iso-fortran-env.def"
5990 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
5993 #undef NAMED_DERIVED_TYPE
5995 #define NAMED_FUNCTION(a,b,c,d) \
5997 #include "iso-fortran-env.def"
5998 #undef NAMED_FUNCTION
5999 create_intrinsic_function (symbol
[i
].name
,
6000 (gfc_isym_id
) symbol
[i
].value
, mod
,
6001 INTMOD_ISO_FORTRAN_ENV
);
6010 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6015 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6016 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6021 /* Process a USE directive. */
6024 gfc_use_module (gfc_use_list
*module
)
6029 gfc_symtree
*mod_symtree
;
6030 gfc_use_list
*use_stmt
;
6031 locus old_locus
= gfc_current_locus
;
6033 gfc_current_locus
= module
->where
;
6034 module_name
= module
->module_name
;
6035 gfc_rename_list
= module
->rename
;
6036 only_flag
= module
->only_flag
;
6038 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6040 strcpy (filename
, module_name
);
6041 strcat (filename
, MODULE_EXTENSION
);
6043 /* First, try to find an non-intrinsic module, unless the USE statement
6044 specified that the module is intrinsic. */
6046 if (!module
->intrinsic
)
6047 module_fp
= gfc_open_included_file (filename
, true, true);
6049 /* Then, see if it's an intrinsic one, unless the USE statement
6050 specified that the module is non-intrinsic. */
6051 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6053 if (strcmp (module_name
, "iso_fortran_env") == 0
6054 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6055 "intrinsic module at %C") != FAILURE
)
6057 use_iso_fortran_env_module ();
6058 gfc_current_locus
= old_locus
;
6059 module
->intrinsic
= true;
6063 if (strcmp (module_name
, "iso_c_binding") == 0
6064 && gfc_notify_std (GFC_STD_F2003
,
6065 "ISO_C_BINDING module at %C") != FAILURE
)
6067 import_iso_c_binding_module();
6068 gfc_current_locus
= old_locus
;
6069 module
->intrinsic
= true;
6073 module_fp
= gfc_open_intrinsic_module (filename
);
6075 if (module_fp
== NULL
&& module
->intrinsic
)
6076 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6080 if (module_fp
== NULL
)
6081 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6082 filename
, xstrerror (errno
));
6084 /* Check that we haven't already USEd an intrinsic module with the
6087 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6088 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6089 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6090 "intrinsic module name used previously", module_name
);
6097 /* Skip the first two lines of the module, after checking that this is
6098 a gfortran module file. */
6104 bad_module ("Unexpected end of module");
6107 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6108 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6109 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6110 " module file", filename
);
6113 if (strcmp (atom_name
, " version") != 0
6114 || module_char () != ' '
6115 || parse_atom () != ATOM_STRING
6116 || strcmp (atom_string
, MOD_VERSION
))
6117 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6118 " because it was created by a different"
6119 " version of GNU Fortran", filename
);
6128 /* Make sure we're not reading the same module that we may be building. */
6129 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6130 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6131 gfc_fatal_error ("Can't USE the same module we're building!");
6134 init_true_name_tree ();
6138 free_true_name (true_name_root
);
6139 true_name_root
= NULL
;
6141 free_pi_tree (pi_root
);
6146 use_stmt
= gfc_get_use_list ();
6147 *use_stmt
= *module
;
6148 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6149 gfc_current_ns
->use_stmts
= use_stmt
;
6151 gfc_current_locus
= old_locus
;
6155 /* Remove duplicated intrinsic operators from the rename list. */
6158 rename_list_remove_duplicate (gfc_use_rename
*list
)
6160 gfc_use_rename
*seek
, *last
;
6162 for (; list
; list
= list
->next
)
6163 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6166 for (seek
= list
->next
; seek
; seek
= last
->next
)
6168 if (list
->op
== seek
->op
)
6170 last
->next
= seek
->next
;
6180 /* Process all USE directives. */
6183 gfc_use_modules (void)
6185 gfc_use_list
*next
, *seek
, *last
;
6187 for (next
= module_list
; next
; next
= next
->next
)
6189 bool non_intrinsic
= next
->non_intrinsic
;
6190 bool intrinsic
= next
->intrinsic
;
6191 bool neither
= !non_intrinsic
&& !intrinsic
;
6193 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6195 if (next
->module_name
!= seek
->module_name
)
6198 if (seek
->non_intrinsic
)
6199 non_intrinsic
= true;
6200 else if (seek
->intrinsic
)
6206 if (intrinsic
&& neither
&& !non_intrinsic
)
6211 filename
= XALLOCAVEC (char,
6212 strlen (next
->module_name
)
6213 + strlen (MODULE_EXTENSION
) + 1);
6214 strcpy (filename
, next
->module_name
);
6215 strcat (filename
, MODULE_EXTENSION
);
6216 fp
= gfc_open_included_file (filename
, true, true);
6219 non_intrinsic
= true;
6225 for (seek
= next
->next
; seek
; seek
= last
->next
)
6227 if (next
->module_name
!= seek
->module_name
)
6233 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6234 || (next
->intrinsic
&& seek
->intrinsic
)
6237 if (!seek
->only_flag
)
6238 next
->only_flag
= false;
6241 gfc_use_rename
*r
= seek
->rename
;
6244 r
->next
= next
->rename
;
6245 next
->rename
= seek
->rename
;
6247 last
->next
= seek
->next
;
6255 for (; module_list
; module_list
= next
)
6257 next
= module_list
->next
;
6258 rename_list_remove_duplicate (module_list
->rename
);
6259 gfc_use_module (module_list
);
6260 if (module_list
->intrinsic
)
6261 free_rename (module_list
->rename
);
6264 gfc_rename_list
= NULL
;
6269 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6272 for (; use_stmts
; use_stmts
= next
)
6274 gfc_use_rename
*next_rename
;
6276 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6278 next_rename
= use_stmts
->rename
->next
;
6279 free (use_stmts
->rename
);
6281 next
= use_stmts
->next
;
6288 gfc_module_init_2 (void)
6290 last_atom
= ATOM_LPAREN
;
6291 gfc_rename_list
= NULL
;
6297 gfc_module_done_2 (void)
6299 free_rename (gfc_rename_list
);
6300 gfc_rename_list
= NULL
;