1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
24 /* The syntax of g95 modules resembles that of lisp lists, ie 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>)
50 ( <Symbol Number (in no particular order)>
52 <Module name of symbol>
53 ( <symbol information> )
62 In general, symbols refer to other symbols by their symbol number,
63 which are zero based. Symbols are written to the module in no
76 #include "parse.h" /* FIXME */
78 #define MODULE_EXTENSION ".mod"
81 /* Structure that descibes a position within a module file */
93 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
97 /* The fixup structure lists pointers to pointers that have to
98 be updated when a pointer value becomes known. */
100 typedef struct fixup_t
103 struct fixup_t
*next
;
108 /* Structure for holding extra info needed for pointers being read */
110 typedef struct pointer_info
112 BBT_HEADER (pointer_info
);
116 /* The first component of each member of the union is the pointer
123 void *pointer
; /* Member for doing pointer searches */
128 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
130 { UNUSED
, NEEDED
, USED
}
135 gfc_symtree
*symtree
;
143 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
153 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
156 /* Lists of rename info for the USE statement */
158 typedef struct gfc_use_rename
160 char local_name
[GFC_MAX_SYMBOL_LEN
+ 1], use_name
[GFC_MAX_SYMBOL_LEN
+ 1];
161 struct gfc_use_rename
*next
;
163 gfc_intrinsic_op
operator;
168 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
170 /* Local variables */
172 /* The FILE for the module we're reading or writing. */
173 static FILE *module_fp
;
175 /* The name of the module we're reading (USE'ing) or writing. */
176 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
178 static int module_line
, module_column
, only_flag
;
180 { IO_INPUT
, IO_OUTPUT
}
183 static gfc_use_rename
*gfc_rename_list
;
184 static pointer_info
*pi_root
;
185 static int symbol_number
; /* Counter for assigning symbol numbers */
189 /*****************************************************************/
191 /* Pointer/integer conversion. Pointers between structures are stored
192 as integers in the module file. The next couple of subroutines
193 handle this translation for reading and writing. */
195 /* Recursively free the tree of pointer structures. */
198 free_pi_tree (pointer_info
* p
)
204 if (p
->fixup
!= NULL
)
205 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
207 free_pi_tree (p
->left
);
208 free_pi_tree (p
->right
);
214 /* Compare pointers when searching by pointer. Used when writing a
218 compare_pointers (void * _sn1
, void * _sn2
)
220 pointer_info
*sn1
, *sn2
;
222 sn1
= (pointer_info
*) _sn1
;
223 sn2
= (pointer_info
*) _sn2
;
225 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
227 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
234 /* Compare integers when searching by integer. Used when reading a
238 compare_integers (void * _sn1
, void * _sn2
)
240 pointer_info
*sn1
, *sn2
;
242 sn1
= (pointer_info
*) _sn1
;
243 sn2
= (pointer_info
*) _sn2
;
245 if (sn1
->integer
< sn2
->integer
)
247 if (sn1
->integer
> sn2
->integer
)
254 /* Initialize the pointer_info tree. */
263 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
265 /* Pointer 0 is the NULL pointer. */
266 p
= gfc_get_pointer_info ();
271 gfc_insert_bbt (&pi_root
, p
, compare
);
273 /* Pointer 1 is the current namespace. */
274 p
= gfc_get_pointer_info ();
275 p
->u
.pointer
= gfc_current_ns
;
277 p
->type
= P_NAMESPACE
;
279 gfc_insert_bbt (&pi_root
, p
, compare
);
285 /* During module writing, call here with a pointer to something,
286 returning the pointer_info node. */
288 static pointer_info
*
289 find_pointer (void *gp
)
296 if (p
->u
.pointer
== gp
)
298 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
305 /* Given a pointer while writing, returns the pointer_info tree node,
306 creating it if it doesn't exist. */
308 static pointer_info
*
309 get_pointer (void *gp
)
313 p
= find_pointer (gp
);
317 /* Pointer doesn't have an integer. Give it one. */
318 p
= gfc_get_pointer_info ();
321 p
->integer
= symbol_number
++;
323 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
329 /* Given an integer during reading, find it in the pointer_info tree,
330 creating the node if not found. */
332 static pointer_info
*
333 get_integer (int integer
)
343 c
= compare_integers (&t
, p
);
347 p
= (c
< 0) ? p
->left
: p
->right
;
353 p
= gfc_get_pointer_info ();
354 p
->integer
= integer
;
357 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
363 /* Recursive function to find a pointer within a tree by brute force. */
365 static pointer_info
*
366 fp2 (pointer_info
* p
, const void *target
)
373 if (p
->u
.pointer
== target
)
376 q
= fp2 (p
->left
, target
);
380 return fp2 (p
->right
, target
);
384 /* During reading, find a pointer_info node from the pointer value.
385 This amounts to a brute-force search. */
387 static pointer_info
*
388 find_pointer2 (void *p
)
391 return fp2 (pi_root
, p
);
395 /* Resolve any fixups using a known pointer. */
397 resolve_fixups (fixup_t
*f
, void * gp
)
409 /* Call here during module reading when we know what pointer to
410 associate with an integer. Any fixups that exist are resolved at
414 associate_integer_pointer (pointer_info
* p
, void *gp
)
416 if (p
->u
.pointer
!= NULL
)
417 gfc_internal_error ("associate_integer_pointer(): Already associated");
421 resolve_fixups (p
->fixup
, gp
);
427 /* During module reading, given an integer and a pointer to a pointer,
428 either store the pointer from an already-known value or create a
429 fixup structure in order to store things later. Returns zero if
430 the reference has been actually stored, or nonzero if the reference
431 must be fixed later (ie associate_integer_pointer must be called
432 sometime later. Returns the pointer_info structure. */
434 static pointer_info
*
435 add_fixup (int integer
, void *gp
)
441 p
= get_integer (integer
);
443 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
450 f
= gfc_getmem (sizeof (fixup_t
));
462 /*****************************************************************/
464 /* Parser related subroutines */
466 /* Free the rename list left behind by a USE statement. */
471 gfc_use_rename
*next
;
473 for (; gfc_rename_list
; gfc_rename_list
= next
)
475 next
= gfc_rename_list
->next
;
476 gfc_free (gfc_rename_list
);
481 /* Match a USE statement. */
486 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
487 gfc_use_rename
*tail
= NULL
, *new;
489 gfc_intrinsic_op
operator;
492 m
= gfc_match_name (module_name
);
499 if (gfc_match_eos () == MATCH_YES
)
501 if (gfc_match_char (',') != MATCH_YES
)
504 if (gfc_match (" only :") == MATCH_YES
)
507 if (gfc_match_eos () == MATCH_YES
)
512 /* Get a new rename struct and add it to the rename list. */
513 new = gfc_get_use_rename ();
514 new->where
= gfc_current_locus
;
517 if (gfc_rename_list
== NULL
)
518 gfc_rename_list
= new;
523 /* See what kind of interface we're dealing with. Assume it is
525 new->operator = INTRINSIC_NONE
;
526 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
531 case INTERFACE_NAMELESS
:
532 gfc_error ("Missing generic specification in USE statement at %C");
535 case INTERFACE_GENERIC
:
536 m
= gfc_match (" =>");
541 strcpy (new->use_name
, name
);
544 strcpy (new->local_name
, name
);
546 m
= gfc_match_name (new->use_name
);
549 if (m
== MATCH_ERROR
)
557 strcpy (new->local_name
, name
);
559 m
= gfc_match_name (new->use_name
);
562 if (m
== MATCH_ERROR
)
568 case INTERFACE_USER_OP
:
569 strcpy (new->use_name
, name
);
572 case INTERFACE_INTRINSIC_OP
:
573 new->operator = operator;
577 if (gfc_match_eos () == MATCH_YES
)
579 if (gfc_match_char (',') != MATCH_YES
)
586 gfc_syntax_error (ST_USE
);
594 /* Given a name, return the name under which to load this symbol.
595 Returns NULL if this symbol shouldn't be loaded. */
598 find_use_name (const char *name
)
602 for (u
= gfc_rename_list
; u
; u
= u
->next
)
603 if (strcmp (u
->use_name
, name
) == 0)
607 return only_flag
? NULL
: name
;
611 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
615 /* Try to find the operator in the current list. */
617 static gfc_use_rename
*
618 find_use_operator (gfc_intrinsic_op
operator)
622 for (u
= gfc_rename_list
; u
; u
= u
->next
)
623 if (u
->operator == operator)
630 /*****************************************************************/
632 /* The next couple of subroutines maintain a tree used to avoid a
633 brute-force search for a combination of true name and module name.
634 While symtree names, the name that a particular symbol is known by
635 can changed with USE statements, we still have to keep track of the
636 true names to generate the correct reference, and also avoid
637 loading the same real symbol twice in a program unit.
639 When we start reading, the true name tree is built and maintained
640 as symbols are read. The tree is searched as we load new symbols
641 to see if it already exists someplace in the namespace. */
643 typedef struct true_name
645 BBT_HEADER (true_name
);
650 static true_name
*true_name_root
;
653 /* Compare two true_name structures. */
656 compare_true_names (void * _t1
, void * _t2
)
661 t1
= (true_name
*) _t1
;
662 t2
= (true_name
*) _t2
;
664 c
= strcmp (t1
->sym
->module
, t2
->sym
->module
);
668 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
672 /* Given a true name, search the true name tree to see if it exists
673 within the main namespace. */
676 find_true_name (const char *name
, const char *module
)
682 strcpy (sym
.name
, name
);
683 strcpy (sym
.module
, module
);
689 c
= compare_true_names ((void *)(&t
), (void *) p
);
693 p
= (c
< 0) ? p
->left
: p
->right
;
700 /* Given a gfc_symbol pointer that is not in the true name tree, add
704 add_true_name (gfc_symbol
* sym
)
708 t
= gfc_getmem (sizeof (true_name
));
711 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
715 /* Recursive function to build the initial true name tree by
716 recursively traversing the current namespace. */
719 build_tnt (gfc_symtree
* st
)
725 build_tnt (st
->left
);
726 build_tnt (st
->right
);
728 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
731 add_true_name (st
->n
.sym
);
735 /* Initialize the true name tree with the current namespace. */
738 init_true_name_tree (void)
740 true_name_root
= NULL
;
742 build_tnt (gfc_current_ns
->sym_root
);
746 /* Recursively free a true name tree node. */
749 free_true_name (true_name
* t
)
754 free_true_name (t
->left
);
755 free_true_name (t
->right
);
761 /*****************************************************************/
763 /* Module reading and writing. */
767 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
771 static atom_type last_atom
;
774 /* The name buffer must be at least as long as a symbol name. Right
775 now it's not clear how we're going to store numeric constants--
776 probably as a hexadecimal string, since this will allow the exact
777 number to be preserved (this can't be done by a decimal
778 representation). Worry about that later. TODO! */
780 #define MAX_ATOM_SIZE 100
783 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
786 /* Report problems with a module. Error reporting is not very
787 elaborate, since this sorts of errors shouldn't really happen.
788 This subroutine never returns. */
790 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
793 bad_module (const char *message
)
812 gfc_fatal_error ("%s module %s at line %d column %d: %s", p
,
813 module_name
, module_line
, module_column
, message
);
817 /* Set the module's input pointer. */
820 set_module_locus (module_locus
* m
)
823 module_column
= m
->column
;
824 module_line
= m
->line
;
825 fsetpos (module_fp
, &m
->pos
);
829 /* Get the module's input pointer so that we can restore it later. */
832 get_module_locus (module_locus
* m
)
835 m
->column
= module_column
;
836 m
->line
= module_line
;
837 fgetpos (module_fp
, &m
->pos
);
841 /* Get the next character in the module, updating our reckoning of
849 c
= fgetc (module_fp
);
852 bad_module ("Unexpected EOF");
865 /* Parse a string constant. The delimiter is guaranteed to be a
875 get_module_locus (&start
);
879 /* See how long the string is */
884 bad_module ("Unexpected end of module in string constant");
902 set_module_locus (&start
);
904 atom_string
= p
= gfc_getmem (len
+ 1);
906 for (; len
> 0; len
--)
910 module_char (); /* Guaranteed to be another \' */
914 module_char (); /* Terminating \' */
915 *p
= '\0'; /* C-style string for debug purposes */
919 /* Parse a small integer. */
922 parse_integer (int c
)
930 get_module_locus (&m
);
936 atom_int
= 10 * atom_int
+ c
- '0';
937 if (atom_int
> 99999999)
938 bad_module ("Integer overflow");
941 set_module_locus (&m
);
959 get_module_locus (&m
);
964 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
968 if (++len
> GFC_MAX_SYMBOL_LEN
)
969 bad_module ("Name too long");
974 fseek (module_fp
, -1, SEEK_CUR
);
975 module_column
= m
.column
+ len
- 1;
982 /* Read the next atom in the module's input stream. */
993 while (c
== ' ' || c
== '\n');
1018 return ATOM_INTEGER
;
1076 bad_module ("Bad name");
1083 /* Peek at the next atom on the input. */
1091 get_module_locus (&m
);
1094 if (a
== ATOM_STRING
)
1095 gfc_free (atom_string
);
1097 set_module_locus (&m
);
1102 /* Read the next atom from the input, requiring that it be a
1106 require_atom (atom_type type
)
1112 get_module_locus (&m
);
1120 p
= "Expected name";
1123 p
= "Expected left parenthesis";
1126 p
= "Expected right parenthesis";
1129 p
= "Expected integer";
1132 p
= "Expected string";
1135 gfc_internal_error ("require_atom(): bad atom type required");
1138 set_module_locus (&m
);
1144 /* Given a pointer to an mstring array, require that the current input
1145 be one of the strings in the array. We return the enum value. */
1148 find_enum (const mstring
* m
)
1152 i
= gfc_string2code (m
, atom_name
);
1156 bad_module ("find_enum(): Enum not found");
1162 /**************** Module output subroutines ***************************/
1164 /* Output a character to a module file. */
1167 write_char (char out
)
1170 if (fputc (out
, module_fp
) == EOF
)
1171 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1183 /* Write an atom to a module. The line wrapping isn't perfect, but it
1184 should work most of the time. This isn't that big of a deal, since
1185 the file really isn't meant to be read by people anyway. */
1188 write_atom (atom_type atom
, const void *v
)
1210 i
= *((const int *) v
);
1212 gfc_internal_error ("write_atom(): Writing negative integer");
1214 sprintf (buffer
, "%d", i
);
1219 gfc_internal_error ("write_atom(): Trying to write dab atom");
1225 if (atom
!= ATOM_RPAREN
)
1227 if (module_column
+ len
> 72)
1232 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1237 if (atom
== ATOM_STRING
)
1242 if (atom
== ATOM_STRING
&& *p
== '\'')
1247 if (atom
== ATOM_STRING
)
1255 /***************** Mid-level I/O subroutines *****************/
1257 /* These subroutines let their caller read or write atoms without
1258 caring about which of the two is actually happening. This lets a
1259 subroutine concentrate on the actual format of the data being
1262 static void mio_expr (gfc_expr
**);
1263 static void mio_symbol_ref (gfc_symbol
**);
1264 static void mio_symtree_ref (gfc_symtree
**);
1266 /* Read or write an enumerated value. On writing, we return the input
1267 value for the convenience of callers. We avoid using an integer
1268 pointer because enums are sometimes inside bitfields. */
1271 mio_name (int t
, const mstring
* m
)
1274 if (iomode
== IO_OUTPUT
)
1275 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1278 require_atom (ATOM_NAME
);
1285 /* Specialisation of mio_name. */
1287 #define DECL_MIO_NAME(TYPE) \
1288 static inline TYPE \
1289 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1291 return (TYPE)mio_name ((int)t, m); \
1293 #define MIO_NAME(TYPE) mio_name_##TYPE
1299 if (iomode
== IO_OUTPUT
)
1300 write_atom (ATOM_LPAREN
, NULL
);
1302 require_atom (ATOM_LPAREN
);
1310 if (iomode
== IO_OUTPUT
)
1311 write_atom (ATOM_RPAREN
, NULL
);
1313 require_atom (ATOM_RPAREN
);
1318 mio_integer (int *ip
)
1321 if (iomode
== IO_OUTPUT
)
1322 write_atom (ATOM_INTEGER
, ip
);
1325 require_atom (ATOM_INTEGER
);
1331 /* Read or write a character pointer that points to a string on the
1335 mio_allocated_string (char **sp
)
1338 if (iomode
== IO_OUTPUT
)
1339 write_atom (ATOM_STRING
, *sp
);
1342 require_atom (ATOM_STRING
);
1348 /* Read or write a string that is in static memory or inside of some
1349 already-allocated structure. */
1352 mio_internal_string (char *string
)
1355 if (iomode
== IO_OUTPUT
)
1356 write_atom (ATOM_STRING
, string
);
1359 require_atom (ATOM_STRING
);
1360 strcpy (string
, atom_string
);
1361 gfc_free (atom_string
);
1368 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1369 AB_POINTER
, AB_SAVE
, AB_TARGET
, AB_DUMMY
, AB_RESULT
,
1370 AB_ENTRY
, AB_DATA
, AB_IN_NAMELIST
, AB_IN_COMMON
,
1371 AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
, AB_ELEMENTAL
, AB_PURE
,
1372 AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
1376 static const mstring attr_bits
[] =
1378 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1379 minit ("DIMENSION", AB_DIMENSION
),
1380 minit ("EXTERNAL", AB_EXTERNAL
),
1381 minit ("INTRINSIC", AB_INTRINSIC
),
1382 minit ("OPTIONAL", AB_OPTIONAL
),
1383 minit ("POINTER", AB_POINTER
),
1384 minit ("SAVE", AB_SAVE
),
1385 minit ("TARGET", AB_TARGET
),
1386 minit ("DUMMY", AB_DUMMY
),
1387 minit ("RESULT", AB_RESULT
),
1388 minit ("ENTRY", AB_ENTRY
),
1389 minit ("DATA", AB_DATA
),
1390 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1391 minit ("IN_COMMON", AB_IN_COMMON
),
1392 minit ("FUNCTION", AB_FUNCTION
),
1393 minit ("SUBROUTINE", AB_SUBROUTINE
),
1394 minit ("SEQUENCE", AB_SEQUENCE
),
1395 minit ("ELEMENTAL", AB_ELEMENTAL
),
1396 minit ("PURE", AB_PURE
),
1397 minit ("RECURSIVE", AB_RECURSIVE
),
1398 minit ("GENERIC", AB_GENERIC
),
1399 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1403 /* Specialisation of mio_name. */
1404 DECL_MIO_NAME(ab_attribute
)
1405 DECL_MIO_NAME(ar_type
)
1406 DECL_MIO_NAME(array_type
)
1408 DECL_MIO_NAME(expr_t
)
1409 DECL_MIO_NAME(gfc_access
)
1410 DECL_MIO_NAME(gfc_intrinsic_op
)
1411 DECL_MIO_NAME(ifsrc
)
1412 DECL_MIO_NAME(procedure_type
)
1413 DECL_MIO_NAME(ref_type
)
1414 DECL_MIO_NAME(sym_flavor
)
1415 DECL_MIO_NAME(sym_intent
)
1416 #undef DECL_MIO_NAME
1418 /* Symbol attributes are stored in list with the first three elements
1419 being the enumerated fields, while the remaining elements (if any)
1420 indicate the individual attribute bits. The access field is not
1421 saved-- it controls what symbols are exported when a module is
1425 mio_symbol_attribute (symbol_attribute
* attr
)
1431 attr
->flavor
= MIO_NAME(sym_flavor
) (attr
->flavor
, flavors
);
1432 attr
->intent
= MIO_NAME(sym_intent
) (attr
->intent
, intents
);
1433 attr
->proc
= MIO_NAME(procedure_type
) (attr
->proc
, procedures
);
1434 attr
->if_source
= MIO_NAME(ifsrc
) (attr
->if_source
, ifsrc_types
);
1436 if (iomode
== IO_OUTPUT
)
1438 if (attr
->allocatable
)
1439 MIO_NAME(ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1440 if (attr
->dimension
)
1441 MIO_NAME(ab_attribute
) (AB_DIMENSION
, attr_bits
);
1443 MIO_NAME(ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1444 if (attr
->intrinsic
)
1445 MIO_NAME(ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1447 MIO_NAME(ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1449 MIO_NAME(ab_attribute
) (AB_POINTER
, attr_bits
);
1451 MIO_NAME(ab_attribute
) (AB_SAVE
, attr_bits
);
1453 MIO_NAME(ab_attribute
) (AB_TARGET
, attr_bits
);
1455 MIO_NAME(ab_attribute
) (AB_DUMMY
, attr_bits
);
1457 MIO_NAME(ab_attribute
) (AB_RESULT
, attr_bits
);
1459 MIO_NAME(ab_attribute
) (AB_ENTRY
, attr_bits
);
1462 MIO_NAME(ab_attribute
) (AB_DATA
, attr_bits
);
1463 if (attr
->in_namelist
)
1464 MIO_NAME(ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1465 if (attr
->in_common
)
1466 MIO_NAME(ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1469 MIO_NAME(ab_attribute
) (AB_FUNCTION
, attr_bits
);
1470 if (attr
->subroutine
)
1471 MIO_NAME(ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1473 MIO_NAME(ab_attribute
) (AB_GENERIC
, attr_bits
);
1476 MIO_NAME(ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1477 if (attr
->elemental
)
1478 MIO_NAME(ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1480 MIO_NAME(ab_attribute
) (AB_PURE
, attr_bits
);
1481 if (attr
->recursive
)
1482 MIO_NAME(ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1483 if (attr
->always_explicit
)
1484 MIO_NAME(ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1495 if (t
== ATOM_RPAREN
)
1498 bad_module ("Expected attribute bit name");
1500 switch ((ab_attribute
) find_enum (attr_bits
))
1502 case AB_ALLOCATABLE
:
1503 attr
->allocatable
= 1;
1506 attr
->dimension
= 1;
1512 attr
->intrinsic
= 1;
1538 case AB_IN_NAMELIST
:
1539 attr
->in_namelist
= 1;
1542 attr
->in_common
= 1;
1548 attr
->subroutine
= 1;
1557 attr
->elemental
= 1;
1563 attr
->recursive
= 1;
1565 case AB_ALWAYS_EXPLICIT
:
1566 attr
->always_explicit
= 1;
1574 static const mstring bt_types
[] = {
1575 minit ("INTEGER", BT_INTEGER
),
1576 minit ("REAL", BT_REAL
),
1577 minit ("COMPLEX", BT_COMPLEX
),
1578 minit ("LOGICAL", BT_LOGICAL
),
1579 minit ("CHARACTER", BT_CHARACTER
),
1580 minit ("DERIVED", BT_DERIVED
),
1581 minit ("PROCEDURE", BT_PROCEDURE
),
1582 minit ("UNKNOWN", BT_UNKNOWN
),
1588 mio_charlen (gfc_charlen
** clp
)
1594 if (iomode
== IO_OUTPUT
)
1598 mio_expr (&cl
->length
);
1603 if (peek_atom () != ATOM_RPAREN
)
1605 cl
= gfc_get_charlen ();
1606 mio_expr (&cl
->length
);
1610 cl
->next
= gfc_current_ns
->cl_list
;
1611 gfc_current_ns
->cl_list
= cl
;
1619 /* Return a symtree node with a name that is guaranteed to be unique
1620 within the namespace and corresponds to an illegal fortran name. */
1622 static gfc_symtree
*
1623 get_unique_symtree (gfc_namespace
* ns
)
1625 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1626 static int serial
= 0;
1628 sprintf (name
, "@%d", serial
++);
1629 return gfc_new_symtree (&ns
->sym_root
, name
);
1633 /* See if a name is a generated name. */
1636 check_unique_name (const char *name
)
1639 return *name
== '@';
1644 mio_typespec (gfc_typespec
* ts
)
1649 ts
->type
= MIO_NAME(bt
) (ts
->type
, bt_types
);
1651 if (ts
->type
!= BT_DERIVED
)
1652 mio_integer (&ts
->kind
);
1654 mio_symbol_ref (&ts
->derived
);
1656 mio_charlen (&ts
->cl
);
1662 static const mstring array_spec_types
[] = {
1663 minit ("EXPLICIT", AS_EXPLICIT
),
1664 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
1665 minit ("DEFERRED", AS_DEFERRED
),
1666 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
1672 mio_array_spec (gfc_array_spec
** asp
)
1679 if (iomode
== IO_OUTPUT
)
1687 if (peek_atom () == ATOM_RPAREN
)
1693 *asp
= as
= gfc_get_array_spec ();
1696 mio_integer (&as
->rank
);
1697 as
->type
= MIO_NAME(array_type
) (as
->type
, array_spec_types
);
1699 for (i
= 0; i
< as
->rank
; i
++)
1701 mio_expr (&as
->lower
[i
]);
1702 mio_expr (&as
->upper
[i
]);
1710 /* Given a pointer to an array reference structure (which lives in a
1711 gfc_ref structure), find the corresponding array specification
1712 structure. Storing the pointer in the ref structure doesn't quite
1713 work when loading from a module. Generating code for an array
1714 reference also needs more infomation than just the array spec. */
1716 static const mstring array_ref_types
[] = {
1717 minit ("FULL", AR_FULL
),
1718 minit ("ELEMENT", AR_ELEMENT
),
1719 minit ("SECTION", AR_SECTION
),
1724 mio_array_ref (gfc_array_ref
* ar
)
1729 ar
->type
= MIO_NAME(ar_type
) (ar
->type
, array_ref_types
);
1730 mio_integer (&ar
->dimen
);
1738 for (i
= 0; i
< ar
->dimen
; i
++)
1739 mio_expr (&ar
->start
[i
]);
1744 for (i
= 0; i
< ar
->dimen
; i
++)
1746 mio_expr (&ar
->start
[i
]);
1747 mio_expr (&ar
->end
[i
]);
1748 mio_expr (&ar
->stride
[i
]);
1754 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1757 for (i
= 0; i
< ar
->dimen
; i
++)
1758 mio_integer ((int *) &ar
->dimen_type
[i
]);
1760 if (iomode
== IO_INPUT
)
1762 ar
->where
= gfc_current_locus
;
1764 for (i
= 0; i
< ar
->dimen
; i
++)
1765 ar
->c_where
[i
] = gfc_current_locus
;
1772 /* Saves or restores a pointer. The pointer is converted back and
1773 forth from an integer. We return the pointer_info pointer so that
1774 the caller can take additional action based on the pointer type. */
1776 static pointer_info
*
1777 mio_pointer_ref (void *gp
)
1781 if (iomode
== IO_OUTPUT
)
1783 p
= get_pointer (*((char **) gp
));
1784 write_atom (ATOM_INTEGER
, &p
->integer
);
1788 require_atom (ATOM_INTEGER
);
1789 p
= add_fixup (atom_int
, gp
);
1796 /* Save and load references to components that occur within
1797 expressions. We have to describe these references by a number and
1798 by name. The number is necessary for forward references during
1799 reading, and the name is necessary if the symbol already exists in
1800 the namespace and is not loaded again. */
1803 mio_component_ref (gfc_component
** cp
, gfc_symbol
* sym
)
1805 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1809 p
= mio_pointer_ref (cp
);
1810 if (p
->type
== P_UNKNOWN
)
1811 p
->type
= P_COMPONENT
;
1813 if (iomode
== IO_OUTPUT
)
1814 mio_internal_string ((*cp
)->name
);
1817 mio_internal_string (name
);
1819 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
1821 /* Symbol already loaded, so search by name. */
1822 for (q
= sym
->components
; q
; q
= q
->next
)
1823 if (strcmp (q
->name
, name
) == 0)
1827 gfc_internal_error ("mio_component_ref(): Component not found");
1829 associate_integer_pointer (p
, q
);
1832 /* Make sure this symbol will eventually be loaded. */
1833 p
= find_pointer2 (sym
);
1834 if (p
->u
.rsym
.state
== UNUSED
)
1835 p
->u
.rsym
.state
= NEEDED
;
1841 mio_component (gfc_component
* c
)
1848 if (iomode
== IO_OUTPUT
)
1850 p
= get_pointer (c
);
1851 mio_integer (&p
->integer
);
1856 p
= get_integer (n
);
1857 associate_integer_pointer (p
, c
);
1860 if (p
->type
== P_UNKNOWN
)
1861 p
->type
= P_COMPONENT
;
1863 mio_internal_string (c
->name
);
1864 mio_typespec (&c
->ts
);
1865 mio_array_spec (&c
->as
);
1867 mio_integer (&c
->dimension
);
1868 mio_integer (&c
->pointer
);
1870 mio_expr (&c
->initializer
);
1876 mio_component_list (gfc_component
** cp
)
1878 gfc_component
*c
, *tail
;
1882 if (iomode
== IO_OUTPUT
)
1884 for (c
= *cp
; c
; c
= c
->next
)
1895 if (peek_atom () == ATOM_RPAREN
)
1898 c
= gfc_get_component ();
1915 mio_actual_arg (gfc_actual_arglist
* a
)
1919 mio_internal_string (a
->name
);
1920 mio_expr (&a
->expr
);
1926 mio_actual_arglist (gfc_actual_arglist
** ap
)
1928 gfc_actual_arglist
*a
, *tail
;
1932 if (iomode
== IO_OUTPUT
)
1934 for (a
= *ap
; a
; a
= a
->next
)
1944 if (peek_atom () != ATOM_LPAREN
)
1947 a
= gfc_get_actual_arglist ();
1963 /* Read and write formal argument lists. */
1966 mio_formal_arglist (gfc_symbol
* sym
)
1968 gfc_formal_arglist
*f
, *tail
;
1972 if (iomode
== IO_OUTPUT
)
1974 for (f
= sym
->formal
; f
; f
= f
->next
)
1975 mio_symbol_ref (&f
->sym
);
1980 sym
->formal
= tail
= NULL
;
1982 while (peek_atom () != ATOM_RPAREN
)
1984 f
= gfc_get_formal_arglist ();
1985 mio_symbol_ref (&f
->sym
);
1987 if (sym
->formal
== NULL
)
2000 /* Save or restore a reference to a symbol node. */
2003 mio_symbol_ref (gfc_symbol
** symp
)
2007 p
= mio_pointer_ref (symp
);
2008 if (p
->type
== P_UNKNOWN
)
2011 if (iomode
== IO_OUTPUT
)
2013 if (p
->u
.wsym
.state
== UNREFERENCED
)
2014 p
->u
.wsym
.state
= NEEDS_WRITE
;
2018 if (p
->u
.rsym
.state
== UNUSED
)
2019 p
->u
.rsym
.state
= NEEDED
;
2024 /* Save or restore a reference to a symtree node. */
2027 mio_symtree_ref (gfc_symtree
** stp
)
2032 if (iomode
== IO_OUTPUT
)
2034 mio_symbol_ref (&(*stp
)->n
.sym
);
2038 require_atom (ATOM_INTEGER
);
2039 p
= get_integer (atom_int
);
2040 if (p
->type
== P_UNKNOWN
)
2043 if (p
->u
.rsym
.state
== UNUSED
)
2044 p
->u
.rsym
.state
= NEEDED
;
2046 if (p
->u
.rsym
.symtree
!= NULL
)
2048 *stp
= p
->u
.rsym
.symtree
;
2052 f
= gfc_getmem (sizeof (fixup_t
));
2054 f
->next
= p
->u
.rsym
.stfixup
;
2055 p
->u
.rsym
.stfixup
= f
;
2057 f
->pointer
= (void **)stp
;
2063 mio_iterator (gfc_iterator
** ip
)
2069 if (iomode
== IO_OUTPUT
)
2076 if (peek_atom () == ATOM_RPAREN
)
2082 *ip
= gfc_get_iterator ();
2087 mio_expr (&iter
->var
);
2088 mio_expr (&iter
->start
);
2089 mio_expr (&iter
->end
);
2090 mio_expr (&iter
->step
);
2099 mio_constructor (gfc_constructor
** cp
)
2101 gfc_constructor
*c
, *tail
;
2105 if (iomode
== IO_OUTPUT
)
2107 for (c
= *cp
; c
; c
= c
->next
)
2110 mio_expr (&c
->expr
);
2111 mio_iterator (&c
->iterator
);
2121 while (peek_atom () != ATOM_RPAREN
)
2123 c
= gfc_get_constructor ();
2133 mio_expr (&c
->expr
);
2134 mio_iterator (&c
->iterator
);
2144 static const mstring ref_types
[] = {
2145 minit ("ARRAY", REF_ARRAY
),
2146 minit ("COMPONENT", REF_COMPONENT
),
2147 minit ("SUBSTRING", REF_SUBSTRING
),
2153 mio_ref (gfc_ref
** rp
)
2160 r
->type
= MIO_NAME(ref_type
) (r
->type
, ref_types
);
2165 mio_array_ref (&r
->u
.ar
);
2169 mio_symbol_ref (&r
->u
.c
.sym
);
2170 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2174 mio_expr (&r
->u
.ss
.start
);
2175 mio_expr (&r
->u
.ss
.end
);
2176 mio_charlen (&r
->u
.ss
.length
);
2185 mio_ref_list (gfc_ref
** rp
)
2187 gfc_ref
*ref
, *head
, *tail
;
2191 if (iomode
== IO_OUTPUT
)
2193 for (ref
= *rp
; ref
; ref
= ref
->next
)
2200 while (peek_atom () != ATOM_RPAREN
)
2203 head
= tail
= gfc_get_ref ();
2206 tail
->next
= gfc_get_ref ();
2220 /* Read and write an integer value. */
2223 mio_gmp_integer (mpz_t
* integer
)
2227 if (iomode
== IO_INPUT
)
2229 if (parse_atom () != ATOM_STRING
)
2230 bad_module ("Expected integer string");
2232 mpz_init (*integer
);
2233 if (mpz_set_str (*integer
, atom_string
, 10))
2234 bad_module ("Error converting integer");
2236 gfc_free (atom_string
);
2241 p
= mpz_get_str (NULL
, 10, *integer
);
2242 write_atom (ATOM_STRING
, p
);
2249 mio_gmp_real (mpfr_t
* real
)
2254 if (iomode
== IO_INPUT
)
2256 if (parse_atom () != ATOM_STRING
)
2257 bad_module ("Expected real string");
2260 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2261 gfc_free (atom_string
);
2266 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2267 atom_string
= gfc_getmem (strlen (p
) + 20);
2269 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2271 /* Fix negative numbers. */
2272 if (atom_string
[2] == '-')
2274 atom_string
[0] = '-';
2275 atom_string
[1] = '0';
2276 atom_string
[2] = '.';
2279 write_atom (ATOM_STRING
, atom_string
);
2281 gfc_free (atom_string
);
2287 /* Save and restore the shape of an array constructor. */
2290 mio_shape (mpz_t
** pshape
, int rank
)
2296 /* A NULL shape is represented by (). */
2299 if (iomode
== IO_OUTPUT
)
2311 if (t
== ATOM_RPAREN
)
2318 shape
= gfc_get_shape (rank
);
2322 for (n
= 0; n
< rank
; n
++)
2323 mio_gmp_integer (&shape
[n
]);
2329 static const mstring expr_types
[] = {
2330 minit ("OP", EXPR_OP
),
2331 minit ("FUNCTION", EXPR_FUNCTION
),
2332 minit ("CONSTANT", EXPR_CONSTANT
),
2333 minit ("VARIABLE", EXPR_VARIABLE
),
2334 minit ("SUBSTRING", EXPR_SUBSTRING
),
2335 minit ("STRUCTURE", EXPR_STRUCTURE
),
2336 minit ("ARRAY", EXPR_ARRAY
),
2337 minit ("NULL", EXPR_NULL
),
2341 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2342 generic operators, not in expressions. INTRINSIC_USER is also
2343 replaced by the correct function name by the time we see it. */
2345 static const mstring intrinsics
[] =
2347 minit ("UPLUS", INTRINSIC_UPLUS
),
2348 minit ("UMINUS", INTRINSIC_UMINUS
),
2349 minit ("PLUS", INTRINSIC_PLUS
),
2350 minit ("MINUS", INTRINSIC_MINUS
),
2351 minit ("TIMES", INTRINSIC_TIMES
),
2352 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2353 minit ("POWER", INTRINSIC_POWER
),
2354 minit ("CONCAT", INTRINSIC_CONCAT
),
2355 minit ("AND", INTRINSIC_AND
),
2356 minit ("OR", INTRINSIC_OR
),
2357 minit ("EQV", INTRINSIC_EQV
),
2358 minit ("NEQV", INTRINSIC_NEQV
),
2359 minit ("EQ", INTRINSIC_EQ
),
2360 minit ("NE", INTRINSIC_NE
),
2361 minit ("GT", INTRINSIC_GT
),
2362 minit ("GE", INTRINSIC_GE
),
2363 minit ("LT", INTRINSIC_LT
),
2364 minit ("LE", INTRINSIC_LE
),
2365 minit ("NOT", INTRINSIC_NOT
),
2369 /* Read and write expressions. The form "()" is allowed to indicate a
2373 mio_expr (gfc_expr
** ep
)
2381 if (iomode
== IO_OUTPUT
)
2390 MIO_NAME(expr_t
) (e
->expr_type
, expr_types
);
2396 if (t
== ATOM_RPAREN
)
2403 bad_module ("Expected expression type");
2405 e
= *ep
= gfc_get_expr ();
2406 e
->where
= gfc_current_locus
;
2407 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2410 mio_typespec (&e
->ts
);
2411 mio_integer (&e
->rank
);
2413 switch (e
->expr_type
)
2416 e
->operator = MIO_NAME(gfc_intrinsic_op
) (e
->operator, intrinsics
);
2418 switch (e
->operator)
2420 case INTRINSIC_UPLUS
:
2421 case INTRINSIC_UMINUS
:
2426 case INTRINSIC_PLUS
:
2427 case INTRINSIC_MINUS
:
2428 case INTRINSIC_TIMES
:
2429 case INTRINSIC_DIVIDE
:
2430 case INTRINSIC_POWER
:
2431 case INTRINSIC_CONCAT
:
2435 case INTRINSIC_NEQV
:
2447 bad_module ("Bad operator");
2453 mio_symtree_ref (&e
->symtree
);
2454 mio_actual_arglist (&e
->value
.function
.actual
);
2456 if (iomode
== IO_OUTPUT
)
2458 mio_allocated_string (&e
->value
.function
.name
);
2459 flag
= e
->value
.function
.esym
!= NULL
;
2460 mio_integer (&flag
);
2462 mio_symbol_ref (&e
->value
.function
.esym
);
2464 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2469 require_atom (ATOM_STRING
);
2470 e
->value
.function
.name
= gfc_get_string (atom_string
);
2471 gfc_free (atom_string
);
2473 mio_integer (&flag
);
2475 mio_symbol_ref (&e
->value
.function
.esym
);
2478 require_atom (ATOM_STRING
);
2479 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2480 gfc_free (atom_string
);
2487 mio_symtree_ref (&e
->symtree
);
2488 mio_ref_list (&e
->ref
);
2491 case EXPR_SUBSTRING
:
2492 mio_allocated_string (&e
->value
.character
.string
);
2497 case EXPR_STRUCTURE
:
2499 mio_constructor (&e
->value
.constructor
);
2500 mio_shape (&e
->shape
, e
->rank
);
2507 mio_gmp_integer (&e
->value
.integer
);
2511 gfc_set_model_kind (e
->ts
.kind
);
2512 mio_gmp_real (&e
->value
.real
);
2516 gfc_set_model_kind (e
->ts
.kind
);
2517 mio_gmp_real (&e
->value
.complex.r
);
2518 mio_gmp_real (&e
->value
.complex.i
);
2522 mio_integer (&e
->value
.logical
);
2526 mio_integer (&e
->value
.character
.length
);
2527 mio_allocated_string (&e
->value
.character
.string
);
2531 bad_module ("Bad type in constant expression");
2544 /* Save/restore lists of gfc_interface stuctures. When loading an
2545 interface, we are really appending to the existing list of
2546 interfaces. Checking for duplicate and ambiguous interfaces has to
2547 be done later when all symbols have been loaded. */
2550 mio_interface_rest (gfc_interface
** ip
)
2552 gfc_interface
*tail
, *p
;
2554 if (iomode
== IO_OUTPUT
)
2557 for (p
= *ip
; p
; p
= p
->next
)
2558 mio_symbol_ref (&p
->sym
);
2574 if (peek_atom () == ATOM_RPAREN
)
2577 p
= gfc_get_interface ();
2578 mio_symbol_ref (&p
->sym
);
2593 /* Save/restore a nameless operator interface. */
2596 mio_interface (gfc_interface
** ip
)
2600 mio_interface_rest (ip
);
2604 /* Save/restore a named operator interface. */
2607 mio_symbol_interface (char *name
, char *module
,
2608 gfc_interface
** ip
)
2613 mio_internal_string (name
);
2614 mio_internal_string (module
);
2616 mio_interface_rest (ip
);
2621 mio_namespace_ref (gfc_namespace
** nsp
)
2626 p
= mio_pointer_ref (nsp
);
2628 if (p
->type
== P_UNKNOWN
)
2629 p
->type
= P_NAMESPACE
;
2631 if (iomode
== IO_INPUT
&& p
->integer
!= 0 && p
->u
.pointer
== NULL
)
2633 ns
= gfc_get_namespace (NULL
);
2634 associate_integer_pointer (p
, ns
);
2639 /* Unlike most other routines, the address of the symbol node is
2640 already fixed on input and the name/module has already been filled
2644 mio_symbol (gfc_symbol
* sym
)
2646 gfc_formal_arglist
*formal
;
2650 mio_symbol_attribute (&sym
->attr
);
2651 mio_typespec (&sym
->ts
);
2653 /* Contained procedures don't have formal namespaces. Instead we output the
2654 procedure namespace. The will contain the formal arguments. */
2655 if (iomode
== IO_OUTPUT
)
2657 formal
= sym
->formal
;
2658 while (formal
&& !formal
->sym
)
2659 formal
= formal
->next
;
2662 mio_namespace_ref (&formal
->sym
->ns
);
2664 mio_namespace_ref (&sym
->formal_ns
);
2668 mio_namespace_ref (&sym
->formal_ns
);
2671 sym
->formal_ns
->proc_name
= sym
;
2676 /* Save/restore common block links */
2677 mio_symbol_ref (&sym
->common_next
);
2679 mio_formal_arglist (sym
);
2681 if (sym
->attr
.flavor
== FL_PARAMETER
)
2682 mio_expr (&sym
->value
);
2684 mio_array_spec (&sym
->as
);
2686 mio_symbol_ref (&sym
->result
);
2688 /* Note that components are always saved, even if they are supposed
2689 to be private. Component access is checked during searching. */
2691 mio_component_list (&sym
->components
);
2693 if (sym
->components
!= NULL
)
2694 sym
->component_access
=
2695 MIO_NAME(gfc_access
) (sym
->component_access
, access_types
);
2701 /************************* Top level subroutines *************************/
2703 /* Skip a list between balanced left and right parens. */
2713 switch (parse_atom ())
2724 gfc_free (atom_string
);
2736 /* Load operator interfaces from the module. Interfaces are unusual
2737 in that they attach themselves to existing symbols. */
2740 load_operator_interfaces (void)
2743 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2748 while (peek_atom () != ATOM_RPAREN
)
2752 mio_internal_string (name
);
2753 mio_internal_string (module
);
2755 /* Decide if we need to load this one or not. */
2756 p
= find_use_name (name
);
2759 while (parse_atom () != ATOM_RPAREN
);
2763 uop
= gfc_get_uop (p
);
2764 mio_interface_rest (&uop
->operator);
2772 /* Load interfaces from the module. Interfaces are unusual in that
2773 they attach themselves to existing symbols. */
2776 load_generic_interfaces (void)
2779 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2784 while (peek_atom () != ATOM_RPAREN
)
2788 mio_internal_string (name
);
2789 mio_internal_string (module
);
2791 /* Decide if we need to load this one or not. */
2792 p
= find_use_name (name
);
2794 if (p
== NULL
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
2796 while (parse_atom () != ATOM_RPAREN
);
2802 gfc_get_symbol (p
, NULL
, &sym
);
2804 sym
->attr
.flavor
= FL_PROCEDURE
;
2805 sym
->attr
.generic
= 1;
2806 sym
->attr
.use_assoc
= 1;
2809 mio_interface_rest (&sym
->generic
);
2816 /* Load common blocks. */
2821 char name
[GFC_MAX_SYMBOL_LEN
+1];
2826 while (peek_atom () != ATOM_RPAREN
)
2829 mio_internal_string (name
);
2831 p
= gfc_get_common (name
, 1);
2833 mio_symbol_ref (&p
->head
);
2834 mio_integer (&p
->saved
);
2844 /* Recursive function to traverse the pointer_info tree and load a
2845 needed symbol. We return nonzero if we load a symbol and stop the
2846 traversal, because the act of loading can alter the tree. */
2849 load_needed (pointer_info
* p
)
2857 if (load_needed (p
->left
))
2859 if (load_needed (p
->right
))
2862 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
2865 p
->u
.rsym
.state
= USED
;
2867 set_module_locus (&p
->u
.rsym
.where
);
2869 sym
= p
->u
.rsym
.sym
;
2872 q
= get_integer (p
->u
.rsym
.ns
);
2874 ns
= (gfc_namespace
*) q
->u
.pointer
;
2877 /* Create an interface namespace if necessary. These are
2878 the namespaces that hold the formal parameters of module
2881 ns
= gfc_get_namespace (NULL
);
2882 associate_integer_pointer (q
, ns
);
2885 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
2886 strcpy (sym
->module
, p
->u
.rsym
.module
);
2888 associate_integer_pointer (p
, sym
);
2892 sym
->attr
.use_assoc
= 1;
2898 /* Recursive function for cleaning up things after a module has been
2902 read_cleanup (pointer_info
* p
)
2910 read_cleanup (p
->left
);
2911 read_cleanup (p
->right
);
2913 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
2915 /* Add hidden symbols to the symtree. */
2916 q
= get_integer (p
->u
.rsym
.ns
);
2917 st
= get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
2919 st
->n
.sym
= p
->u
.rsym
.sym
;
2922 /* Fixup any symtree references. */
2923 p
->u
.rsym
.symtree
= st
;
2924 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
2925 p
->u
.rsym
.stfixup
= NULL
;
2928 /* Free unused symbols. */
2929 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
2930 gfc_free_symbol (p
->u
.rsym
.sym
);
2934 /* Read a module file. */
2939 module_locus operator_interfaces
, user_operators
;
2941 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2943 int ambiguous
, symbol
;
2949 get_module_locus (&operator_interfaces
); /* Skip these for now */
2952 get_module_locus (&user_operators
);
2959 /* Create the fixup nodes for all the symbols. */
2961 while (peek_atom () != ATOM_RPAREN
)
2963 require_atom (ATOM_INTEGER
);
2964 info
= get_integer (atom_int
);
2966 info
->type
= P_SYMBOL
;
2967 info
->u
.rsym
.state
= UNUSED
;
2969 mio_internal_string (info
->u
.rsym
.true_name
);
2970 mio_internal_string (info
->u
.rsym
.module
);
2972 require_atom (ATOM_INTEGER
);
2973 info
->u
.rsym
.ns
= atom_int
;
2975 get_module_locus (&info
->u
.rsym
.where
);
2978 /* See if the symbol has already been loaded by a previous module.
2979 If so, we reference the existing symbol and prevent it from
2980 being loaded again. */
2982 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
2986 info
->u
.rsym
.state
= USED
;
2987 info
->u
.rsym
.referenced
= 1;
2988 info
->u
.rsym
.sym
= sym
;
2993 /* Parse the symtree lists. This lets us mark which symbols need to
2994 be loaded. Renaming is also done at this point by replacing the
2999 while (peek_atom () != ATOM_RPAREN
)
3001 mio_internal_string (name
);
3002 mio_integer (&ambiguous
);
3003 mio_integer (&symbol
);
3005 info
= get_integer (symbol
);
3007 /* Get the local name for this symbol. */
3008 p
= find_use_name (name
);
3010 /* Skip symtree nodes not in an ONLY caluse. */
3014 /* Check for ambiguous symbols. */
3015 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3019 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
3021 info
->u
.rsym
.symtree
= st
;
3025 /* Create a symtree node in the current namespace for this symbol. */
3026 st
= check_unique_name (p
) ? get_unique_symtree (gfc_current_ns
) :
3027 gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3029 st
->ambiguous
= ambiguous
;
3031 sym
= info
->u
.rsym
.sym
;
3033 /* Create a symbol node if it doesn't already exist. */
3036 sym
= info
->u
.rsym
.sym
=
3037 gfc_new_symbol (info
->u
.rsym
.true_name
, gfc_current_ns
);
3039 strcpy (sym
->module
, info
->u
.rsym
.module
);
3045 /* Store the symtree pointing to this symbol. */
3046 info
->u
.rsym
.symtree
= st
;
3048 if (info
->u
.rsym
.state
== UNUSED
)
3049 info
->u
.rsym
.state
= NEEDED
;
3050 info
->u
.rsym
.referenced
= 1;
3056 /* Load intrinsic operator interfaces. */
3057 set_module_locus (&operator_interfaces
);
3060 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3062 if (i
== INTRINSIC_USER
)
3067 u
= find_use_operator (i
);
3078 mio_interface (&gfc_current_ns
->operator[i
]);
3083 /* Load generic and user operator interfaces. These must follow the
3084 loading of symtree because otherwise symbols can be marked as
3087 set_module_locus (&user_operators
);
3089 load_operator_interfaces ();
3090 load_generic_interfaces ();
3094 /* At this point, we read those symbols that are needed but haven't
3095 been loaded yet. If one symbol requires another, the other gets
3096 marked as NEEDED if its previous state was UNUSED. */
3098 while (load_needed (pi_root
));
3100 /* Make sure all elements of the rename-list were found in the
3103 for (u
= gfc_rename_list
; u
; u
= u
->next
)
3108 if (u
->operator == INTRINSIC_NONE
)
3110 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3111 u
->use_name
, &u
->where
, module_name
);
3115 if (u
->operator == INTRINSIC_USER
)
3118 ("User operator '%s' referenced at %L not found in module '%s'",
3119 u
->use_name
, &u
->where
, module_name
);
3124 ("Intrinsic operator '%s' referenced at %L not found in module "
3125 "'%s'", gfc_op2string (u
->operator), &u
->where
, module_name
);
3128 gfc_check_interfaces (gfc_current_ns
);
3130 /* Clean up symbol nodes that were never loaded, create references
3131 to hidden symbols. */
3133 read_cleanup (pi_root
);
3137 /* Given an access type that is specific to an entity and the default
3138 access, return nonzero if we should write the entity. */
3141 check_access (gfc_access specific_access
, gfc_access default_access
)
3144 if (specific_access
== ACCESS_PUBLIC
)
3146 if (specific_access
== ACCESS_PRIVATE
)
3149 if (gfc_option
.flag_module_access_private
)
3151 if (default_access
== ACCESS_PUBLIC
)
3156 if (default_access
!= ACCESS_PRIVATE
)
3164 /* Write a common block to the module */
3167 write_common (gfc_symtree
*st
)
3174 write_common(st
->left
);
3175 write_common(st
->right
);
3178 mio_internal_string(st
->name
);
3181 mio_symbol_ref(&p
->head
);
3182 mio_integer(&p
->saved
);
3188 /* Write a symbol to the module. */
3191 write_symbol (int n
, gfc_symbol
* sym
)
3194 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
3195 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
3198 mio_internal_string (sym
->name
);
3200 if (sym
->module
[0] == '\0')
3201 strcpy (sym
->module
, module_name
);
3203 mio_internal_string (sym
->module
);
3204 mio_pointer_ref (&sym
->ns
);
3211 /* Recursive traversal function to write the initial set of symbols to
3212 the module. We check to see if the symbol should be written
3213 according to the access specification. */
3216 write_symbol0 (gfc_symtree
* st
)
3224 write_symbol0 (st
->left
);
3225 write_symbol0 (st
->right
);
3229 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3230 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
3233 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3236 p
= get_pointer (sym
);
3237 if (p
->type
== P_UNKNOWN
)
3240 if (p
->u
.wsym
.state
== WRITTEN
)
3243 write_symbol (p
->integer
, sym
);
3244 p
->u
.wsym
.state
= WRITTEN
;
3250 /* Recursive traversal function to write the secondary set of symbols
3251 to the module file. These are symbols that were not public yet are
3252 needed by the public symbols or another dependent symbol. The act
3253 of writing a symbol can modify the pointer_info tree, so we cease
3254 traversal if we find a symbol to write. We return nonzero if a
3255 symbol was written and pass that information upwards. */
3258 write_symbol1 (pointer_info
* p
)
3264 if (write_symbol1 (p
->left
))
3266 if (write_symbol1 (p
->right
))
3269 if (p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
)
3272 p
->u
.wsym
.state
= WRITTEN
;
3273 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
3279 /* Write operator interfaces associated with a symbol. */
3282 write_operator (gfc_user_op
* uop
)
3284 static char nullstring
[] = "";
3286 if (uop
->operator == NULL
3287 || !check_access (uop
->access
, uop
->ns
->default_access
))
3290 mio_symbol_interface (uop
->name
, nullstring
, &uop
->operator);
3294 /* Write generic interfaces associated with a symbol. */
3297 write_generic (gfc_symbol
* sym
)
3300 if (sym
->generic
== NULL
3301 || !check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3304 mio_symbol_interface (sym
->name
, sym
->module
, &sym
->generic
);
3309 write_symtree (gfc_symtree
* st
)
3315 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
)
3316 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3317 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
3320 if (check_unique_name (st
->name
))
3323 p
= find_pointer (sym
);
3325 gfc_internal_error ("write_symtree(): Symbol not written");
3327 mio_internal_string (st
->name
);
3328 mio_integer (&st
->ambiguous
);
3329 mio_integer (&p
->integer
);
3338 /* Write the operator interfaces. */
3341 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3343 if (i
== INTRINSIC_USER
)
3346 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
3347 gfc_current_ns
->default_access
)
3348 ? &gfc_current_ns
->operator[i
] : NULL
);
3356 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
3362 gfc_traverse_ns (gfc_current_ns
, write_generic
);
3368 write_common (gfc_current_ns
->common_root
);
3373 /* Write symbol information. First we traverse all symbols in the
3374 primary namespace, writing those that need to be written.
3375 Sometimes writing one symbol will cause another to need to be
3376 written. A list of these symbols ends up on the write stack, and
3377 we end by popping the bottom of the stack and writing the symbol
3378 until the stack is empty. */
3382 write_symbol0 (gfc_current_ns
->sym_root
);
3383 while (write_symbol1 (pi_root
));
3391 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
3396 /* Given module, dump it to disk. If there was an error while
3397 processing the module, dump_flag will be set to zero and we delete
3398 the module file, even if it was already there. */
3401 gfc_dump_module (const char *name
, int dump_flag
)
3403 char filename
[PATH_MAX
], *p
;
3407 if (gfc_option
.module_dir
!= NULL
)
3408 strcpy (filename
, gfc_option
.module_dir
);
3410 strcat (filename
, name
);
3411 strcat (filename
, MODULE_EXTENSION
);
3419 module_fp
= fopen (filename
, "w");
3420 if (module_fp
== NULL
)
3421 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3422 filename
, strerror (errno
));
3427 *strchr (p
, '\n') = '\0';
3429 fprintf (module_fp
, "GFORTRAN module created from %s on %s\n",
3430 gfc_source_file
, p
);
3431 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp
);
3434 strcpy (module_name
, name
);
3440 free_pi_tree (pi_root
);
3445 if (fclose (module_fp
))
3446 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3447 filename
, strerror (errno
));
3451 /* Process a USE directive. */
3454 gfc_use_module (void)
3456 char filename
[GFC_MAX_SYMBOL_LEN
+ 5];
3460 strcpy (filename
, module_name
);
3461 strcat (filename
, MODULE_EXTENSION
);
3463 module_fp
= gfc_open_included_file (filename
);
3464 if (module_fp
== NULL
)
3465 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
3466 filename
, strerror (errno
));
3472 /* Skip the first two lines of the module. */
3473 /* FIXME: Could also check for valid two lines here, instead. */
3479 bad_module ("Unexpected end of module");
3484 /* Make sure we're not reading the same module that we may be building. */
3485 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3486 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
3487 gfc_fatal_error ("Can't USE the same module we're building!");
3490 init_true_name_tree ();
3494 free_true_name (true_name_root
);
3495 true_name_root
= NULL
;
3497 free_pi_tree (pi_root
);
3505 gfc_module_init_2 (void)
3508 last_atom
= ATOM_LPAREN
;
3513 gfc_module_done_2 (void)