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
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* The syntax of gfortran modules resembles that of lisp lists, ie a
24 sequence of atoms, which can be left or right parenthesis, names,
25 integers or strings. Parenthesis are always matched which allows
26 us to skip over sections at high speed without having to know
27 anything about the internal structure of the lists. A "name" is
28 usually a fortran 95 identifier, but can also start with '@' in
29 order to reference a hidden symbol.
31 The first line of a module is an informational message about what
32 created the module, the file it came from and when it was created.
33 The second line is a warning for people not to edit the module.
34 The rest of the module looks like:
36 ( ( <Interface info for UPLUS> )
37 ( <Interface info for UMINUS> )
40 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
43 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
46 ( ( <common name> <symbol> <saved flag>)
52 ( <Symbol Number (in no particular order)>
54 <Module name of symbol>
55 ( <symbol information> )
64 In general, symbols refer to other symbols by their symbol number,
65 which are zero based. Symbols are written to the module in no
73 #include "parse.h" /* FIXME */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
88 /* Structure for list of symbols of intrinsic modules. */
100 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
104 /* The fixup structure lists pointers to pointers that have to
105 be updated when a pointer value becomes known. */
107 typedef struct fixup_t
110 struct fixup_t
*next
;
115 /* Structure for holding extra info needed for pointers being read. */
117 typedef struct pointer_info
119 BBT_HEADER (pointer_info
);
123 /* The first component of each member of the union is the pointer
130 void *pointer
; /* Member for doing pointer searches. */
135 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
137 { UNUSED
, NEEDED
, USED
}
142 gfc_symtree
*symtree
;
143 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
151 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
161 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
164 /* Lists of rename info for the USE statement. */
166 typedef struct gfc_use_rename
168 char local_name
[GFC_MAX_SYMBOL_LEN
+ 1], use_name
[GFC_MAX_SYMBOL_LEN
+ 1];
169 struct gfc_use_rename
*next
;
171 gfc_intrinsic_op
operator;
176 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
178 /* Local variables */
180 /* The FILE for the module we're reading or writing. */
181 static FILE *module_fp
;
183 /* MD5 context structure. */
184 static struct md5_ctx ctx
;
186 /* The name of the module we're reading (USE'ing) or writing. */
187 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
189 /* The way the module we're reading was specified. */
190 static bool specified_nonint
, specified_int
;
192 static int module_line
, module_column
, only_flag
;
194 { IO_INPUT
, IO_OUTPUT
}
197 static gfc_use_rename
*gfc_rename_list
;
198 static pointer_info
*pi_root
;
199 static int symbol_number
; /* Counter for assigning symbol numbers */
201 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
202 static bool in_load_equiv
;
206 /*****************************************************************/
208 /* Pointer/integer conversion. Pointers between structures are stored
209 as integers in the module file. The next couple of subroutines
210 handle this translation for reading and writing. */
212 /* Recursively free the tree of pointer structures. */
215 free_pi_tree (pointer_info
*p
)
220 if (p
->fixup
!= NULL
)
221 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
223 free_pi_tree (p
->left
);
224 free_pi_tree (p
->right
);
230 /* Compare pointers when searching by pointer. Used when writing a
234 compare_pointers (void *_sn1
, void *_sn2
)
236 pointer_info
*sn1
, *sn2
;
238 sn1
= (pointer_info
*) _sn1
;
239 sn2
= (pointer_info
*) _sn2
;
241 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
243 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
250 /* Compare integers when searching by integer. Used when reading a
254 compare_integers (void *_sn1
, void *_sn2
)
256 pointer_info
*sn1
, *sn2
;
258 sn1
= (pointer_info
*) _sn1
;
259 sn2
= (pointer_info
*) _sn2
;
261 if (sn1
->integer
< sn2
->integer
)
263 if (sn1
->integer
> sn2
->integer
)
270 /* Initialize the pointer_info tree. */
279 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
281 /* Pointer 0 is the NULL pointer. */
282 p
= gfc_get_pointer_info ();
287 gfc_insert_bbt (&pi_root
, p
, compare
);
289 /* Pointer 1 is the current namespace. */
290 p
= gfc_get_pointer_info ();
291 p
->u
.pointer
= gfc_current_ns
;
293 p
->type
= P_NAMESPACE
;
295 gfc_insert_bbt (&pi_root
, p
, compare
);
301 /* During module writing, call here with a pointer to something,
302 returning the pointer_info node. */
304 static pointer_info
*
305 find_pointer (void *gp
)
312 if (p
->u
.pointer
== gp
)
314 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
321 /* Given a pointer while writing, returns the pointer_info tree node,
322 creating it if it doesn't exist. */
324 static pointer_info
*
325 get_pointer (void *gp
)
329 p
= find_pointer (gp
);
333 /* Pointer doesn't have an integer. Give it one. */
334 p
= gfc_get_pointer_info ();
337 p
->integer
= symbol_number
++;
339 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
345 /* Given an integer during reading, find it in the pointer_info tree,
346 creating the node if not found. */
348 static pointer_info
*
349 get_integer (int integer
)
359 c
= compare_integers (&t
, p
);
363 p
= (c
< 0) ? p
->left
: p
->right
;
369 p
= gfc_get_pointer_info ();
370 p
->integer
= integer
;
373 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
379 /* Recursive function to find a pointer within a tree by brute force. */
381 static pointer_info
*
382 fp2 (pointer_info
*p
, const void *target
)
389 if (p
->u
.pointer
== target
)
392 q
= fp2 (p
->left
, target
);
396 return fp2 (p
->right
, target
);
400 /* During reading, find a pointer_info node from the pointer value.
401 This amounts to a brute-force search. */
403 static pointer_info
*
404 find_pointer2 (void *p
)
406 return fp2 (pi_root
, p
);
410 /* Resolve any fixups using a known pointer. */
413 resolve_fixups (fixup_t
*f
, void *gp
)
426 /* Call here during module reading when we know what pointer to
427 associate with an integer. Any fixups that exist are resolved at
431 associate_integer_pointer (pointer_info
*p
, void *gp
)
433 if (p
->u
.pointer
!= NULL
)
434 gfc_internal_error ("associate_integer_pointer(): Already associated");
438 resolve_fixups (p
->fixup
, gp
);
444 /* During module reading, given an integer and a pointer to a pointer,
445 either store the pointer from an already-known value or create a
446 fixup structure in order to store things later. Returns zero if
447 the reference has been actually stored, or nonzero if the reference
448 must be fixed later (ie associate_integer_pointer must be called
449 sometime later. Returns the pointer_info structure. */
451 static pointer_info
*
452 add_fixup (int integer
, void *gp
)
458 p
= get_integer (integer
);
460 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
467 f
= gfc_getmem (sizeof (fixup_t
));
479 /*****************************************************************/
481 /* Parser related subroutines */
483 /* Free the rename list left behind by a USE statement. */
488 gfc_use_rename
*next
;
490 for (; gfc_rename_list
; gfc_rename_list
= next
)
492 next
= gfc_rename_list
->next
;
493 gfc_free (gfc_rename_list
);
498 /* Match a USE statement. */
503 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
504 gfc_use_rename
*tail
= NULL
, *new;
505 interface_type type
, type2
;
506 gfc_intrinsic_op
operator;
509 specified_int
= false;
510 specified_nonint
= false;
512 if (gfc_match (" , ") == MATCH_YES
)
514 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
516 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: module "
517 "nature in USE statement at %C") == FAILURE
)
520 if (strcmp (module_nature
, "intrinsic") == 0)
521 specified_int
= true;
524 if (strcmp (module_nature
, "non_intrinsic") == 0)
525 specified_nonint
= true;
528 gfc_error ("Module nature in USE statement at %C shall "
529 "be either INTRINSIC or NON_INTRINSIC");
536 /* Help output a better error message than "Unclassifiable
538 gfc_match (" %n", module_nature
);
539 if (strcmp (module_nature
, "intrinsic") == 0
540 || strcmp (module_nature
, "non_intrinsic") == 0)
541 gfc_error ("\"::\" was expected after module nature at %C "
542 "but was not found");
548 m
= gfc_match (" ::");
549 if (m
== MATCH_YES
&&
550 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
551 "\"USE :: module\" at %C") == FAILURE
)
556 m
= gfc_match ("% ");
562 m
= gfc_match_name (module_name
);
569 if (gfc_match_eos () == MATCH_YES
)
571 if (gfc_match_char (',') != MATCH_YES
)
574 if (gfc_match (" only :") == MATCH_YES
)
577 if (gfc_match_eos () == MATCH_YES
)
582 /* Get a new rename struct and add it to the rename list. */
583 new = gfc_get_use_rename ();
584 new->where
= gfc_current_locus
;
587 if (gfc_rename_list
== NULL
)
588 gfc_rename_list
= new;
593 /* See what kind of interface we're dealing with. Assume it is
595 new->operator = INTRINSIC_NONE
;
596 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
601 case INTERFACE_NAMELESS
:
602 gfc_error ("Missing generic specification in USE statement at %C");
605 case INTERFACE_USER_OP
:
606 case INTERFACE_GENERIC
:
607 m
= gfc_match (" =>");
609 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
610 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Renaming "
611 "operators in USE statements at %C")
618 strcpy (new->use_name
, name
);
621 strcpy (new->local_name
, name
);
622 m
= gfc_match_generic_spec (&type2
, new->use_name
, &operator);
627 if (m
== MATCH_ERROR
)
635 strcpy (new->local_name
, name
);
637 m
= gfc_match_generic_spec (&type2
, new->use_name
, &operator);
642 if (m
== MATCH_ERROR
)
646 if (strcmp (new->use_name
, module_name
) == 0
647 || strcmp (new->local_name
, module_name
) == 0)
649 gfc_error ("The name '%s' at %C has already been used as "
650 "an external module name.", module_name
);
655 case INTERFACE_INTRINSIC_OP
:
656 new->operator = operator;
660 if (gfc_match_eos () == MATCH_YES
)
662 if (gfc_match_char (',') != MATCH_YES
)
669 gfc_syntax_error (ST_USE
);
677 /* Given a name and a number, inst, return the inst name
678 under which to load this symbol. Returns NULL if this
679 symbol shouldn't be loaded. If inst is zero, returns
680 the number of instances of this name. */
683 find_use_name_n (const char *name
, int *inst
)
689 for (u
= gfc_rename_list
; u
; u
= u
->next
)
691 if (strcmp (u
->use_name
, name
) != 0)
704 return only_flag
? NULL
: name
;
708 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
712 /* Given a name, return the name under which to load this symbol.
713 Returns NULL if this symbol shouldn't be loaded. */
716 find_use_name (const char *name
)
719 return find_use_name_n (name
, &i
);
723 /* Given a real name, return the number of use names associated with it. */
726 number_use_names (const char *name
)
730 c
= find_use_name_n (name
, &i
);
735 /* Try to find the operator in the current list. */
737 static gfc_use_rename
*
738 find_use_operator (gfc_intrinsic_op
operator)
742 for (u
= gfc_rename_list
; u
; u
= u
->next
)
743 if (u
->operator == operator)
750 /*****************************************************************/
752 /* The next couple of subroutines maintain a tree used to avoid a
753 brute-force search for a combination of true name and module name.
754 While symtree names, the name that a particular symbol is known by
755 can changed with USE statements, we still have to keep track of the
756 true names to generate the correct reference, and also avoid
757 loading the same real symbol twice in a program unit.
759 When we start reading, the true name tree is built and maintained
760 as symbols are read. The tree is searched as we load new symbols
761 to see if it already exists someplace in the namespace. */
763 typedef struct true_name
765 BBT_HEADER (true_name
);
770 static true_name
*true_name_root
;
773 /* Compare two true_name structures. */
776 compare_true_names (void *_t1
, void *_t2
)
781 t1
= (true_name
*) _t1
;
782 t2
= (true_name
*) _t2
;
784 c
= ((t1
->sym
->module
> t2
->sym
->module
)
785 - (t1
->sym
->module
< t2
->sym
->module
));
789 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
793 /* Given a true name, search the true name tree to see if it exists
794 within the main namespace. */
797 find_true_name (const char *name
, const char *module
)
803 sym
.name
= gfc_get_string (name
);
805 sym
.module
= gfc_get_string (module
);
813 c
= compare_true_names ((void *) (&t
), (void *) p
);
817 p
= (c
< 0) ? p
->left
: p
->right
;
824 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
827 add_true_name (gfc_symbol
*sym
)
831 t
= gfc_getmem (sizeof (true_name
));
834 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
838 /* Recursive function to build the initial true name tree by
839 recursively traversing the current namespace. */
842 build_tnt (gfc_symtree
*st
)
847 build_tnt (st
->left
);
848 build_tnt (st
->right
);
850 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
853 add_true_name (st
->n
.sym
);
857 /* Initialize the true name tree with the current namespace. */
860 init_true_name_tree (void)
862 true_name_root
= NULL
;
863 build_tnt (gfc_current_ns
->sym_root
);
867 /* Recursively free a true name tree node. */
870 free_true_name (true_name
*t
)
874 free_true_name (t
->left
);
875 free_true_name (t
->right
);
881 /*****************************************************************/
883 /* Module reading and writing. */
887 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
891 static atom_type last_atom
;
894 /* The name buffer must be at least as long as a symbol name. Right
895 now it's not clear how we're going to store numeric constants--
896 probably as a hexadecimal string, since this will allow the exact
897 number to be preserved (this can't be done by a decimal
898 representation). Worry about that later. TODO! */
900 #define MAX_ATOM_SIZE 100
903 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
906 /* Report problems with a module. Error reporting is not very
907 elaborate, since this sorts of errors shouldn't really happen.
908 This subroutine never returns. */
910 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
913 bad_module (const char *msgid
)
920 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
921 module_name
, module_line
, module_column
, msgid
);
924 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
925 module_name
, module_line
, module_column
, msgid
);
928 gfc_fatal_error ("Module %s at line %d column %d: %s",
929 module_name
, module_line
, module_column
, msgid
);
935 /* Set the module's input pointer. */
938 set_module_locus (module_locus
*m
)
940 module_column
= m
->column
;
941 module_line
= m
->line
;
942 fsetpos (module_fp
, &m
->pos
);
946 /* Get the module's input pointer so that we can restore it later. */
949 get_module_locus (module_locus
*m
)
951 m
->column
= module_column
;
952 m
->line
= module_line
;
953 fgetpos (module_fp
, &m
->pos
);
957 /* Get the next character in the module, updating our reckoning of
965 c
= getc (module_fp
);
968 bad_module ("Unexpected EOF");
981 /* Parse a string constant. The delimiter is guaranteed to be a
991 get_module_locus (&start
);
995 /* See how long the string is. */
1000 bad_module ("Unexpected end of module in string constant");
1018 set_module_locus (&start
);
1020 atom_string
= p
= gfc_getmem (len
+ 1);
1022 for (; len
> 0; len
--)
1026 module_char (); /* Guaranteed to be another \'. */
1030 module_char (); /* Terminating \'. */
1031 *p
= '\0'; /* C-style string for debug purposes. */
1035 /* Parse a small integer. */
1038 parse_integer (int c
)
1046 get_module_locus (&m
);
1052 atom_int
= 10 * atom_int
+ c
- '0';
1053 if (atom_int
> 99999999)
1054 bad_module ("Integer overflow");
1057 set_module_locus (&m
);
1075 get_module_locus (&m
);
1080 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1084 if (++len
> GFC_MAX_SYMBOL_LEN
)
1085 bad_module ("Name too long");
1090 fseek (module_fp
, -1, SEEK_CUR
);
1091 module_column
= m
.column
+ len
- 1;
1098 /* Read the next atom in the module's input stream. */
1109 while (c
== ' ' || c
== '\n');
1134 return ATOM_INTEGER
;
1192 bad_module ("Bad name");
1199 /* Peek at the next atom on the input. */
1207 get_module_locus (&m
);
1210 if (a
== ATOM_STRING
)
1211 gfc_free (atom_string
);
1213 set_module_locus (&m
);
1218 /* Read the next atom from the input, requiring that it be a
1222 require_atom (atom_type type
)
1228 get_module_locus (&m
);
1236 p
= _("Expected name");
1239 p
= _("Expected left parenthesis");
1242 p
= _("Expected right parenthesis");
1245 p
= _("Expected integer");
1248 p
= _("Expected string");
1251 gfc_internal_error ("require_atom(): bad atom type required");
1254 set_module_locus (&m
);
1260 /* Given a pointer to an mstring array, require that the current input
1261 be one of the strings in the array. We return the enum value. */
1264 find_enum (const mstring
*m
)
1268 i
= gfc_string2code (m
, atom_name
);
1272 bad_module ("find_enum(): Enum not found");
1278 /**************** Module output subroutines ***************************/
1280 /* Output a character to a module file. */
1283 write_char (char out
)
1285 if (putc (out
, module_fp
) == EOF
)
1286 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1288 /* Add this to our MD5. */
1289 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1301 /* Write an atom to a module. The line wrapping isn't perfect, but it
1302 should work most of the time. This isn't that big of a deal, since
1303 the file really isn't meant to be read by people anyway. */
1306 write_atom (atom_type atom
, const void *v
)
1328 i
= *((const int *) v
);
1330 gfc_internal_error ("write_atom(): Writing negative integer");
1332 sprintf (buffer
, "%d", i
);
1337 gfc_internal_error ("write_atom(): Trying to write dab atom");
1341 if(p
== NULL
|| *p
== '\0')
1346 if (atom
!= ATOM_RPAREN
)
1348 if (module_column
+ len
> 72)
1353 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1358 if (atom
== ATOM_STRING
)
1361 while (p
!= NULL
&& *p
)
1363 if (atom
== ATOM_STRING
&& *p
== '\'')
1368 if (atom
== ATOM_STRING
)
1376 /***************** Mid-level I/O subroutines *****************/
1378 /* These subroutines let their caller read or write atoms without
1379 caring about which of the two is actually happening. This lets a
1380 subroutine concentrate on the actual format of the data being
1383 static void mio_expr (gfc_expr
**);
1384 static void mio_symbol_ref (gfc_symbol
**);
1385 static void mio_symtree_ref (gfc_symtree
**);
1387 /* Read or write an enumerated value. On writing, we return the input
1388 value for the convenience of callers. We avoid using an integer
1389 pointer because enums are sometimes inside bitfields. */
1392 mio_name (int t
, const mstring
*m
)
1394 if (iomode
== IO_OUTPUT
)
1395 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1398 require_atom (ATOM_NAME
);
1405 /* Specialization of mio_name. */
1407 #define DECL_MIO_NAME(TYPE) \
1408 static inline TYPE \
1409 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1411 return (TYPE) mio_name ((int) t, m); \
1413 #define MIO_NAME(TYPE) mio_name_##TYPE
1418 if (iomode
== IO_OUTPUT
)
1419 write_atom (ATOM_LPAREN
, NULL
);
1421 require_atom (ATOM_LPAREN
);
1428 if (iomode
== IO_OUTPUT
)
1429 write_atom (ATOM_RPAREN
, NULL
);
1431 require_atom (ATOM_RPAREN
);
1436 mio_integer (int *ip
)
1438 if (iomode
== IO_OUTPUT
)
1439 write_atom (ATOM_INTEGER
, ip
);
1442 require_atom (ATOM_INTEGER
);
1448 /* Read or write a character pointer that points to a string on the heap. */
1451 mio_allocated_string (const char *s
)
1453 if (iomode
== IO_OUTPUT
)
1455 write_atom (ATOM_STRING
, s
);
1460 require_atom (ATOM_STRING
);
1466 /* Read or write a string that is in static memory. */
1469 mio_pool_string (const char **stringp
)
1471 /* TODO: one could write the string only once, and refer to it via a
1474 /* As a special case we have to deal with a NULL string. This
1475 happens for the 'module' member of 'gfc_symbol's that are not in a
1476 module. We read / write these as the empty string. */
1477 if (iomode
== IO_OUTPUT
)
1479 const char *p
= *stringp
== NULL
? "" : *stringp
;
1480 write_atom (ATOM_STRING
, p
);
1484 require_atom (ATOM_STRING
);
1485 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1486 gfc_free (atom_string
);
1491 /* Read or write a string that is inside of some already-allocated
1495 mio_internal_string (char *string
)
1497 if (iomode
== IO_OUTPUT
)
1498 write_atom (ATOM_STRING
, string
);
1501 require_atom (ATOM_STRING
);
1502 strcpy (string
, atom_string
);
1503 gfc_free (atom_string
);
1509 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1510 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1511 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1512 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1513 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
, AB_ALLOC_COMP
,
1514 AB_POINTER_COMP
, AB_PRIVATE_COMP
, AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
,
1515 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
1519 static const mstring attr_bits
[] =
1521 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1522 minit ("DIMENSION", AB_DIMENSION
),
1523 minit ("EXTERNAL", AB_EXTERNAL
),
1524 minit ("INTRINSIC", AB_INTRINSIC
),
1525 minit ("OPTIONAL", AB_OPTIONAL
),
1526 minit ("POINTER", AB_POINTER
),
1527 minit ("VOLATILE", AB_VOLATILE
),
1528 minit ("TARGET", AB_TARGET
),
1529 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1530 minit ("DUMMY", AB_DUMMY
),
1531 minit ("RESULT", AB_RESULT
),
1532 minit ("DATA", AB_DATA
),
1533 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1534 minit ("IN_COMMON", AB_IN_COMMON
),
1535 minit ("FUNCTION", AB_FUNCTION
),
1536 minit ("SUBROUTINE", AB_SUBROUTINE
),
1537 minit ("SEQUENCE", AB_SEQUENCE
),
1538 minit ("ELEMENTAL", AB_ELEMENTAL
),
1539 minit ("PURE", AB_PURE
),
1540 minit ("RECURSIVE", AB_RECURSIVE
),
1541 minit ("GENERIC", AB_GENERIC
),
1542 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1543 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1544 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1545 minit ("IS_BIND_C", AB_IS_BIND_C
),
1546 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1547 minit ("IS_ISO_C", AB_IS_ISO_C
),
1548 minit ("VALUE", AB_VALUE
),
1549 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1550 minit ("POINTER_COMP", AB_POINTER_COMP
),
1551 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1552 minit ("PROTECTED", AB_PROTECTED
),
1557 /* Specialization of mio_name. */
1558 DECL_MIO_NAME (ab_attribute
)
1559 DECL_MIO_NAME (ar_type
)
1560 DECL_MIO_NAME (array_type
)
1562 DECL_MIO_NAME (expr_t
)
1563 DECL_MIO_NAME (gfc_access
)
1564 DECL_MIO_NAME (gfc_intrinsic_op
)
1565 DECL_MIO_NAME (ifsrc
)
1566 DECL_MIO_NAME (save_state
)
1567 DECL_MIO_NAME (procedure_type
)
1568 DECL_MIO_NAME (ref_type
)
1569 DECL_MIO_NAME (sym_flavor
)
1570 DECL_MIO_NAME (sym_intent
)
1571 #undef DECL_MIO_NAME
1573 /* Symbol attributes are stored in list with the first three elements
1574 being the enumerated fields, while the remaining elements (if any)
1575 indicate the individual attribute bits. The access field is not
1576 saved-- it controls what symbols are exported when a module is
1580 mio_symbol_attribute (symbol_attribute
*attr
)
1586 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1587 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1588 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1589 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1590 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1592 if (iomode
== IO_OUTPUT
)
1594 if (attr
->allocatable
)
1595 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1596 if (attr
->dimension
)
1597 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1599 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1600 if (attr
->intrinsic
)
1601 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1603 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1605 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1606 if (attr
->protected)
1607 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
1609 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
1610 if (attr
->volatile_
)
1611 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
1613 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
1614 if (attr
->threadprivate
)
1615 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
1617 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
1619 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
1620 /* We deliberately don't preserve the "entry" flag. */
1623 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
1624 if (attr
->in_namelist
)
1625 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1626 if (attr
->in_common
)
1627 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1630 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
1631 if (attr
->subroutine
)
1632 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1634 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
1637 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1638 if (attr
->elemental
)
1639 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1641 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
1642 if (attr
->recursive
)
1643 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1644 if (attr
->always_explicit
)
1645 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1646 if (attr
->cray_pointer
)
1647 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
1648 if (attr
->cray_pointee
)
1649 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
1650 if (attr
->is_bind_c
)
1651 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
1652 if (attr
->is_c_interop
)
1653 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
1655 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
1656 if (attr
->alloc_comp
)
1657 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
1658 if (attr
->pointer_comp
)
1659 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
1660 if (attr
->private_comp
)
1661 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
1671 if (t
== ATOM_RPAREN
)
1674 bad_module ("Expected attribute bit name");
1676 switch ((ab_attribute
) find_enum (attr_bits
))
1678 case AB_ALLOCATABLE
:
1679 attr
->allocatable
= 1;
1682 attr
->dimension
= 1;
1688 attr
->intrinsic
= 1;
1697 attr
->protected = 1;
1703 attr
->volatile_
= 1;
1708 case AB_THREADPRIVATE
:
1709 attr
->threadprivate
= 1;
1720 case AB_IN_NAMELIST
:
1721 attr
->in_namelist
= 1;
1724 attr
->in_common
= 1;
1730 attr
->subroutine
= 1;
1739 attr
->elemental
= 1;
1745 attr
->recursive
= 1;
1747 case AB_ALWAYS_EXPLICIT
:
1748 attr
->always_explicit
= 1;
1750 case AB_CRAY_POINTER
:
1751 attr
->cray_pointer
= 1;
1753 case AB_CRAY_POINTEE
:
1754 attr
->cray_pointee
= 1;
1757 attr
->is_bind_c
= 1;
1759 case AB_IS_C_INTEROP
:
1760 attr
->is_c_interop
= 1;
1766 attr
->alloc_comp
= 1;
1768 case AB_POINTER_COMP
:
1769 attr
->pointer_comp
= 1;
1771 case AB_PRIVATE_COMP
:
1772 attr
->private_comp
= 1;
1780 static const mstring bt_types
[] = {
1781 minit ("INTEGER", BT_INTEGER
),
1782 minit ("REAL", BT_REAL
),
1783 minit ("COMPLEX", BT_COMPLEX
),
1784 minit ("LOGICAL", BT_LOGICAL
),
1785 minit ("CHARACTER", BT_CHARACTER
),
1786 minit ("DERIVED", BT_DERIVED
),
1787 minit ("PROCEDURE", BT_PROCEDURE
),
1788 minit ("UNKNOWN", BT_UNKNOWN
),
1789 minit ("VOID", BT_VOID
),
1795 mio_charlen (gfc_charlen
**clp
)
1801 if (iomode
== IO_OUTPUT
)
1805 mio_expr (&cl
->length
);
1809 if (peek_atom () != ATOM_RPAREN
)
1811 cl
= gfc_get_charlen ();
1812 mio_expr (&cl
->length
);
1816 cl
->next
= gfc_current_ns
->cl_list
;
1817 gfc_current_ns
->cl_list
= cl
;
1825 /* Return a symtree node with a name that is guaranteed to be unique
1826 within the namespace and corresponds to an illegal fortran name. */
1828 static gfc_symtree
*
1829 get_unique_symtree (gfc_namespace
*ns
)
1831 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1832 static int serial
= 0;
1834 sprintf (name
, "@%d", serial
++);
1835 return gfc_new_symtree (&ns
->sym_root
, name
);
1839 /* See if a name is a generated name. */
1842 check_unique_name (const char *name
)
1844 return *name
== '@';
1849 mio_typespec (gfc_typespec
*ts
)
1853 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
1855 if (ts
->type
!= BT_DERIVED
)
1856 mio_integer (&ts
->kind
);
1858 mio_symbol_ref (&ts
->derived
);
1860 /* Add info for C interop and is_iso_c. */
1861 mio_integer (&ts
->is_c_interop
);
1862 mio_integer (&ts
->is_iso_c
);
1864 /* If the typespec is for an identifier either from iso_c_binding, or
1865 a constant that was initialized to an identifier from it, use the
1866 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1868 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
1870 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
1872 if (ts
->type
!= BT_CHARACTER
)
1874 /* ts->cl is only valid for BT_CHARACTER. */
1879 mio_charlen (&ts
->cl
);
1885 static const mstring array_spec_types
[] = {
1886 minit ("EXPLICIT", AS_EXPLICIT
),
1887 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
1888 minit ("DEFERRED", AS_DEFERRED
),
1889 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
1895 mio_array_spec (gfc_array_spec
**asp
)
1902 if (iomode
== IO_OUTPUT
)
1910 if (peek_atom () == ATOM_RPAREN
)
1916 *asp
= as
= gfc_get_array_spec ();
1919 mio_integer (&as
->rank
);
1920 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
1922 for (i
= 0; i
< as
->rank
; i
++)
1924 mio_expr (&as
->lower
[i
]);
1925 mio_expr (&as
->upper
[i
]);
1933 /* Given a pointer to an array reference structure (which lives in a
1934 gfc_ref structure), find the corresponding array specification
1935 structure. Storing the pointer in the ref structure doesn't quite
1936 work when loading from a module. Generating code for an array
1937 reference also needs more information than just the array spec. */
1939 static const mstring array_ref_types
[] = {
1940 minit ("FULL", AR_FULL
),
1941 minit ("ELEMENT", AR_ELEMENT
),
1942 minit ("SECTION", AR_SECTION
),
1948 mio_array_ref (gfc_array_ref
*ar
)
1953 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
1954 mio_integer (&ar
->dimen
);
1962 for (i
= 0; i
< ar
->dimen
; i
++)
1963 mio_expr (&ar
->start
[i
]);
1968 for (i
= 0; i
< ar
->dimen
; i
++)
1970 mio_expr (&ar
->start
[i
]);
1971 mio_expr (&ar
->end
[i
]);
1972 mio_expr (&ar
->stride
[i
]);
1978 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1981 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1982 we can't call mio_integer directly. Instead loop over each element
1983 and cast it to/from an integer. */
1984 if (iomode
== IO_OUTPUT
)
1986 for (i
= 0; i
< ar
->dimen
; i
++)
1988 int tmp
= (int)ar
->dimen_type
[i
];
1989 write_atom (ATOM_INTEGER
, &tmp
);
1994 for (i
= 0; i
< ar
->dimen
; i
++)
1996 require_atom (ATOM_INTEGER
);
1997 ar
->dimen_type
[i
] = atom_int
;
2001 if (iomode
== IO_INPUT
)
2003 ar
->where
= gfc_current_locus
;
2005 for (i
= 0; i
< ar
->dimen
; i
++)
2006 ar
->c_where
[i
] = gfc_current_locus
;
2013 /* Saves or restores a pointer. The pointer is converted back and
2014 forth from an integer. We return the pointer_info pointer so that
2015 the caller can take additional action based on the pointer type. */
2017 static pointer_info
*
2018 mio_pointer_ref (void *gp
)
2022 if (iomode
== IO_OUTPUT
)
2024 p
= get_pointer (*((char **) gp
));
2025 write_atom (ATOM_INTEGER
, &p
->integer
);
2029 require_atom (ATOM_INTEGER
);
2030 p
= add_fixup (atom_int
, gp
);
2037 /* Save and load references to components that occur within
2038 expressions. We have to describe these references by a number and
2039 by name. The number is necessary for forward references during
2040 reading, and the name is necessary if the symbol already exists in
2041 the namespace and is not loaded again. */
2044 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2046 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2050 p
= mio_pointer_ref (cp
);
2051 if (p
->type
== P_UNKNOWN
)
2052 p
->type
= P_COMPONENT
;
2054 if (iomode
== IO_OUTPUT
)
2055 mio_pool_string (&(*cp
)->name
);
2058 mio_internal_string (name
);
2060 /* It can happen that a component reference can be read before the
2061 associated derived type symbol has been loaded. Return now and
2062 wait for a later iteration of load_needed. */
2066 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2068 /* Symbol already loaded, so search by name. */
2069 for (q
= sym
->components
; q
; q
= q
->next
)
2070 if (strcmp (q
->name
, name
) == 0)
2074 gfc_internal_error ("mio_component_ref(): Component not found");
2076 associate_integer_pointer (p
, q
);
2079 /* Make sure this symbol will eventually be loaded. */
2080 p
= find_pointer2 (sym
);
2081 if (p
->u
.rsym
.state
== UNUSED
)
2082 p
->u
.rsym
.state
= NEEDED
;
2088 mio_component (gfc_component
*c
)
2095 if (iomode
== IO_OUTPUT
)
2097 p
= get_pointer (c
);
2098 mio_integer (&p
->integer
);
2103 p
= get_integer (n
);
2104 associate_integer_pointer (p
, c
);
2107 if (p
->type
== P_UNKNOWN
)
2108 p
->type
= P_COMPONENT
;
2110 mio_pool_string (&c
->name
);
2111 mio_typespec (&c
->ts
);
2112 mio_array_spec (&c
->as
);
2114 mio_integer (&c
->dimension
);
2115 mio_integer (&c
->pointer
);
2116 mio_integer (&c
->allocatable
);
2117 c
->access
= MIO_NAME (gfc_access
) (c
->access
, access_types
);
2119 mio_expr (&c
->initializer
);
2125 mio_component_list (gfc_component
**cp
)
2127 gfc_component
*c
, *tail
;
2131 if (iomode
== IO_OUTPUT
)
2133 for (c
= *cp
; c
; c
= c
->next
)
2143 if (peek_atom () == ATOM_RPAREN
)
2146 c
= gfc_get_component ();
2163 mio_actual_arg (gfc_actual_arglist
*a
)
2166 mio_pool_string (&a
->name
);
2167 mio_expr (&a
->expr
);
2173 mio_actual_arglist (gfc_actual_arglist
**ap
)
2175 gfc_actual_arglist
*a
, *tail
;
2179 if (iomode
== IO_OUTPUT
)
2181 for (a
= *ap
; a
; a
= a
->next
)
2191 if (peek_atom () != ATOM_LPAREN
)
2194 a
= gfc_get_actual_arglist ();
2210 /* Read and write formal argument lists. */
2213 mio_formal_arglist (gfc_symbol
*sym
)
2215 gfc_formal_arglist
*f
, *tail
;
2219 if (iomode
== IO_OUTPUT
)
2221 for (f
= sym
->formal
; f
; f
= f
->next
)
2222 mio_symbol_ref (&f
->sym
);
2226 sym
->formal
= tail
= NULL
;
2228 while (peek_atom () != ATOM_RPAREN
)
2230 f
= gfc_get_formal_arglist ();
2231 mio_symbol_ref (&f
->sym
);
2233 if (sym
->formal
== NULL
)
2246 /* Save or restore a reference to a symbol node. */
2249 mio_symbol_ref (gfc_symbol
**symp
)
2253 p
= mio_pointer_ref (symp
);
2254 if (p
->type
== P_UNKNOWN
)
2257 if (iomode
== IO_OUTPUT
)
2259 if (p
->u
.wsym
.state
== UNREFERENCED
)
2260 p
->u
.wsym
.state
= NEEDS_WRITE
;
2264 if (p
->u
.rsym
.state
== UNUSED
)
2265 p
->u
.rsym
.state
= NEEDED
;
2270 /* Save or restore a reference to a symtree node. */
2273 mio_symtree_ref (gfc_symtree
**stp
)
2278 if (iomode
== IO_OUTPUT
)
2279 mio_symbol_ref (&(*stp
)->n
.sym
);
2282 require_atom (ATOM_INTEGER
);
2283 p
= get_integer (atom_int
);
2285 /* An unused equivalence member; make a symbol and a symtree
2287 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2289 /* Since this is not used, it must have a unique name. */
2290 p
->u
.rsym
.symtree
= get_unique_symtree (gfc_current_ns
);
2292 /* Make the symbol. */
2293 if (p
->u
.rsym
.sym
== NULL
)
2295 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2297 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2300 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2301 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2302 p
->u
.rsym
.referenced
= 1;
2305 if (p
->type
== P_UNKNOWN
)
2308 if (p
->u
.rsym
.state
== UNUSED
)
2309 p
->u
.rsym
.state
= NEEDED
;
2311 if (p
->u
.rsym
.symtree
!= NULL
)
2313 *stp
= p
->u
.rsym
.symtree
;
2317 f
= gfc_getmem (sizeof (fixup_t
));
2319 f
->next
= p
->u
.rsym
.stfixup
;
2320 p
->u
.rsym
.stfixup
= f
;
2322 f
->pointer
= (void **) stp
;
2329 mio_iterator (gfc_iterator
**ip
)
2335 if (iomode
== IO_OUTPUT
)
2342 if (peek_atom () == ATOM_RPAREN
)
2348 *ip
= gfc_get_iterator ();
2353 mio_expr (&iter
->var
);
2354 mio_expr (&iter
->start
);
2355 mio_expr (&iter
->end
);
2356 mio_expr (&iter
->step
);
2364 mio_constructor (gfc_constructor
**cp
)
2366 gfc_constructor
*c
, *tail
;
2370 if (iomode
== IO_OUTPUT
)
2372 for (c
= *cp
; c
; c
= c
->next
)
2375 mio_expr (&c
->expr
);
2376 mio_iterator (&c
->iterator
);
2385 while (peek_atom () != ATOM_RPAREN
)
2387 c
= gfc_get_constructor ();
2397 mio_expr (&c
->expr
);
2398 mio_iterator (&c
->iterator
);
2407 static const mstring ref_types
[] = {
2408 minit ("ARRAY", REF_ARRAY
),
2409 minit ("COMPONENT", REF_COMPONENT
),
2410 minit ("SUBSTRING", REF_SUBSTRING
),
2416 mio_ref (gfc_ref
**rp
)
2423 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2428 mio_array_ref (&r
->u
.ar
);
2432 mio_symbol_ref (&r
->u
.c
.sym
);
2433 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2437 mio_expr (&r
->u
.ss
.start
);
2438 mio_expr (&r
->u
.ss
.end
);
2439 mio_charlen (&r
->u
.ss
.length
);
2448 mio_ref_list (gfc_ref
**rp
)
2450 gfc_ref
*ref
, *head
, *tail
;
2454 if (iomode
== IO_OUTPUT
)
2456 for (ref
= *rp
; ref
; ref
= ref
->next
)
2463 while (peek_atom () != ATOM_RPAREN
)
2466 head
= tail
= gfc_get_ref ();
2469 tail
->next
= gfc_get_ref ();
2483 /* Read and write an integer value. */
2486 mio_gmp_integer (mpz_t
*integer
)
2490 if (iomode
== IO_INPUT
)
2492 if (parse_atom () != ATOM_STRING
)
2493 bad_module ("Expected integer string");
2495 mpz_init (*integer
);
2496 if (mpz_set_str (*integer
, atom_string
, 10))
2497 bad_module ("Error converting integer");
2499 gfc_free (atom_string
);
2503 p
= mpz_get_str (NULL
, 10, *integer
);
2504 write_atom (ATOM_STRING
, p
);
2511 mio_gmp_real (mpfr_t
*real
)
2516 if (iomode
== IO_INPUT
)
2518 if (parse_atom () != ATOM_STRING
)
2519 bad_module ("Expected real string");
2522 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2523 gfc_free (atom_string
);
2527 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2528 atom_string
= gfc_getmem (strlen (p
) + 20);
2530 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2532 /* Fix negative numbers. */
2533 if (atom_string
[2] == '-')
2535 atom_string
[0] = '-';
2536 atom_string
[1] = '0';
2537 atom_string
[2] = '.';
2540 write_atom (ATOM_STRING
, atom_string
);
2542 gfc_free (atom_string
);
2548 /* Save and restore the shape of an array constructor. */
2551 mio_shape (mpz_t
**pshape
, int rank
)
2557 /* A NULL shape is represented by (). */
2560 if (iomode
== IO_OUTPUT
)
2572 if (t
== ATOM_RPAREN
)
2579 shape
= gfc_get_shape (rank
);
2583 for (n
= 0; n
< rank
; n
++)
2584 mio_gmp_integer (&shape
[n
]);
2590 static const mstring expr_types
[] = {
2591 minit ("OP", EXPR_OP
),
2592 minit ("FUNCTION", EXPR_FUNCTION
),
2593 minit ("CONSTANT", EXPR_CONSTANT
),
2594 minit ("VARIABLE", EXPR_VARIABLE
),
2595 minit ("SUBSTRING", EXPR_SUBSTRING
),
2596 minit ("STRUCTURE", EXPR_STRUCTURE
),
2597 minit ("ARRAY", EXPR_ARRAY
),
2598 minit ("NULL", EXPR_NULL
),
2602 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2603 generic operators, not in expressions. INTRINSIC_USER is also
2604 replaced by the correct function name by the time we see it. */
2606 static const mstring intrinsics
[] =
2608 minit ("UPLUS", INTRINSIC_UPLUS
),
2609 minit ("UMINUS", INTRINSIC_UMINUS
),
2610 minit ("PLUS", INTRINSIC_PLUS
),
2611 minit ("MINUS", INTRINSIC_MINUS
),
2612 minit ("TIMES", INTRINSIC_TIMES
),
2613 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2614 minit ("POWER", INTRINSIC_POWER
),
2615 minit ("CONCAT", INTRINSIC_CONCAT
),
2616 minit ("AND", INTRINSIC_AND
),
2617 minit ("OR", INTRINSIC_OR
),
2618 minit ("EQV", INTRINSIC_EQV
),
2619 minit ("NEQV", INTRINSIC_NEQV
),
2620 minit ("==", INTRINSIC_EQ
),
2621 minit ("EQ", INTRINSIC_EQ_OS
),
2622 minit ("/=", INTRINSIC_NE
),
2623 minit ("NE", INTRINSIC_NE_OS
),
2624 minit (">", INTRINSIC_GT
),
2625 minit ("GT", INTRINSIC_GT_OS
),
2626 minit (">=", INTRINSIC_GE
),
2627 minit ("GE", INTRINSIC_GE_OS
),
2628 minit ("<", INTRINSIC_LT
),
2629 minit ("LT", INTRINSIC_LT_OS
),
2630 minit ("<=", INTRINSIC_LE
),
2631 minit ("LE", INTRINSIC_LE_OS
),
2632 minit ("NOT", INTRINSIC_NOT
),
2633 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
2638 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2641 fix_mio_expr (gfc_expr
*e
)
2643 gfc_symtree
*ns_st
= NULL
;
2646 if (iomode
!= IO_OUTPUT
)
2651 /* If this is a symtree for a symbol that came from a contained module
2652 namespace, it has a unique name and we should look in the current
2653 namespace to see if the required, non-contained symbol is available
2654 yet. If so, the latter should be written. */
2655 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
2656 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
,
2657 e
->symtree
->n
.sym
->name
);
2659 /* On the other hand, if the existing symbol is the module name or the
2660 new symbol is a dummy argument, do not do the promotion. */
2661 if (ns_st
&& ns_st
->n
.sym
2662 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
2663 && !e
->symtree
->n
.sym
->attr
.dummy
)
2666 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
2668 /* In some circumstances, a function used in an initialization
2669 expression, in one use associated module, can fail to be
2670 coupled to its symtree when used in a specification
2671 expression in another module. */
2672 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
2673 : e
->value
.function
.isym
->name
;
2674 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
2679 /* Read and write expressions. The form "()" is allowed to indicate a
2683 mio_expr (gfc_expr
**ep
)
2691 if (iomode
== IO_OUTPUT
)
2700 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
2705 if (t
== ATOM_RPAREN
)
2712 bad_module ("Expected expression type");
2714 e
= *ep
= gfc_get_expr ();
2715 e
->where
= gfc_current_locus
;
2716 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2719 mio_typespec (&e
->ts
);
2720 mio_integer (&e
->rank
);
2724 switch (e
->expr_type
)
2727 e
->value
.op
.operator
2728 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.operator, intrinsics
);
2730 switch (e
->value
.op
.operator)
2732 case INTRINSIC_UPLUS
:
2733 case INTRINSIC_UMINUS
:
2735 case INTRINSIC_PARENTHESES
:
2736 mio_expr (&e
->value
.op
.op1
);
2739 case INTRINSIC_PLUS
:
2740 case INTRINSIC_MINUS
:
2741 case INTRINSIC_TIMES
:
2742 case INTRINSIC_DIVIDE
:
2743 case INTRINSIC_POWER
:
2744 case INTRINSIC_CONCAT
:
2748 case INTRINSIC_NEQV
:
2750 case INTRINSIC_EQ_OS
:
2752 case INTRINSIC_NE_OS
:
2754 case INTRINSIC_GT_OS
:
2756 case INTRINSIC_GE_OS
:
2758 case INTRINSIC_LT_OS
:
2760 case INTRINSIC_LE_OS
:
2761 mio_expr (&e
->value
.op
.op1
);
2762 mio_expr (&e
->value
.op
.op2
);
2766 bad_module ("Bad operator");
2772 mio_symtree_ref (&e
->symtree
);
2773 mio_actual_arglist (&e
->value
.function
.actual
);
2775 if (iomode
== IO_OUTPUT
)
2777 e
->value
.function
.name
2778 = mio_allocated_string (e
->value
.function
.name
);
2779 flag
= e
->value
.function
.esym
!= NULL
;
2780 mio_integer (&flag
);
2782 mio_symbol_ref (&e
->value
.function
.esym
);
2784 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2788 require_atom (ATOM_STRING
);
2789 e
->value
.function
.name
= gfc_get_string (atom_string
);
2790 gfc_free (atom_string
);
2792 mio_integer (&flag
);
2794 mio_symbol_ref (&e
->value
.function
.esym
);
2797 require_atom (ATOM_STRING
);
2798 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2799 gfc_free (atom_string
);
2806 mio_symtree_ref (&e
->symtree
);
2807 mio_ref_list (&e
->ref
);
2810 case EXPR_SUBSTRING
:
2811 e
->value
.character
.string
2812 = (char *) mio_allocated_string (e
->value
.character
.string
);
2813 mio_ref_list (&e
->ref
);
2816 case EXPR_STRUCTURE
:
2818 mio_constructor (&e
->value
.constructor
);
2819 mio_shape (&e
->shape
, e
->rank
);
2826 mio_gmp_integer (&e
->value
.integer
);
2830 gfc_set_model_kind (e
->ts
.kind
);
2831 mio_gmp_real (&e
->value
.real
);
2835 gfc_set_model_kind (e
->ts
.kind
);
2836 mio_gmp_real (&e
->value
.complex.r
);
2837 mio_gmp_real (&e
->value
.complex.i
);
2841 mio_integer (&e
->value
.logical
);
2845 mio_integer (&e
->value
.character
.length
);
2846 e
->value
.character
.string
2847 = (char *) mio_allocated_string (e
->value
.character
.string
);
2851 bad_module ("Bad type in constant expression");
2864 /* Read and write namelists. */
2867 mio_namelist (gfc_symbol
*sym
)
2869 gfc_namelist
*n
, *m
;
2870 const char *check_name
;
2874 if (iomode
== IO_OUTPUT
)
2876 for (n
= sym
->namelist
; n
; n
= n
->next
)
2877 mio_symbol_ref (&n
->sym
);
2881 /* This departure from the standard is flagged as an error.
2882 It does, in fact, work correctly. TODO: Allow it
2884 if (sym
->attr
.flavor
== FL_NAMELIST
)
2886 check_name
= find_use_name (sym
->name
);
2887 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
2888 gfc_error ("Namelist %s cannot be renamed by USE "
2889 "association to %s", sym
->name
, check_name
);
2893 while (peek_atom () != ATOM_RPAREN
)
2895 n
= gfc_get_namelist ();
2896 mio_symbol_ref (&n
->sym
);
2898 if (sym
->namelist
== NULL
)
2905 sym
->namelist_tail
= m
;
2912 /* Save/restore lists of gfc_interface stuctures. When loading an
2913 interface, we are really appending to the existing list of
2914 interfaces. Checking for duplicate and ambiguous interfaces has to
2915 be done later when all symbols have been loaded. */
2918 mio_interface_rest (gfc_interface
**ip
)
2920 gfc_interface
*tail
, *p
;
2922 if (iomode
== IO_OUTPUT
)
2925 for (p
= *ip
; p
; p
= p
->next
)
2926 mio_symbol_ref (&p
->sym
);
2941 if (peek_atom () == ATOM_RPAREN
)
2944 p
= gfc_get_interface ();
2945 p
->where
= gfc_current_locus
;
2946 mio_symbol_ref (&p
->sym
);
2961 /* Save/restore a nameless operator interface. */
2964 mio_interface (gfc_interface
**ip
)
2967 mio_interface_rest (ip
);
2971 /* Save/restore a named operator interface. */
2974 mio_symbol_interface (const char **name
, const char **module
,
2978 mio_pool_string (name
);
2979 mio_pool_string (module
);
2980 mio_interface_rest (ip
);
2985 mio_namespace_ref (gfc_namespace
**nsp
)
2990 p
= mio_pointer_ref (nsp
);
2992 if (p
->type
== P_UNKNOWN
)
2993 p
->type
= P_NAMESPACE
;
2995 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
2997 ns
= (gfc_namespace
*) p
->u
.pointer
;
3000 ns
= gfc_get_namespace (NULL
, 0);
3001 associate_integer_pointer (p
, ns
);
3009 /* Unlike most other routines, the address of the symbol node is already
3010 fixed on input and the name/module has already been filled in. */
3013 mio_symbol (gfc_symbol
*sym
)
3015 int intmod
= INTMOD_NONE
;
3017 gfc_formal_arglist
*formal
;
3021 mio_symbol_attribute (&sym
->attr
);
3022 mio_typespec (&sym
->ts
);
3024 /* Contained procedures don't have formal namespaces. Instead we output the
3025 procedure namespace. The will contain the formal arguments. */
3026 if (iomode
== IO_OUTPUT
)
3028 formal
= sym
->formal
;
3029 while (formal
&& !formal
->sym
)
3030 formal
= formal
->next
;
3033 mio_namespace_ref (&formal
->sym
->ns
);
3035 mio_namespace_ref (&sym
->formal_ns
);
3039 mio_namespace_ref (&sym
->formal_ns
);
3042 sym
->formal_ns
->proc_name
= sym
;
3047 /* Save/restore common block links. */
3048 mio_symbol_ref (&sym
->common_next
);
3050 mio_formal_arglist (sym
);
3052 if (sym
->attr
.flavor
== FL_PARAMETER
)
3053 mio_expr (&sym
->value
);
3055 mio_array_spec (&sym
->as
);
3057 mio_symbol_ref (&sym
->result
);
3059 if (sym
->attr
.cray_pointee
)
3060 mio_symbol_ref (&sym
->cp_pointer
);
3062 /* Note that components are always saved, even if they are supposed
3063 to be private. Component access is checked during searching. */
3065 mio_component_list (&sym
->components
);
3067 if (sym
->components
!= NULL
)
3068 sym
->component_access
3069 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3073 /* Add the fields that say whether this is from an intrinsic module,
3074 and if so, what symbol it is within the module. */
3075 /* mio_integer (&(sym->from_intmod)); */
3076 if (iomode
== IO_OUTPUT
)
3078 intmod
= sym
->from_intmod
;
3079 mio_integer (&intmod
);
3083 mio_integer (&intmod
);
3084 sym
->from_intmod
= intmod
;
3087 mio_integer (&(sym
->intmod_sym_id
));
3093 /************************* Top level subroutines *************************/
3095 /* Skip a list between balanced left and right parens. */
3105 switch (parse_atom ())
3116 gfc_free (atom_string
);
3128 /* Load operator interfaces from the module. Interfaces are unusual
3129 in that they attach themselves to existing symbols. */
3132 load_operator_interfaces (void)
3135 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3140 while (peek_atom () != ATOM_RPAREN
)
3144 mio_internal_string (name
);
3145 mio_internal_string (module
);
3147 /* Decide if we need to load this one or not. */
3148 p
= find_use_name (name
);
3151 while (parse_atom () != ATOM_RPAREN
);
3155 uop
= gfc_get_uop (p
);
3156 mio_interface_rest (&uop
->operator);
3164 /* Load interfaces from the module. Interfaces are unusual in that
3165 they attach themselves to existing symbols. */
3168 load_generic_interfaces (void)
3171 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3173 gfc_interface
*generic
= NULL
;
3178 while (peek_atom () != ATOM_RPAREN
)
3182 mio_internal_string (name
);
3183 mio_internal_string (module
);
3185 n
= number_use_names (name
);
3188 for (i
= 1; i
<= n
; i
++)
3190 /* Decide if we need to load this one or not. */
3191 p
= find_use_name_n (name
, &i
);
3193 if (p
== NULL
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
3195 while (parse_atom () != ATOM_RPAREN
);
3201 gfc_get_symbol (p
, NULL
, &sym
);
3203 sym
->attr
.flavor
= FL_PROCEDURE
;
3204 sym
->attr
.generic
= 1;
3205 sym
->attr
.use_assoc
= 1;
3209 /* Unless sym is a generic interface, this reference
3213 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3214 if (!sym
->attr
.generic
3215 && sym
->module
!= NULL
3216 && strcmp(module
, sym
->module
) != 0)
3221 mio_interface_rest (&sym
->generic
);
3222 generic
= sym
->generic
;
3226 sym
->generic
= generic
;
3227 sym
->attr
.generic_copy
= 1;
3236 /* Load common blocks. */
3241 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3246 while (peek_atom () != ATOM_RPAREN
)
3250 mio_internal_string (name
);
3252 p
= gfc_get_common (name
, 1);
3254 mio_symbol_ref (&p
->head
);
3255 mio_integer (&flags
);
3259 p
->threadprivate
= 1;
3262 /* Get whether this was a bind(c) common or not. */
3263 mio_integer (&p
->is_bind_c
);
3264 /* Get the binding label. */
3265 mio_internal_string (p
->binding_label
);
3274 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3275 so that unused variables are not loaded and so that the expression can
3281 gfc_equiv
*head
, *tail
, *end
, *eq
;
3285 in_load_equiv
= true;
3287 end
= gfc_current_ns
->equiv
;
3288 while (end
!= NULL
&& end
->next
!= NULL
)
3291 while (peek_atom () != ATOM_RPAREN
) {
3295 while(peek_atom () != ATOM_RPAREN
)
3298 head
= tail
= gfc_get_equiv ();
3301 tail
->eq
= gfc_get_equiv ();
3305 mio_pool_string (&tail
->module
);
3306 mio_expr (&tail
->expr
);
3309 /* Unused equivalence members have a unique name. */
3311 for (eq
= head
; eq
; eq
= eq
->eq
)
3313 if (!check_unique_name (eq
->expr
->symtree
->name
))
3322 for (eq
= head
; eq
; eq
= head
)
3325 gfc_free_expr (eq
->expr
);
3331 gfc_current_ns
->equiv
= head
;
3342 in_load_equiv
= false;
3346 /* Recursive function to traverse the pointer_info tree and load a
3347 needed symbol. We return nonzero if we load a symbol and stop the
3348 traversal, because the act of loading can alter the tree. */
3351 load_needed (pointer_info
*p
)
3362 rv
|= load_needed (p
->left
);
3363 rv
|= load_needed (p
->right
);
3365 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
3368 p
->u
.rsym
.state
= USED
;
3370 set_module_locus (&p
->u
.rsym
.where
);
3372 sym
= p
->u
.rsym
.sym
;
3375 q
= get_integer (p
->u
.rsym
.ns
);
3377 ns
= (gfc_namespace
*) q
->u
.pointer
;
3380 /* Create an interface namespace if necessary. These are
3381 the namespaces that hold the formal parameters of module
3384 ns
= gfc_get_namespace (NULL
, 0);
3385 associate_integer_pointer (q
, ns
);
3388 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
3389 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
3391 associate_integer_pointer (p
, sym
);
3395 sym
->attr
.use_assoc
= 1;
3397 sym
->attr
.use_only
= 1;
3403 /* Recursive function for cleaning up things after a module has been read. */
3406 read_cleanup (pointer_info
*p
)
3414 read_cleanup (p
->left
);
3415 read_cleanup (p
->right
);
3417 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
3419 /* Add hidden symbols to the symtree. */
3420 q
= get_integer (p
->u
.rsym
.ns
);
3421 st
= get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
3423 st
->n
.sym
= p
->u
.rsym
.sym
;
3426 /* Fixup any symtree references. */
3427 p
->u
.rsym
.symtree
= st
;
3428 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
3429 p
->u
.rsym
.stfixup
= NULL
;
3432 /* Free unused symbols. */
3433 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
3434 gfc_free_symbol (p
->u
.rsym
.sym
);
3438 /* Given a root symtree node and a symbol, try to find a symtree that
3439 references the symbol that is not a unique name. */
3441 static gfc_symtree
*
3442 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3444 gfc_symtree
*s
= NULL
;
3449 s
= find_symtree_for_symbol (st
->right
, sym
);
3452 s
= find_symtree_for_symbol (st
->left
, sym
);
3456 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3463 /* Read a module file. */
3468 module_locus operator_interfaces
, user_operators
;
3470 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3472 int ambiguous
, j
, nuse
, symbol
;
3473 pointer_info
*info
, *q
;
3478 get_module_locus (&operator_interfaces
); /* Skip these for now. */
3481 get_module_locus (&user_operators
);
3485 /* Skip commons and equivalences for now. */
3491 /* Create the fixup nodes for all the symbols. */
3493 while (peek_atom () != ATOM_RPAREN
)
3495 require_atom (ATOM_INTEGER
);
3496 info
= get_integer (atom_int
);
3498 info
->type
= P_SYMBOL
;
3499 info
->u
.rsym
.state
= UNUSED
;
3501 mio_internal_string (info
->u
.rsym
.true_name
);
3502 mio_internal_string (info
->u
.rsym
.module
);
3503 mio_internal_string (info
->u
.rsym
.binding_label
);
3506 require_atom (ATOM_INTEGER
);
3507 info
->u
.rsym
.ns
= atom_int
;
3509 get_module_locus (&info
->u
.rsym
.where
);
3512 /* See if the symbol has already been loaded by a previous module.
3513 If so, we reference the existing symbol and prevent it from
3514 being loaded again. This should not happen if the symbol being
3515 read is an index for an assumed shape dummy array (ns != 1). */
3517 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
3520 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
3523 info
->u
.rsym
.state
= USED
;
3524 info
->u
.rsym
.sym
= sym
;
3526 /* Some symbols do not have a namespace (eg. formal arguments),
3527 so the automatic "unique symtree" mechanism must be suppressed
3528 by marking them as referenced. */
3529 q
= get_integer (info
->u
.rsym
.ns
);
3530 if (q
->u
.pointer
== NULL
)
3532 info
->u
.rsym
.referenced
= 1;
3536 /* If possible recycle the symtree that references the symbol.
3537 If a symtree is not found and the module does not import one,
3538 a unique-name symtree is found by read_cleanup. */
3539 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
3542 info
->u
.rsym
.symtree
= st
;
3543 info
->u
.rsym
.referenced
= 1;
3549 /* Parse the symtree lists. This lets us mark which symbols need to
3550 be loaded. Renaming is also done at this point by replacing the
3555 while (peek_atom () != ATOM_RPAREN
)
3557 mio_internal_string (name
);
3558 mio_integer (&ambiguous
);
3559 mio_integer (&symbol
);
3561 info
= get_integer (symbol
);
3563 /* See how many use names there are. If none, go through the start
3564 of the loop at least once. */
3565 nuse
= number_use_names (name
);
3569 for (j
= 1; j
<= nuse
; j
++)
3571 /* Get the jth local name for this symbol. */
3572 p
= find_use_name_n (name
, &j
);
3574 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
3577 /* Skip symtree nodes not in an ONLY clause, unless there
3578 is an existing symtree loaded from another USE statement. */
3581 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3583 info
->u
.rsym
.symtree
= st
;
3587 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3591 /* Check for ambiguous symbols. */
3592 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
3594 info
->u
.rsym
.symtree
= st
;
3598 /* Create a symtree node in the current namespace for this
3600 st
= check_unique_name (p
)
3601 ? get_unique_symtree (gfc_current_ns
)
3602 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3604 st
->ambiguous
= ambiguous
;
3606 sym
= info
->u
.rsym
.sym
;
3608 /* Create a symbol node if it doesn't already exist. */
3611 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
3613 sym
= info
->u
.rsym
.sym
;
3614 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
3616 /* TODO: hmm, can we test this? Do we know it will be
3617 initialized to zeros? */
3618 if (info
->u
.rsym
.binding_label
[0] != '\0')
3619 strcpy (sym
->binding_label
, info
->u
.rsym
.binding_label
);
3625 /* Store the symtree pointing to this symbol. */
3626 info
->u
.rsym
.symtree
= st
;
3628 if (info
->u
.rsym
.state
== UNUSED
)
3629 info
->u
.rsym
.state
= NEEDED
;
3630 info
->u
.rsym
.referenced
= 1;
3637 /* Load intrinsic operator interfaces. */
3638 set_module_locus (&operator_interfaces
);
3641 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3643 if (i
== INTRINSIC_USER
)
3648 u
= find_use_operator (i
);
3659 mio_interface (&gfc_current_ns
->operator[i
]);
3664 /* Load generic and user operator interfaces. These must follow the
3665 loading of symtree because otherwise symbols can be marked as
3668 set_module_locus (&user_operators
);
3670 load_operator_interfaces ();
3671 load_generic_interfaces ();
3676 /* At this point, we read those symbols that are needed but haven't
3677 been loaded yet. If one symbol requires another, the other gets
3678 marked as NEEDED if its previous state was UNUSED. */
3680 while (load_needed (pi_root
));
3682 /* Make sure all elements of the rename-list were found in the module. */
3684 for (u
= gfc_rename_list
; u
; u
= u
->next
)
3689 if (u
->operator == INTRINSIC_NONE
)
3691 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3692 u
->use_name
, &u
->where
, module_name
);
3696 if (u
->operator == INTRINSIC_USER
)
3698 gfc_error ("User operator '%s' referenced at %L not found "
3699 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
3703 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3704 "in module '%s'", gfc_op2string (u
->operator), &u
->where
,
3708 gfc_check_interfaces (gfc_current_ns
);
3710 /* Clean up symbol nodes that were never loaded, create references
3711 to hidden symbols. */
3713 read_cleanup (pi_root
);
3717 /* Given an access type that is specific to an entity and the default
3718 access, return nonzero if the entity is publicly accessible. If the
3719 element is declared as PUBLIC, then it is public; if declared
3720 PRIVATE, then private, and otherwise it is public unless the default
3721 access in this context has been declared PRIVATE. */
3724 gfc_check_access (gfc_access specific_access
, gfc_access default_access
)
3726 if (specific_access
== ACCESS_PUBLIC
)
3728 if (specific_access
== ACCESS_PRIVATE
)
3731 return default_access
!= ACCESS_PRIVATE
;
3735 /* Write a common block to the module. */
3738 write_common (gfc_symtree
*st
)
3748 write_common (st
->left
);
3749 write_common (st
->right
);
3753 /* Write the unmangled name. */
3754 name
= st
->n
.common
->name
;
3756 mio_pool_string (&name
);
3759 mio_symbol_ref (&p
->head
);
3760 flags
= p
->saved
? 1 : 0;
3761 if (p
->threadprivate
) flags
|= 2;
3762 mio_integer (&flags
);
3764 /* Write out whether the common block is bind(c) or not. */
3765 mio_integer (&(p
->is_bind_c
));
3767 /* Write out the binding label, or the com name if no label given. */
3770 label
= p
->binding_label
;
3771 mio_pool_string (&label
);
3776 mio_pool_string (&label
);
3783 /* Write the blank common block to the module. */
3786 write_blank_common (void)
3788 const char * name
= BLANK_COMMON_NAME
;
3790 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3791 this, but it hasn't been checked. Just making it so for now. */
3794 if (gfc_current_ns
->blank_common
.head
== NULL
)
3799 mio_pool_string (&name
);
3801 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
3802 saved
= gfc_current_ns
->blank_common
.saved
;
3803 mio_integer (&saved
);
3805 /* Write out whether the common block is bind(c) or not. */
3806 mio_integer (&is_bind_c
);
3808 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3809 it doesn't matter because the label isn't used. */
3810 mio_pool_string (&name
);
3816 /* Write equivalences to the module. */
3825 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
3829 for (e
= eq
; e
; e
= e
->eq
)
3831 if (e
->module
== NULL
)
3832 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
3833 mio_allocated_string (e
->module
);
3834 mio_expr (&e
->expr
);
3843 /* Write a symbol to the module. */
3846 write_symbol (int n
, gfc_symbol
*sym
)
3850 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
3851 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
3854 mio_pool_string (&sym
->name
);
3856 mio_pool_string (&sym
->module
);
3857 if (sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
)
3859 label
= sym
->binding_label
;
3860 mio_pool_string (&label
);
3863 mio_pool_string (&sym
->name
);
3865 mio_pointer_ref (&sym
->ns
);
3872 /* Recursive traversal function to write the initial set of symbols to
3873 the module. We check to see if the symbol should be written
3874 according to the access specification. */
3877 write_symbol0 (gfc_symtree
*st
)
3885 write_symbol0 (st
->left
);
3886 write_symbol0 (st
->right
);
3889 if (sym
->module
== NULL
)
3890 sym
->module
= gfc_get_string (module_name
);
3892 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3893 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
3896 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3899 p
= get_pointer (sym
);
3900 if (p
->type
== P_UNKNOWN
)
3903 if (p
->u
.wsym
.state
== WRITTEN
)
3906 write_symbol (p
->integer
, sym
);
3907 p
->u
.wsym
.state
= WRITTEN
;
3911 /* Recursive traversal function to write the secondary set of symbols
3912 to the module file. These are symbols that were not public yet are
3913 needed by the public symbols or another dependent symbol. The act
3914 of writing a symbol can modify the pointer_info tree, so we cease
3915 traversal if we find a symbol to write. We return nonzero if a
3916 symbol was written and pass that information upwards. */
3919 write_symbol1 (pointer_info
*p
)
3925 if (write_symbol1 (p
->left
))
3927 if (write_symbol1 (p
->right
))
3930 if (p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
)
3933 p
->u
.wsym
.state
= WRITTEN
;
3934 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
3940 /* Write operator interfaces associated with a symbol. */
3943 write_operator (gfc_user_op
*uop
)
3945 static char nullstring
[] = "";
3946 const char *p
= nullstring
;
3948 if (uop
->operator == NULL
3949 || !gfc_check_access (uop
->access
, uop
->ns
->default_access
))
3952 mio_symbol_interface (&uop
->name
, &p
, &uop
->operator);
3956 /* Write generic interfaces associated with a symbol. */
3959 write_generic (gfc_symbol
*sym
)
3964 if (sym
->generic
== NULL
3965 || !gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3968 if (sym
->module
== NULL
)
3969 sym
->module
= gfc_get_string (module_name
);
3971 /* See how many use names there are. If none, use the symbol name. */
3972 nuse
= number_use_names (sym
->name
);
3975 mio_symbol_interface (&sym
->name
, &sym
->module
, &sym
->generic
);
3979 for (j
= 1; j
<= nuse
; j
++)
3981 /* Get the jth local name for this symbol. */
3982 p
= find_use_name_n (sym
->name
, &j
);
3984 mio_symbol_interface (&p
, &sym
->module
, &sym
->generic
);
3990 write_symtree (gfc_symtree
*st
)
3996 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
3997 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3998 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
4001 if (check_unique_name (st
->name
))
4004 p
= find_pointer (sym
);
4006 gfc_internal_error ("write_symtree(): Symbol not written");
4008 mio_pool_string (&st
->name
);
4009 mio_integer (&st
->ambiguous
);
4010 mio_integer (&p
->integer
);
4019 /* Write the operator interfaces. */
4022 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4024 if (i
== INTRINSIC_USER
)
4027 mio_interface (gfc_check_access (gfc_current_ns
->operator_access
[i
],
4028 gfc_current_ns
->default_access
)
4029 ? &gfc_current_ns
->operator[i
] : NULL
);
4037 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
4043 gfc_traverse_ns (gfc_current_ns
, write_generic
);
4049 write_blank_common ();
4050 write_common (gfc_current_ns
->common_root
);
4061 /* Write symbol information. First we traverse all symbols in the
4062 primary namespace, writing those that need to be written.
4063 Sometimes writing one symbol will cause another to need to be
4064 written. A list of these symbols ends up on the write stack, and
4065 we end by popping the bottom of the stack and writing the symbol
4066 until the stack is empty. */
4070 write_symbol0 (gfc_current_ns
->sym_root
);
4071 while (write_symbol1 (pi_root
));
4079 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
4084 /* Read a MD5 sum from the header of a module file. If the file cannot
4085 be opened, or we have any other error, we return -1. */
4088 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
4094 /* Open the file. */
4095 if ((file
= fopen (filename
, "r")) == NULL
)
4098 /* Read two lines. */
4099 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
4100 || fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
4106 /* Close the file. */
4109 /* If the header is not what we expect, or is too short, bail out. */
4110 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
4113 /* Now, we have a real MD5, read it into the array. */
4114 for (n
= 0; n
< 16; n
++)
4118 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
4128 /* Given module, dump it to disk. If there was an error while
4129 processing the module, dump_flag will be set to zero and we delete
4130 the module file, even if it was already there. */
4133 gfc_dump_module (const char *name
, int dump_flag
)
4136 char *filename
, *filename_tmp
, *p
;
4139 unsigned char md5_new
[16], md5_old
[16];
4141 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
4142 if (gfc_option
.module_dir
!= NULL
)
4144 n
+= strlen (gfc_option
.module_dir
);
4145 filename
= (char *) alloca (n
);
4146 strcpy (filename
, gfc_option
.module_dir
);
4147 strcat (filename
, name
);
4151 filename
= (char *) alloca (n
);
4152 strcpy (filename
, name
);
4154 strcat (filename
, MODULE_EXTENSION
);
4156 /* Name of the temporary file used to write the module. */
4157 filename_tmp
= (char *) alloca (n
+ 1);
4158 strcpy (filename_tmp
, filename
);
4159 strcat (filename_tmp
, "0");
4161 /* There was an error while processing the module. We delete the
4162 module file, even if it was already there. */
4169 /* Write the module to the temporary file. */
4170 module_fp
= fopen (filename_tmp
, "w");
4171 if (module_fp
== NULL
)
4172 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4173 filename_tmp
, strerror (errno
));
4175 /* Write the header, including space reserved for the MD5 sum. */
4179 *strchr (p
, '\n') = '\0';
4181 fprintf (module_fp
, "GFORTRAN module created from %s on %s\nMD5:",
4182 gfc_source_file
, p
);
4183 fgetpos (module_fp
, &md5_pos
);
4184 fputs ("00000000000000000000000000000000 -- "
4185 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
4187 /* Initialize the MD5 context that will be used for output. */
4188 md5_init_ctx (&ctx
);
4190 /* Write the module itself. */
4192 strcpy (module_name
, name
);
4198 free_pi_tree (pi_root
);
4203 /* Write the MD5 sum to the header of the module file. */
4204 md5_finish_ctx (&ctx
, md5_new
);
4205 fsetpos (module_fp
, &md5_pos
);
4206 for (n
= 0; n
< 16; n
++)
4207 fprintf (module_fp
, "%02x", md5_new
[n
]);
4209 if (fclose (module_fp
))
4210 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4211 filename_tmp
, strerror (errno
));
4213 /* Read the MD5 from the header of the old module file and compare. */
4214 if (read_md5_from_module_file (filename
, md5_old
) != 0
4215 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
4217 /* Module file have changed, replace the old one. */
4219 rename (filename_tmp
, filename
);
4222 unlink (filename_tmp
);
4227 sort_iso_c_rename_list (void)
4229 gfc_use_rename
*tmp_list
= NULL
;
4230 gfc_use_rename
*curr
;
4231 gfc_use_rename
*kinds_used
[ISOCBINDING_NUMBER
] = {NULL
};
4235 for (curr
= gfc_rename_list
; curr
; curr
= curr
->next
)
4237 c_kind
= get_c_kind (curr
->use_name
, c_interop_kinds_table
);
4238 if (c_kind
== ISOCBINDING_INVALID
|| c_kind
== ISOCBINDING_LAST
)
4240 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4241 "intrinsic module ISO_C_BINDING.", curr
->use_name
,
4245 /* Put it in the list. */
4246 kinds_used
[c_kind
] = curr
;
4249 /* Make a new (sorted) rename list. */
4251 while (i
< ISOCBINDING_NUMBER
&& kinds_used
[i
] == NULL
)
4254 if (i
< ISOCBINDING_NUMBER
)
4256 tmp_list
= kinds_used
[i
];
4260 for (; i
< ISOCBINDING_NUMBER
; i
++)
4261 if (kinds_used
[i
] != NULL
)
4263 curr
->next
= kinds_used
[i
];
4269 gfc_rename_list
= tmp_list
;
4273 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4274 the current namespace for all named constants, pointer types, and
4275 procedures in the module unless the only clause was used or a rename
4276 list was provided. */
4279 import_iso_c_binding_module (void)
4281 gfc_symbol
*mod_sym
= NULL
;
4282 gfc_symtree
*mod_symtree
= NULL
;
4283 const char *iso_c_module_name
= "__iso_c_binding";
4288 /* Look only in the current namespace. */
4289 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
4291 if (mod_symtree
== NULL
)
4293 /* symtree doesn't already exist in current namespace. */
4294 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
);
4296 if (mod_symtree
!= NULL
)
4297 mod_sym
= mod_symtree
->n
.sym
;
4299 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4300 "create symbol for %s", iso_c_module_name
);
4302 mod_sym
->attr
.flavor
= FL_MODULE
;
4303 mod_sym
->attr
.intrinsic
= 1;
4304 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
4305 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4308 /* Generate the symbols for the named constants representing
4309 the kinds for intrinsic data types. */
4312 /* Sort the rename list because there are dependencies between types
4313 and procedures (e.g., c_loc needs c_ptr). */
4314 sort_iso_c_rename_list ();
4316 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4318 i
= get_c_kind (u
->use_name
, c_interop_kinds_table
);
4320 if (i
== ISOCBINDING_INVALID
|| i
== ISOCBINDING_LAST
)
4322 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4323 "intrinsic module ISO_C_BINDING.", u
->use_name
,
4328 generate_isocbinding_symbol (iso_c_module_name
, i
, u
->local_name
);
4333 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
4336 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4338 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
4340 local_name
= u
->local_name
;
4345 generate_isocbinding_symbol (iso_c_module_name
, i
, local_name
);
4348 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4353 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4354 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
4360 /* Add an integer named constant from a given module. */
4363 create_int_parameter (const char *name
, int value
, const char *modname
,
4364 intmod_id module
, int id
)
4366 gfc_symtree
*tmp_symtree
;
4369 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4370 if (tmp_symtree
!= NULL
)
4372 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
4375 gfc_error ("Symbol '%s' already declared", name
);
4378 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
4379 sym
= tmp_symtree
->n
.sym
;
4381 sym
->module
= gfc_get_string (modname
);
4382 sym
->attr
.flavor
= FL_PARAMETER
;
4383 sym
->ts
.type
= BT_INTEGER
;
4384 sym
->ts
.kind
= gfc_default_integer_kind
;
4385 sym
->value
= gfc_int_expr (value
);
4386 sym
->attr
.use_assoc
= 1;
4387 sym
->from_intmod
= module
;
4388 sym
->intmod_sym_id
= id
;
4392 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4395 use_iso_fortran_env_module (void)
4397 static char mod
[] = "iso_fortran_env";
4398 const char *local_name
;
4400 gfc_symbol
*mod_sym
;
4401 gfc_symtree
*mod_symtree
;
4404 intmod_sym symbol
[] = {
4405 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4406 #include "iso-fortran-env.def"
4408 { ISOFORTRANENV_INVALID
, NULL
, -1234 } };
4411 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4412 #include "iso-fortran-env.def"
4415 /* Generate the symbol for the module itself. */
4416 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
4417 if (mod_symtree
== NULL
)
4419 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
);
4420 gcc_assert (mod_symtree
);
4421 mod_sym
= mod_symtree
->n
.sym
;
4423 mod_sym
->attr
.flavor
= FL_MODULE
;
4424 mod_sym
->attr
.intrinsic
= 1;
4425 mod_sym
->module
= gfc_get_string (mod
);
4426 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
4429 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
4430 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4431 "non-intrinsic module name used previously", mod
);
4433 /* Generate the symbols for the module integer named constants. */
4435 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4437 for (i
= 0; symbol
[i
].name
; i
++)
4438 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
4441 if (symbol
[i
].name
== NULL
)
4443 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4444 "intrinsic module ISO_FORTRAN_ENV", u
->use_name
,
4449 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
4450 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
4451 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4452 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4453 "incompatible with option %s", &u
->where
,
4454 gfc_option
.flag_default_integer
4455 ? "-fdefault-integer-8" : "-fdefault-real-8");
4457 create_int_parameter (u
->local_name
[0] ? u
->local_name
4459 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
4464 for (i
= 0; symbol
[i
].name
; i
++)
4467 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4469 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
4471 local_name
= u
->local_name
;
4477 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
4478 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
4479 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4480 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4481 "incompatible with option %s",
4482 gfc_option
.flag_default_integer
4483 ? "-fdefault-integer-8" : "-fdefault-real-8");
4485 create_int_parameter (local_name
? local_name
: symbol
[i
].name
,
4486 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
4490 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4495 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4496 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
4502 /* Process a USE directive. */
4505 gfc_use_module (void)
4510 gfc_symtree
*mod_symtree
;
4512 filename
= (char *) alloca (strlen (module_name
) + strlen (MODULE_EXTENSION
)
4514 strcpy (filename
, module_name
);
4515 strcat (filename
, MODULE_EXTENSION
);
4517 /* First, try to find an non-intrinsic module, unless the USE statement
4518 specified that the module is intrinsic. */
4521 module_fp
= gfc_open_included_file (filename
, true, true);
4523 /* Then, see if it's an intrinsic one, unless the USE statement
4524 specified that the module is non-intrinsic. */
4525 if (module_fp
== NULL
&& !specified_nonint
)
4527 if (strcmp (module_name
, "iso_fortran_env") == 0
4528 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ISO_FORTRAN_ENV "
4529 "intrinsic module at %C") != FAILURE
)
4531 use_iso_fortran_env_module ();
4535 if (strcmp (module_name
, "iso_c_binding") == 0
4536 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
4537 "ISO_C_BINDING module at %C") != FAILURE
)
4539 import_iso_c_binding_module();
4543 module_fp
= gfc_open_intrinsic_module (filename
);
4545 if (module_fp
== NULL
&& specified_int
)
4546 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4550 if (module_fp
== NULL
)
4551 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4552 filename
, strerror (errno
));
4554 /* Check that we haven't already USEd an intrinsic module with the
4557 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
4558 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
4559 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4560 "intrinsic module name used previously", module_name
);
4567 /* Skip the first two lines of the module, after checking that this is
4568 a gfortran module file. */
4574 bad_module ("Unexpected end of module");
4577 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
4578 || (start
== 2 && strcmp (atom_name
, " module") != 0))
4579 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4586 /* Make sure we're not reading the same module that we may be building. */
4587 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4588 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
4589 gfc_fatal_error ("Can't USE the same module we're building!");
4592 init_true_name_tree ();
4596 free_true_name (true_name_root
);
4597 true_name_root
= NULL
;
4599 free_pi_tree (pi_root
);
4607 gfc_module_init_2 (void)
4609 last_atom
= ATOM_LPAREN
;
4614 gfc_module_done_2 (void)