]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/module.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[multiple changes]
[gcc.git] / gcc / fortran / module.c
CommitLineData
6de9cd9a
DN		 1/* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
edf1eac2
SK		 3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
4 Free Software Foundation, Inc.
6de9cd9a
DN		 5 Contributed by Andy Vaught
6
9fc4d79b 7This file is part of GCC.
6de9cd9a 8
9fc4d79b
TS		 9GCC is free software; you can redistribute it and/or modify it under
10the terms of the GNU General Public License as published by the Free
11Software Foundation; either version 2, or (at your option) any later
12version.
6de9cd9a 13
9fc4d79b
TS		 14GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15WARRANTY; without even the implied warranty of MERCHANTABILITY or
16FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17for more details.
6de9cd9a
DN		 18
19You should have received a copy of the GNU General Public License
9fc4d79b 20along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 21Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2202110-1301, USA. */
6de9cd9a 23
75101feb 24/* The syntax of gfortran modules resembles that of lisp lists, ie a
6de9cd9a
DN		 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.
31
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:
36
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
39 ...
40 )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ...
43 )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ...
46 )
9056bd70
TS		 47 ( ( <common name> <symbol> <saved flag>)
48 ...
49 )
30aabb86
PT		 50
51 ( equivalence list )
52
6de9cd9a
DN		 53 ( <Symbol Number (in no particular order)>
54 <True name of symbol>
55 <Module name of symbol>
56 ( <symbol information> )
57 ...
58 )
59 ( <Symtree name>
60 <Ambiguous flag>
61 <Symbol number>
62 ...
63 )
64
65 In general, symbols refer to other symbols by their symbol number,
66 which are zero based. Symbols are written to the module in no
67 particular order. */
68
69#include "config.h"
d22e4895 70#include "system.h"
6de9cd9a 71#include "gfortran.h"
f8e566e5 72#include "arith.h"
6de9cd9a
DN		 73#include "match.h"
74#include "parse.h" /* FIXME */
1e9ecf6d 75#include "md5.h"
6de9cd9a
DN		 76
77#define MODULE_EXTENSION ".mod"
78
79
711f8369 80/* Structure that describes a position within a module file. */
6de9cd9a
DN		 81
82typedef struct
83{
84 int column, line;
85 fpos_t pos;
86}
87module_locus;
88
a8b3b0b6
CR		 89/* Structure for list of symbols of intrinsic modules. */
90typedef struct
91{
92 int id;
93 const char *name;
94 int value;
95}
96intmod_sym;
97
6de9cd9a
DN		 98
99typedef enum
100{
101 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
102}
103pointer_t;
104
105/* The fixup structure lists pointers to pointers that have to
106 be updated when a pointer value becomes known. */
107
108typedef struct fixup_t
109{
110 void **pointer;
111 struct fixup_t *next;
112}
113fixup_t;
114
115
711f8369 116/* Structure for holding extra info needed for pointers being read. */
6de9cd9a
DN		 117
118typedef struct pointer_info
119{
120 BBT_HEADER (pointer_info);
121 int integer;
122 pointer_t type;
123
124 /* The first component of each member of the union is the pointer
711f8369 125 being stored. */
6de9cd9a
DN		 126
127 fixup_t *fixup;
128
129 union
130 {
711f8369 131 void *pointer; /* Member for doing pointer searches. */
6de9cd9a
DN		 132
133 struct
134 {
135 gfc_symbol *sym;
136 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
137 enum
138 { UNUSED, NEEDED, USED }
139 state;
140 int ns, referenced;
141 module_locus where;
142 fixup_t *stfixup;
143 gfc_symtree *symtree;
a8b3b0b6 144 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
6de9cd9a
DN		 145 }
146 rsym;
147
148 struct
149 {
150 gfc_symbol *sym;
151 enum
152 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
153 state;
154 }
155 wsym;
156 }
157 u;
158
159}
160pointer_info;
161
162#define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
163
164
711f8369 165/* Lists of rename info for the USE statement. */
6de9cd9a
DN		 166
167typedef struct gfc_use_rename
168{
169 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
170 struct gfc_use_rename *next;
171 int found;
172 gfc_intrinsic_op operator;
173 locus where;
174}
175gfc_use_rename;
176
177#define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
178
179/* Local variables */
180
181/* The FILE for the module we're reading or writing. */
182static FILE *module_fp;
183
1e9ecf6d
FXC		 184/* MD5 context structure. */
185static struct md5_ctx ctx;
186
6de9cd9a
DN		 187/* The name of the module we're reading (USE'ing) or writing. */
188static char module_name[GFC_MAX_SYMBOL_LEN + 1];
189
31198773
FXC		 190/* The way the module we're reading was specified. */
191static bool specified_nonint, specified_int;
192
6de9cd9a
DN		 193static int module_line, module_column, only_flag;
194static enum
195{ IO_INPUT, IO_OUTPUT }
196iomode;
197
198static gfc_use_rename *gfc_rename_list;
199static pointer_info *pi_root;
200static int symbol_number; /* Counter for assigning symbol numbers */
201
fdecbf80 202/* Tells mio_expr_ref to make symbols for unused equivalence members. */
613e2ac8
PT		 203static bool in_load_equiv;
204
6de9cd9a
DN		 205
206
207/*****************************************************************/
208
209/* Pointer/integer conversion. Pointers between structures are stored
210 as integers in the module file. The next couple of subroutines
211 handle this translation for reading and writing. */
212
213/* Recursively free the tree of pointer structures. */
214
215static void
edf1eac2 216free_pi_tree (pointer_info *p)
6de9cd9a 217{
6de9cd9a
DN		 218 if (p == NULL)
219 return;
220
221 if (p->fixup != NULL)
222 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
223
224 free_pi_tree (p->left);
225 free_pi_tree (p->right);
226
227 gfc_free (p);
228}
229
230
231/* Compare pointers when searching by pointer. Used when writing a
232 module. */
233
234static int
edf1eac2 235compare_pointers (void *_sn1, void *_sn2)
6de9cd9a
DN		 236{
237 pointer_info *sn1, *sn2;
238
239 sn1 = (pointer_info *) _sn1;
240 sn2 = (pointer_info *) _sn2;
241
242 if (sn1->u.pointer < sn2->u.pointer)
243 return -1;
244 if (sn1->u.pointer > sn2->u.pointer)
245 return 1;
246
247 return 0;
248}
249
250
251/* Compare integers when searching by integer. Used when reading a
252 module. */
253
254static int
edf1eac2 255compare_integers (void *_sn1, void *_sn2)
6de9cd9a
DN		 256{
257 pointer_info *sn1, *sn2;
258
259 sn1 = (pointer_info *) _sn1;
260 sn2 = (pointer_info *) _sn2;
261
262 if (sn1->integer < sn2->integer)
263 return -1;
264 if (sn1->integer > sn2->integer)
265 return 1;
266
267 return 0;
268}
269
270
271/* Initialize the pointer_info tree. */
272
273static void
274init_pi_tree (void)
275{
276 compare_fn compare;
277 pointer_info *p;
278
279 pi_root = NULL;
280 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
281
282 /* Pointer 0 is the NULL pointer. */
283 p = gfc_get_pointer_info ();
284 p->u.pointer = NULL;
285 p->integer = 0;
286 p->type = P_OTHER;
287
288 gfc_insert_bbt (&pi_root, p, compare);
289
290 /* Pointer 1 is the current namespace. */
291 p = gfc_get_pointer_info ();
292 p->u.pointer = gfc_current_ns;
293 p->integer = 1;
294 p->type = P_NAMESPACE;
295
296 gfc_insert_bbt (&pi_root, p, compare);
297
298 symbol_number = 2;
299}
300
301
302/* During module writing, call here with a pointer to something,
303 returning the pointer_info node. */
304
305static pointer_info *
306find_pointer (void *gp)
307{
308 pointer_info *p;
309
310 p = pi_root;
311 while (p != NULL)
312 {
313 if (p->u.pointer == gp)
314 break;
315 p = (gp < p->u.pointer) ? p->left : p->right;
316 }
317
318 return p;
319}
320
321
322/* Given a pointer while writing, returns the pointer_info tree node,
323 creating it if it doesn't exist. */
324
325static pointer_info *
326get_pointer (void *gp)
327{
328 pointer_info *p;
329
330 p = find_pointer (gp);
331 if (p != NULL)
332 return p;
333
334 /* Pointer doesn't have an integer. Give it one. */
335 p = gfc_get_pointer_info ();
336
337 p->u.pointer = gp;
338 p->integer = symbol_number++;
339
340 gfc_insert_bbt (&pi_root, p, compare_pointers);
341
342 return p;
343}
344
345
346/* Given an integer during reading, find it in the pointer_info tree,
347 creating the node if not found. */
348
349static pointer_info *
350get_integer (int integer)
351{
352 pointer_info *p, t;
353 int c;
354
355 t.integer = integer;
356
357 p = pi_root;
358 while (p != NULL)
359 {
360 c = compare_integers (&t, p);
361 if (c == 0)
362 break;
363
364 p = (c < 0) ? p->left : p->right;
365 }
366
367 if (p != NULL)
368 return p;
369
370 p = gfc_get_pointer_info ();
371 p->integer = integer;
372 p->u.pointer = NULL;
373
374 gfc_insert_bbt (&pi_root, p, compare_integers);
375
376 return p;
377}
378
379
380/* Recursive function to find a pointer within a tree by brute force. */
381
382static pointer_info *
edf1eac2 383fp2 (pointer_info *p, const void *target)
6de9cd9a
DN		 384{
385 pointer_info *q;
386
387 if (p == NULL)
388 return NULL;
389
390 if (p->u.pointer == target)
391 return p;
392
393 q = fp2 (p->left, target);
394 if (q != NULL)
395 return q;
396
397 return fp2 (p->right, target);
398}
399
400
401/* During reading, find a pointer_info node from the pointer value.
402 This amounts to a brute-force search. */
403
404static pointer_info *
405find_pointer2 (void *p)
406{
6de9cd9a
DN		 407 return fp2 (pi_root, p);
408}
409
410
411/* Resolve any fixups using a known pointer. */
66e4ab31 412
6de9cd9a 413static void
edf1eac2 414resolve_fixups (fixup_t *f, void *gp)
6de9cd9a
DN		 415{
416 fixup_t *next;
417
418 for (; f; f = next)
419 {
420 next = f->next;
421 *(f->pointer) = gp;
422 gfc_free (f);
423 }
424}
425
edf1eac2 426
6de9cd9a
DN		 427/* Call here during module reading when we know what pointer to
428 associate with an integer. Any fixups that exist are resolved at
429 this time. */
430
431static void
edf1eac2 432associate_integer_pointer (pointer_info *p, void *gp)
6de9cd9a
DN		 433{
434 if (p->u.pointer != NULL)
435 gfc_internal_error ("associate_integer_pointer(): Already associated");
436
437 p->u.pointer = gp;
438
439 resolve_fixups (p->fixup, gp);
440
441 p->fixup = NULL;
442}
443
444
445/* During module reading, given an integer and a pointer to a pointer,
446 either store the pointer from an already-known value or create a
447 fixup structure in order to store things later. Returns zero if
448 the reference has been actually stored, or nonzero if the reference
449 must be fixed later (ie associate_integer_pointer must be called
450 sometime later. Returns the pointer_info structure. */
451
452static pointer_info *
453add_fixup (int integer, void *gp)
454{
455 pointer_info *p;
456 fixup_t *f;
457 char **cp;
458
459 p = get_integer (integer);
460
461 if (p->integer == 0 || p->u.pointer != NULL)
462 {
463 cp = gp;
464 *cp = p->u.pointer;
465 }
466 else
467 {
468 f = gfc_getmem (sizeof (fixup_t));
469
470 f->next = p->fixup;
471 p->fixup = f;
472
473 f->pointer = gp;
474 }
475
476 return p;
477}
478
479
480/*****************************************************************/
481
482/* Parser related subroutines */
483
484/* Free the rename list left behind by a USE statement. */
485
486static void
487free_rename (void)
488{
489 gfc_use_rename *next;
490
491 for (; gfc_rename_list; gfc_rename_list = next)
492 {
493 next = gfc_rename_list->next;
494 gfc_free (gfc_rename_list);
495 }
496}
497
498
499/* Match a USE statement. */
500
501match
502gfc_match_use (void)
503{
31198773 504 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
6de9cd9a 505 gfc_use_rename *tail = NULL, *new;
56bedf42 506 interface_type type, type2;
6de9cd9a
DN		 507 gfc_intrinsic_op operator;
508 match m;
509
31198773
FXC		 510 specified_int = false;
511 specified_nonint = false;
512
513 if (gfc_match (" , ") == MATCH_YES)
514 {
515 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
39f87c03
FXC		 516 {
517 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
518 "nature in USE statement at %C") == FAILURE)
519 return MATCH_ERROR;
520
521 if (strcmp (module_nature, "intrinsic") == 0)
522 specified_int = true;
523 else
524 {
525 if (strcmp (module_nature, "non_intrinsic") == 0)
526 specified_nonint = true;
527 else
528 {
529 gfc_error ("Module nature in USE statement at %C shall "
530 "be either INTRINSIC or NON_INTRINSIC");
531 return MATCH_ERROR;
532 }
533 }
31198773
FXC		 534 }
535 else
536 {
537 /* Help output a better error message than "Unclassifiable
538 statement". */
539 gfc_match (" %n", module_nature);
540 if (strcmp (module_nature, "intrinsic") == 0
541 || strcmp (module_nature, "non_intrinsic") == 0)
542 gfc_error ("\"::\" was expected after module nature at %C "
543 "but was not found");
544 return m;
545 }
546 }
547 else
548 {
549 m = gfc_match (" ::");
550 if (m == MATCH_YES &&
551 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
552 "\"USE :: module\" at %C") == FAILURE)
553 return MATCH_ERROR;
554
555 if (m != MATCH_YES)
39f87c03
FXC		 556 {
557 m = gfc_match ("% ");
558 if (m != MATCH_YES)
559 return m;
560 }
31198773
FXC		 561 }
562
6de9cd9a
DN		 563 m = gfc_match_name (module_name);
564 if (m != MATCH_YES)
565 return m;
566
567 free_rename ();
568 only_flag = 0;
569
570 if (gfc_match_eos () == MATCH_YES)
571 return MATCH_YES;
572 if (gfc_match_char (',') != MATCH_YES)
573 goto syntax;
574
575 if (gfc_match (" only :") == MATCH_YES)
576 only_flag = 1;
577
578 if (gfc_match_eos () == MATCH_YES)
579 return MATCH_YES;
580
581 for (;;)
582 {
583 /* Get a new rename struct and add it to the rename list. */
584 new = gfc_get_use_rename ();
63645982 585 new->where = gfc_current_locus;
6de9cd9a
DN		 586 new->found = 0;
587
588 if (gfc_rename_list == NULL)
589 gfc_rename_list = new;
590 else
591 tail->next = new;
592 tail = new;
593
f8e566e5 594 /* See what kind of interface we're dealing with. Assume it is
edf1eac2 595 not an operator. */
6de9cd9a
DN		 596 new->operator = INTRINSIC_NONE;
597 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
598 goto cleanup;
599
600 switch (type)
601 {
602 case INTERFACE_NAMELESS:
603 gfc_error ("Missing generic specification in USE statement at %C");
604 goto cleanup;
605
56bedf42 606 case INTERFACE_USER_OP:
6de9cd9a
DN		 607 case INTERFACE_GENERIC:
608 m = gfc_match (" =>");
609
56bedf42
TB		 610 if (type == INTERFACE_USER_OP && m == MATCH_YES
611 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
612 "operators in USE statements at %C")
66e4ab31 613 == FAILURE))
56bedf42
TB		 614 goto cleanup;
615
6de9cd9a
DN		 616 if (only_flag)
617 {
618 if (m != MATCH_YES)
619 strcpy (new->use_name, name);
620 else
621 {
622 strcpy (new->local_name, name);
56bedf42
TB		 623 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
624 if (type != type2)
625 goto syntax;
6de9cd9a
DN		 626 if (m == MATCH_NO)
627 goto syntax;
628 if (m == MATCH_ERROR)
629 goto cleanup;
630 }
631 }
632 else
633 {
634 if (m != MATCH_YES)
635 goto syntax;
636 strcpy (new->local_name, name);
637
56bedf42
TB		 638 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
639 if (type != type2)
640 goto syntax;
6de9cd9a
DN		 641 if (m == MATCH_NO)
642 goto syntax;
643 if (m == MATCH_ERROR)
644 goto cleanup;
645 }
646
ac497e6a
TB		 647 if (strcmp (new->use_name, module_name) == 0
648 || strcmp (new->local_name, module_name) == 0)
649 {
650 gfc_error ("The name '%s' at %C has already been used as "
651 "an external module name.", module_name);
652 goto cleanup;
653 }
654
56bedf42
TB		 655 if (type == INTERFACE_USER_OP)
656 new->operator = operator;
6de9cd9a 657
56bedf42 658 break;
6de9cd9a
DN		 659
660 case INTERFACE_INTRINSIC_OP:
661 new->operator = operator;
662 break;
663 }
664
665 if (gfc_match_eos () == MATCH_YES)
666 break;
667 if (gfc_match_char (',') != MATCH_YES)
668 goto syntax;
669 }
670
671 return MATCH_YES;
672
673syntax:
674 gfc_syntax_error (ST_USE);
675
676cleanup:
677 free_rename ();
678 return MATCH_ERROR;
30aabb86 679 }
6de9cd9a
DN		 680
681
30aabb86
PT		 682/* Given a name and a number, inst, return the inst name
683 under which to load this symbol. Returns NULL if this
684 symbol shouldn't be loaded. If inst is zero, returns
685 the number of instances of this name. */
6de9cd9a
DN		 686
687static const char *
30aabb86 688find_use_name_n (const char *name, int *inst)
6de9cd9a
DN		 689{
690 gfc_use_rename *u;
30aabb86 691 int i;
6de9cd9a 692
30aabb86 693 i = 0;
6de9cd9a 694 for (u = gfc_rename_list; u; u = u->next)
30aabb86
PT		 695 {
696 if (strcmp (u->use_name, name) != 0)
697 continue;
698 if (++i == *inst)
699 break;
700 }
701
702 if (!*inst)
703 {
704 *inst = i;
705 return NULL;
706 }
6de9cd9a
DN		 707
708 if (u == NULL)
709 return only_flag ? NULL : name;
710
711 u->found = 1;
712
713 return (u->local_name[0] != '\0') ? u->local_name : name;
714}
715
edf1eac2 716
30aabb86
PT		 717/* Given a name, return the name under which to load this symbol.
718 Returns NULL if this symbol shouldn't be loaded. */
719
720static const char *
721find_use_name (const char *name)
722{
723 int i = 1;
724 return find_use_name_n (name, &i);
725}
726
edf1eac2
SK		 727
728/* Given a real name, return the number of use names associated with it. */
30aabb86
PT		 729
730static int
731number_use_names (const char *name)
732{
733 int i = 0;
734 const char *c;
735 c = find_use_name_n (name, &i);
736 return i;
737}
738
6de9cd9a
DN		 739
740/* Try to find the operator in the current list. */
741
742static gfc_use_rename *
743find_use_operator (gfc_intrinsic_op operator)
744{
745 gfc_use_rename *u;
746
747 for (u = gfc_rename_list; u; u = u->next)
748 if (u->operator == operator)
749 return u;
750
751 return NULL;
752}
753
754
755/*****************************************************************/
756
757/* The next couple of subroutines maintain a tree used to avoid a
758 brute-force search for a combination of true name and module name.
759 While symtree names, the name that a particular symbol is known by
760 can changed with USE statements, we still have to keep track of the
761 true names to generate the correct reference, and also avoid
762 loading the same real symbol twice in a program unit.
763
764 When we start reading, the true name tree is built and maintained
765 as symbols are read. The tree is searched as we load new symbols
766 to see if it already exists someplace in the namespace. */
767
768typedef struct true_name
769{
770 BBT_HEADER (true_name);
771 gfc_symbol *sym;
772}
773true_name;
774
775static true_name *true_name_root;
776
777
778/* Compare two true_name structures. */
779
780static int
edf1eac2 781compare_true_names (void *_t1, void *_t2)
6de9cd9a
DN		 782{
783 true_name *t1, *t2;
784 int c;
785
786 t1 = (true_name *) _t1;
787 t2 = (true_name *) _t2;
788
cb9e4f55
TS		 789 c = ((t1->sym->module > t2->sym->module)
790 - (t1->sym->module < t2->sym->module));
6de9cd9a
DN		 791 if (c != 0)
792 return c;
793
794 return strcmp (t1->sym->name, t2->sym->name);
795}
796
797
798/* Given a true name, search the true name tree to see if it exists
799 within the main namespace. */
800
801static gfc_symbol *
802find_true_name (const char *name, const char *module)
803{
804 true_name t, *p;
805 gfc_symbol sym;
806 int c;
807
cb9e4f55
TS		 808 sym.name = gfc_get_string (name);
809 if (module != NULL)
810 sym.module = gfc_get_string (module);
811 else
812 sym.module = NULL;
6de9cd9a
DN		 813 t.sym = &sym;
814
815 p = true_name_root;
816 while (p != NULL)
817 {
edf1eac2 818 c = compare_true_names ((void *) (&t), (void *) p);
6de9cd9a
DN		 819 if (c == 0)
820 return p->sym;
821
822 p = (c < 0) ? p->left : p->right;
823 }
824
825 return NULL;
826}
827
828
edf1eac2 829/* Given a gfc_symbol pointer that is not in the true name tree, add it. */
6de9cd9a
DN		 830
831static void
edf1eac2 832add_true_name (gfc_symbol *sym)
6de9cd9a
DN		 833{
834 true_name *t;
835
836 t = gfc_getmem (sizeof (true_name));
837 t->sym = sym;
838
839 gfc_insert_bbt (&true_name_root, t, compare_true_names);
840}
841
842
843/* Recursive function to build the initial true name tree by
844 recursively traversing the current namespace. */
845
846static void
edf1eac2 847build_tnt (gfc_symtree *st)
6de9cd9a 848{
6de9cd9a
DN		 849 if (st == NULL)
850 return;
851
852 build_tnt (st->left);
853 build_tnt (st->right);
854
855 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
856 return;
857
858 add_true_name (st->n.sym);
859}
860
861
862/* Initialize the true name tree with the current namespace. */
863
864static void
865init_true_name_tree (void)
866{
867 true_name_root = NULL;
6de9cd9a
DN		 868 build_tnt (gfc_current_ns->sym_root);
869}
870
871
872/* Recursively free a true name tree node. */
873
874static void
edf1eac2 875free_true_name (true_name *t)
6de9cd9a 876{
6de9cd9a
DN		 877 if (t == NULL)
878 return;
879 free_true_name (t->left);
880 free_true_name (t->right);
881
882 gfc_free (t);
883}
884
885
886/*****************************************************************/
887
888/* Module reading and writing. */
889
890typedef enum
891{
892 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
893}
894atom_type;
895
896static atom_type last_atom;
897
898
899/* The name buffer must be at least as long as a symbol name. Right
900 now it's not clear how we're going to store numeric constants--
901 probably as a hexadecimal string, since this will allow the exact
902 number to be preserved (this can't be done by a decimal
903 representation). Worry about that later. TODO! */
904
905#define MAX_ATOM_SIZE 100
906
907static int atom_int;
908static char *atom_string, atom_name[MAX_ATOM_SIZE];
909
910
911/* Report problems with a module. Error reporting is not very
912 elaborate, since this sorts of errors shouldn't really happen.
913 This subroutine never returns. */
914
915static void bad_module (const char *) ATTRIBUTE_NORETURN;
916
917static void
31043f6c 918bad_module (const char *msgid)
6de9cd9a 919{
31043f6c 920 fclose (module_fp);
6de9cd9a
DN		 921
922 switch (iomode)
923 {
924 case IO_INPUT:
31043f6c
FXC		 925 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
926 module_name, module_line, module_column, msgid);
6de9cd9a
DN		 927 break;
928 case IO_OUTPUT:
31043f6c
FXC		 929 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
930 module_name, module_line, module_column, msgid);
6de9cd9a
DN		 931 break;
932 default:
31043f6c
FXC		 933 gfc_fatal_error ("Module %s at line %d column %d: %s",
934 module_name, module_line, module_column, msgid);
6de9cd9a
DN		 935 break;
936 }
6de9cd9a
DN		 937}
938
939
940/* Set the module's input pointer. */
941
942static void
edf1eac2 943set_module_locus (module_locus *m)
6de9cd9a 944{
6de9cd9a
DN		 945 module_column = m->column;
946 module_line = m->line;
947 fsetpos (module_fp, &m->pos);
948}
949
950
951/* Get the module's input pointer so that we can restore it later. */
952
953static void
edf1eac2 954get_module_locus (module_locus *m)
6de9cd9a 955{
6de9cd9a
DN		 956 m->column = module_column;
957 m->line = module_line;
958 fgetpos (module_fp, &m->pos);
959}
960
961
962/* Get the next character in the module, updating our reckoning of
963 where we are. */
964
965static int
966module_char (void)
967{
968 int c;
969
c4da1827 970 c = getc (module_fp);
6de9cd9a
DN		 971
972 if (c == EOF)
973 bad_module ("Unexpected EOF");
974
975 if (c == '\n')
976 {
977 module_line++;
978 module_column = 0;
979 }
980
981 module_column++;
982 return c;
983}
984
985
986/* Parse a string constant. The delimiter is guaranteed to be a
987 single quote. */
988
989static void
990parse_string (void)
991{
992 module_locus start;
993 int len, c;
994 char *p;
995
996 get_module_locus (&start);
997
998 len = 0;
999
66e4ab31 1000 /* See how long the string is. */
6de9cd9a
DN		 1001 for ( ; ; )
1002 {
1003 c = module_char ();
1004 if (c == EOF)
1005 bad_module ("Unexpected end of module in string constant");
1006
1007 if (c != '\'')
edf1eac2 1008 {
6de9cd9a
DN		 1009 len++;
1010 continue;
1011 }
1012
1013 c = module_char ();
1014 if (c == '\'')
edf1eac2 1015 {
6de9cd9a
DN		 1016 len++;
1017 continue;
1018 }
1019
1020 break;
1021 }
1022
1023 set_module_locus (&start);
1024
1025 atom_string = p = gfc_getmem (len + 1);
1026
1027 for (; len > 0; len--)
1028 {
1029 c = module_char ();
1030 if (c == '\'')
66e4ab31 1031 module_char (); /* Guaranteed to be another \'. */
6de9cd9a
DN		 1032 *p++ = c;
1033 }
1034
66e4ab31 1035 module_char (); /* Terminating \'. */
edf1eac2 1036 *p = '\0'; /* C-style string for debug purposes. */
6de9cd9a
DN		 1037}
1038
1039
1040/* Parse a small integer. */
1041
1042static void
1043parse_integer (int c)
1044{
1045 module_locus m;
1046
1047 atom_int = c - '0';
1048
1049 for (;;)
1050 {
1051 get_module_locus (&m);
1052
1053 c = module_char ();
1054 if (!ISDIGIT (c))
1055 break;
1056
1057 atom_int = 10 * atom_int + c - '0';
1058 if (atom_int > 99999999)
1059 bad_module ("Integer overflow");
1060 }
1061
1062 set_module_locus (&m);
1063}
1064
1065
1066/* Parse a name. */
1067
1068static void
1069parse_name (int c)
1070{
1071 module_locus m;
1072 char *p;
1073 int len;
1074
1075 p = atom_name;
1076
1077 *p++ = c;
1078 len = 1;
1079
1080 get_module_locus (&m);
1081
1082 for (;;)
1083 {
1084 c = module_char ();
1085 if (!ISALNUM (c) && c != '_' && c != '-')
1086 break;
1087
1088 *p++ = c;
1089 if (++len > GFC_MAX_SYMBOL_LEN)
1090 bad_module ("Name too long");
1091 }
1092
1093 *p = '\0';
1094
1095 fseek (module_fp, -1, SEEK_CUR);
1096 module_column = m.column + len - 1;
1097
1098 if (c == '\n')
1099 module_line--;
1100}
1101
1102
1103/* Read the next atom in the module's input stream. */
1104
1105static atom_type
1106parse_atom (void)
1107{
1108 int c;
1109
1110 do
1111 {
1112 c = module_char ();
1113 }
1114 while (c == ' ' || c == '\n');
1115
1116 switch (c)
1117 {
1118 case '(':
1119 return ATOM_LPAREN;
1120
1121 case ')':
1122 return ATOM_RPAREN;
1123
1124 case '\'':
1125 parse_string ();
1126 return ATOM_STRING;
1127
1128 case '0':
1129 case '1':
1130 case '2':
1131 case '3':
1132 case '4':
1133 case '5':
1134 case '6':
1135 case '7':
1136 case '8':
1137 case '9':
1138 parse_integer (c);
1139 return ATOM_INTEGER;
1140
1141 case 'a':
1142 case 'b':
1143 case 'c':
1144 case 'd':
1145 case 'e':
1146 case 'f':
1147 case 'g':
1148 case 'h':
1149 case 'i':
1150 case 'j':
1151 case 'k':
1152 case 'l':
1153 case 'm':
1154 case 'n':
1155 case 'o':
1156 case 'p':
1157 case 'q':
1158 case 'r':
1159 case 's':
1160 case 't':
1161 case 'u':
1162 case 'v':
1163 case 'w':
1164 case 'x':
1165 case 'y':
1166 case 'z':
1167 case 'A':
1168 case 'B':
1169 case 'C':
1170 case 'D':
1171 case 'E':
1172 case 'F':
1173 case 'G':
1174 case 'H':
1175 case 'I':
1176 case 'J':
1177 case 'K':
1178 case 'L':
1179 case 'M':
1180 case 'N':
1181 case 'O':
1182 case 'P':
1183 case 'Q':
1184 case 'R':
1185 case 'S':
1186 case 'T':
1187 case 'U':
1188 case 'V':
1189 case 'W':
1190 case 'X':
1191 case 'Y':
1192 case 'Z':
1193 parse_name (c);
1194 return ATOM_NAME;
1195
1196 default:
1197 bad_module ("Bad name");
1198 }
1199
66e4ab31 1200 /* Not reached. */
6de9cd9a
DN		 1201}
1202
1203
1204/* Peek at the next atom on the input. */
1205
1206static atom_type
1207peek_atom (void)
1208{
1209 module_locus m;
1210 atom_type a;
1211
1212 get_module_locus (&m);
1213
1214 a = parse_atom ();
1215 if (a == ATOM_STRING)
1216 gfc_free (atom_string);
1217
1218 set_module_locus (&m);
1219 return a;
1220}
1221
1222
1223/* Read the next atom from the input, requiring that it be a
1224 particular kind. */
1225
1226static void
1227require_atom (atom_type type)
1228{
1229 module_locus m;
1230 atom_type t;
1231 const char *p;
1232
1233 get_module_locus (&m);
1234
1235 t = parse_atom ();
1236 if (t != type)
1237 {
1238 switch (type)
1239 {
1240 case ATOM_NAME:
31043f6c 1241 p = _("Expected name");
6de9cd9a
DN		 1242 break;
1243 case ATOM_LPAREN:
31043f6c 1244 p = _("Expected left parenthesis");
6de9cd9a
DN		 1245 break;
1246 case ATOM_RPAREN:
31043f6c 1247 p = _("Expected right parenthesis");
6de9cd9a
DN		 1248 break;
1249 case ATOM_INTEGER:
31043f6c 1250 p = _("Expected integer");
6de9cd9a
DN		 1251 break;
1252 case ATOM_STRING:
31043f6c 1253 p = _("Expected string");
6de9cd9a
DN		 1254 break;
1255 default:
1256 gfc_internal_error ("require_atom(): bad atom type required");
1257 }
1258
1259 set_module_locus (&m);
1260 bad_module (p);
1261 }
1262}
1263
1264
1265/* Given a pointer to an mstring array, require that the current input
1266 be one of the strings in the array. We return the enum value. */
1267
1268static int
edf1eac2 1269find_enum (const mstring *m)
6de9cd9a
DN		 1270{
1271 int i;
1272
1273 i = gfc_string2code (m, atom_name);
1274 if (i >= 0)
1275 return i;
1276
1277 bad_module ("find_enum(): Enum not found");
1278
66e4ab31 1279 /* Not reached. */
6de9cd9a
DN		 1280}
1281
1282
1283/**************** Module output subroutines ***************************/
1284
1285/* Output a character to a module file. */
1286
1287static void
1288write_char (char out)
1289{
c4da1827 1290 if (putc (out, module_fp) == EOF)
6de9cd9a
DN		 1291 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1292
1e9ecf6d
FXC		 1293 /* Add this to our MD5. */
1294 md5_process_bytes (&out, sizeof (out), &ctx);
1295
6de9cd9a
DN		 1296 if (out != '\n')
1297 module_column++;
1298 else
1299 {
1300 module_column = 1;
1301 module_line++;
1302 }
1303}
1304
1305
1306/* Write an atom to a module. The line wrapping isn't perfect, but it
1307 should work most of the time. This isn't that big of a deal, since
1308 the file really isn't meant to be read by people anyway. */
1309
1310static void
1311write_atom (atom_type atom, const void *v)
1312{
1313 char buffer[20];
1314 int i, len;
1315 const char *p;
1316
1317 switch (atom)
1318 {
1319 case ATOM_STRING:
1320 case ATOM_NAME:
1321 p = v;
1322 break;
1323
1324 case ATOM_LPAREN:
1325 p = "(";
1326 break;
1327
1328 case ATOM_RPAREN:
1329 p = ")";
1330 break;
1331
1332 case ATOM_INTEGER:
1333 i = *((const int *) v);
1334 if (i < 0)
1335 gfc_internal_error ("write_atom(): Writing negative integer");
1336
1337 sprintf (buffer, "%d", i);
1338 p = buffer;
1339 break;
1340
1341 default:
1342 gfc_internal_error ("write_atom(): Trying to write dab atom");
1343
1344 }
1345
a8b3b0b6
CR		 1346 if(p == NULL || *p == '\0')
1347 len = 0;
1348 else
6de9cd9a
DN		 1349 len = strlen (p);
1350
1351 if (atom != ATOM_RPAREN)
1352 {
1353 if (module_column + len > 72)
1354 write_char ('\n');
1355 else
1356 {
1357
1358 if (last_atom != ATOM_LPAREN && module_column != 1)
1359 write_char (' ');
1360 }
1361 }
1362
1363 if (atom == ATOM_STRING)
1364 write_char ('\'');
1365
a8b3b0b6 1366 while (p != NULL && *p)
6de9cd9a
DN		 1367 {
1368 if (atom == ATOM_STRING && *p == '\'')
1369 write_char ('\'');
1370 write_char (*p++);
1371 }
1372
1373 if (atom == ATOM_STRING)
1374 write_char ('\'');
1375
1376 last_atom = atom;
1377}
1378
1379
1380
1381/***************** Mid-level I/O subroutines *****************/
1382
1383/* These subroutines let their caller read or write atoms without
1384 caring about which of the two is actually happening. This lets a
1385 subroutine concentrate on the actual format of the data being
1386 written. */
1387
1388static void mio_expr (gfc_expr **);
1389static void mio_symbol_ref (gfc_symbol **);
1390static void mio_symtree_ref (gfc_symtree **);
1391
1392/* Read or write an enumerated value. On writing, we return the input
1393 value for the convenience of callers. We avoid using an integer
1394 pointer because enums are sometimes inside bitfields. */
1395
1396static int
edf1eac2 1397mio_name (int t, const mstring *m)
6de9cd9a 1398{
6de9cd9a
DN		 1399 if (iomode == IO_OUTPUT)
1400 write_atom (ATOM_NAME, gfc_code2string (m, t));
1401 else
1402 {
1403 require_atom (ATOM_NAME);
1404 t = find_enum (m);
1405 }
1406
1407 return t;
1408}
1409
69de3b83 1410/* Specialization of mio_name. */
6de9cd9a
DN		 1411
1412#define DECL_MIO_NAME(TYPE) \
1413 static inline TYPE \
edf1eac2 1414 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
6de9cd9a 1415 { \
edf1eac2 1416 return (TYPE) mio_name ((int) t, m); \
6de9cd9a
DN		 1417 }
1418#define MIO_NAME(TYPE) mio_name_##TYPE
1419
1420static void
1421mio_lparen (void)
1422{
6de9cd9a
DN		 1423 if (iomode == IO_OUTPUT)
1424 write_atom (ATOM_LPAREN, NULL);
1425 else
1426 require_atom (ATOM_LPAREN);
1427}
1428
1429
1430static void
1431mio_rparen (void)
1432{
6de9cd9a
DN		 1433 if (iomode == IO_OUTPUT)
1434 write_atom (ATOM_RPAREN, NULL);
1435 else
1436 require_atom (ATOM_RPAREN);
1437}
1438
1439
1440static void
1441mio_integer (int *ip)
1442{
6de9cd9a
DN		 1443 if (iomode == IO_OUTPUT)
1444 write_atom (ATOM_INTEGER, ip);
1445 else
1446 {
1447 require_atom (ATOM_INTEGER);
1448 *ip = atom_int;
1449 }
1450}
1451
1452
66e4ab31 1453/* Read or write a character pointer that points to a string on the heap. */
6de9cd9a 1454
6b25a558
RH		 1455static const char *
1456mio_allocated_string (const char *s)
6de9cd9a 1457{
6de9cd9a 1458 if (iomode == IO_OUTPUT)
6b25a558
RH		 1459 {
1460 write_atom (ATOM_STRING, s);
1461 return s;
1462 }
6de9cd9a
DN		 1463 else
1464 {
1465 require_atom (ATOM_STRING);
6b25a558 1466 return atom_string;
6de9cd9a
DN		 1467 }
1468}
1469
1470
cb9e4f55
TS		 1471/* Read or write a string that is in static memory. */
1472
1473static void
1474mio_pool_string (const char **stringp)
1475{
1476 /* TODO: one could write the string only once, and refer to it via a
1477 fixup pointer. */
1478
1479 /* As a special case we have to deal with a NULL string. This
1480 happens for the 'module' member of 'gfc_symbol's that are not in a
1481 module. We read / write these as the empty string. */
1482 if (iomode == IO_OUTPUT)
1483 {
1484 const char *p = *stringp == NULL ? "" : *stringp;
1485 write_atom (ATOM_STRING, p);
1486 }
1487 else
1488 {
1489 require_atom (ATOM_STRING);
1490 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1491 gfc_free (atom_string);
1492 }
1493}
1494
1495
1496/* Read or write a string that is inside of some already-allocated
1497 structure. */
6de9cd9a
DN		 1498
1499static void
1500mio_internal_string (char *string)
1501{
6de9cd9a
DN		 1502 if (iomode == IO_OUTPUT)
1503 write_atom (ATOM_STRING, string);
1504 else
1505 {
1506 require_atom (ATOM_STRING);
1507 strcpy (string, atom_string);
1508 gfc_free (atom_string);
1509 }
1510}
1511
1512
6de9cd9a
DN		 1513typedef enum
1514{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
06469efd
PT		 1515 AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1516 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1517 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1518 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
a8b3b0b6
CR		 1519 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP,
1520 AB_IS_ISO_C
6de9cd9a
DN		 1521}
1522ab_attribute;
1523
1524static const mstring attr_bits[] =
1525{
1526 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1527 minit ("DIMENSION", AB_DIMENSION),
1528 minit ("EXTERNAL", AB_EXTERNAL),
1529 minit ("INTRINSIC", AB_INTRINSIC),
1530 minit ("OPTIONAL", AB_OPTIONAL),
1531 minit ("POINTER", AB_POINTER),
1532 minit ("SAVE", AB_SAVE),
775e6c3a 1533 minit ("VOLATILE", AB_VOLATILE),
6de9cd9a 1534 minit ("TARGET", AB_TARGET),
6c7a4dfd 1535 minit ("THREADPRIVATE", AB_THREADPRIVATE),
6de9cd9a 1536 minit ("DUMMY", AB_DUMMY),
6de9cd9a 1537 minit ("RESULT", AB_RESULT),
6de9cd9a
DN		 1538 minit ("DATA", AB_DATA),
1539 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1540 minit ("IN_COMMON", AB_IN_COMMON),
6de9cd9a
DN		 1541 minit ("FUNCTION", AB_FUNCTION),
1542 minit ("SUBROUTINE", AB_SUBROUTINE),
1543 minit ("SEQUENCE", AB_SEQUENCE),
1544 minit ("ELEMENTAL", AB_ELEMENTAL),
1545 minit ("PURE", AB_PURE),
1546 minit ("RECURSIVE", AB_RECURSIVE),
1547 minit ("GENERIC", AB_GENERIC),
1548 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
b122dc6a
JJ		 1549 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1550 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
a8b3b0b6
CR		 1551 minit ("IS_BIND_C", AB_IS_BIND_C),
1552 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1553 minit ("IS_ISO_C", AB_IS_ISO_C),
1554 minit ("VALUE", AB_VALUE),
5046aff5 1555 minit ("ALLOC_COMP", AB_ALLOC_COMP),
ee7e677f 1556 minit ("PROTECTED", AB_PROTECTED),
6de9cd9a
DN		 1557 minit (NULL, -1)
1558};
1559
a8b3b0b6 1560
69de3b83 1561/* Specialization of mio_name. */
edf1eac2
SK		 1562DECL_MIO_NAME (ab_attribute)
1563DECL_MIO_NAME (ar_type)
1564DECL_MIO_NAME (array_type)
1565DECL_MIO_NAME (bt)
1566DECL_MIO_NAME (expr_t)
1567DECL_MIO_NAME (gfc_access)
1568DECL_MIO_NAME (gfc_intrinsic_op)
1569DECL_MIO_NAME (ifsrc)
1570DECL_MIO_NAME (procedure_type)
1571DECL_MIO_NAME (ref_type)
1572DECL_MIO_NAME (sym_flavor)
1573DECL_MIO_NAME (sym_intent)
6de9cd9a
DN		 1574#undef DECL_MIO_NAME
1575
1576/* Symbol attributes are stored in list with the first three elements
1577 being the enumerated fields, while the remaining elements (if any)
1578 indicate the individual attribute bits. The access field is not
1579 saved-- it controls what symbols are exported when a module is
1580 written. */
1581
1582static void
edf1eac2 1583mio_symbol_attribute (symbol_attribute *attr)
6de9cd9a
DN		 1584{
1585 atom_type t;
1586
1587 mio_lparen ();
1588
edf1eac2
SK		 1589 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1590 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1591 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1592 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
6de9cd9a
DN		 1593
1594 if (iomode == IO_OUTPUT)
1595 {
1596 if (attr->allocatable)
edf1eac2 1597 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
6de9cd9a 1598 if (attr->dimension)
edf1eac2 1599 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
6de9cd9a 1600 if (attr->external)
edf1eac2 1601 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
6de9cd9a 1602 if (attr->intrinsic)
edf1eac2 1603 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
6de9cd9a 1604 if (attr->optional)
edf1eac2 1605 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
6de9cd9a 1606 if (attr->pointer)
edf1eac2 1607 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
ee7e677f 1608 if (attr->protected)
edf1eac2 1609 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
6de9cd9a 1610 if (attr->save)
edf1eac2 1611 MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
06469efd 1612 if (attr->value)
edf1eac2 1613 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
775e6c3a 1614 if (attr->volatile_)
edf1eac2 1615 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
6de9cd9a 1616 if (attr->target)
edf1eac2 1617 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
6c7a4dfd 1618 if (attr->threadprivate)
edf1eac2 1619 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
6de9cd9a 1620 if (attr->dummy)
edf1eac2 1621 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
6de9cd9a 1622 if (attr->result)
edf1eac2 1623 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
3d79abbd 1624 /* We deliberately don't preserve the "entry" flag. */
6de9cd9a
DN		 1625
1626 if (attr->data)
edf1eac2 1627 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
6de9cd9a 1628 if (attr->in_namelist)
edf1eac2 1629 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
6de9cd9a 1630 if (attr->in_common)
edf1eac2 1631 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
6de9cd9a
DN		 1632
1633 if (attr->function)
edf1eac2 1634 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
6de9cd9a 1635 if (attr->subroutine)
edf1eac2 1636 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
6de9cd9a 1637 if (attr->generic)
edf1eac2 1638 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
6de9cd9a
DN		 1639
1640 if (attr->sequence)
edf1eac2 1641 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
6de9cd9a 1642 if (attr->elemental)
edf1eac2 1643 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
6de9cd9a 1644 if (attr->pure)
edf1eac2 1645 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
6de9cd9a 1646 if (attr->recursive)
edf1eac2 1647 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
6de9cd9a 1648 if (attr->always_explicit)
edf1eac2 1649 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
b122dc6a 1650 if (attr->cray_pointer)
edf1eac2 1651 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
b122dc6a 1652 if (attr->cray_pointee)
edf1eac2 1653 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
a8b3b0b6
CR		 1654 if (attr->is_bind_c)
1655 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1656 if (attr->is_c_interop)
1657 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1658 if (attr->is_iso_c)
1659 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
5046aff5 1660 if (attr->alloc_comp)
edf1eac2 1661 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
6de9cd9a
DN		 1662
1663 mio_rparen ();
1664
1665 }
1666 else
1667 {
6de9cd9a
DN		 1668 for (;;)
1669 {
1670 t = parse_atom ();
1671 if (t == ATOM_RPAREN)
1672 break;
1673 if (t != ATOM_NAME)
1674 bad_module ("Expected attribute bit name");
1675
1676 switch ((ab_attribute) find_enum (attr_bits))
1677 {
1678 case AB_ALLOCATABLE:
1679 attr->allocatable = 1;
1680 break;
1681 case AB_DIMENSION:
1682 attr->dimension = 1;
1683 break;
1684 case AB_EXTERNAL:
1685 attr->external = 1;
1686 break;
1687 case AB_INTRINSIC:
1688 attr->intrinsic = 1;
1689 break;
1690 case AB_OPTIONAL:
1691 attr->optional = 1;
1692 break;
1693 case AB_POINTER:
1694 attr->pointer = 1;
1695 break;
ee7e677f
TB		 1696 case AB_PROTECTED:
1697 attr->protected = 1;
1698 break;
6de9cd9a
DN		 1699 case AB_SAVE:
1700 attr->save = 1;
1701 break;
06469efd
PT		 1702 case AB_VALUE:
1703 attr->value = 1;
1704 break;
775e6c3a
TB		 1705 case AB_VOLATILE:
1706 attr->volatile_ = 1;
1707 break;
6de9cd9a
DN		 1708 case AB_TARGET:
1709 attr->target = 1;
1710 break;
6c7a4dfd
JJ		 1711 case AB_THREADPRIVATE:
1712 attr->threadprivate = 1;
1713 break;
6de9cd9a
DN		 1714 case AB_DUMMY:
1715 attr->dummy = 1;
1716 break;
6de9cd9a
DN		 1717 case AB_RESULT:
1718 attr->result = 1;
1719 break;
6de9cd9a
DN		 1720 case AB_DATA:
1721 attr->data = 1;
1722 break;
1723 case AB_IN_NAMELIST:
1724 attr->in_namelist = 1;
1725 break;
1726 case AB_IN_COMMON:
1727 attr->in_common = 1;
1728 break;
6de9cd9a
DN		 1729 case AB_FUNCTION:
1730 attr->function = 1;
1731 break;
1732 case AB_SUBROUTINE:
1733 attr->subroutine = 1;
1734 break;
1735 case AB_GENERIC:
1736 attr->generic = 1;
1737 break;
1738 case AB_SEQUENCE:
1739 attr->sequence = 1;
1740 break;
1741 case AB_ELEMENTAL:
1742 attr->elemental = 1;
1743 break;
1744 case AB_PURE:
1745 attr->pure = 1;
1746 break;
1747 case AB_RECURSIVE:
1748 attr->recursive = 1;
1749 break;
edf1eac2
SK		 1750 case AB_ALWAYS_EXPLICIT:
1751 attr->always_explicit = 1;
1752 break;
b122dc6a
JJ		 1753 case AB_CRAY_POINTER:
1754 attr->cray_pointer = 1;
1755 break;
1756 case AB_CRAY_POINTEE:
1757 attr->cray_pointee = 1;
1758 break;
a8b3b0b6
CR		 1759 case AB_IS_BIND_C:
1760 attr->is_bind_c = 1;
1761 break;
1762 case AB_IS_C_INTEROP:
1763 attr->is_c_interop = 1;
1764 break;
1765 case AB_IS_ISO_C:
1766 attr->is_iso_c = 1;
1767 break;
5046aff5
PT		 1768 case AB_ALLOC_COMP:
1769 attr->alloc_comp = 1;
1770 break;
6de9cd9a
DN		 1771 }
1772 }
1773 }
1774}
1775
1776
1777static const mstring bt_types[] = {
1778 minit ("INTEGER", BT_INTEGER),
1779 minit ("REAL", BT_REAL),
1780 minit ("COMPLEX", BT_COMPLEX),
1781 minit ("LOGICAL", BT_LOGICAL),
1782 minit ("CHARACTER", BT_CHARACTER),
1783 minit ("DERIVED", BT_DERIVED),
1784 minit ("PROCEDURE", BT_PROCEDURE),
1785 minit ("UNKNOWN", BT_UNKNOWN),
a8b3b0b6 1786 minit ("VOID", BT_VOID),
6de9cd9a
DN		 1787 minit (NULL, -1)
1788};
1789
1790
1791static void
edf1eac2 1792mio_charlen (gfc_charlen **clp)
6de9cd9a
DN		 1793{
1794 gfc_charlen *cl;
1795
1796 mio_lparen ();
1797
1798 if (iomode == IO_OUTPUT)
1799 {
1800 cl = *clp;
1801 if (cl != NULL)
1802 mio_expr (&cl->length);
1803 }
1804 else
1805 {
6de9cd9a
DN		 1806 if (peek_atom () != ATOM_RPAREN)
1807 {
1808 cl = gfc_get_charlen ();
1809 mio_expr (&cl->length);
1810
1811 *clp = cl;
1812
1813 cl->next = gfc_current_ns->cl_list;
1814 gfc_current_ns->cl_list = cl;
1815 }
1816 }
1817
1818 mio_rparen ();
1819}
1820
1821
1822/* Return a symtree node with a name that is guaranteed to be unique
1823 within the namespace and corresponds to an illegal fortran name. */
1824
1825static gfc_symtree *
edf1eac2 1826get_unique_symtree (gfc_namespace *ns)
6de9cd9a
DN		 1827{
1828 char name[GFC_MAX_SYMBOL_LEN + 1];
1829 static int serial = 0;
1830
1831 sprintf (name, "@%d", serial++);
1832 return gfc_new_symtree (&ns->sym_root, name);
1833}
1834
1835
1836/* See if a name is a generated name. */
1837
1838static int
1839check_unique_name (const char *name)
1840{
6de9cd9a
DN		 1841 return *name == '@';
1842}
1843
1844
1845static void
edf1eac2 1846mio_typespec (gfc_typespec *ts)
6de9cd9a 1847{
6de9cd9a
DN		 1848 mio_lparen ();
1849
edf1eac2 1850 ts->type = MIO_NAME (bt) (ts->type, bt_types);
6de9cd9a
DN		 1851
1852 if (ts->type != BT_DERIVED)
1853 mio_integer (&ts->kind);
1854 else
1855 mio_symbol_ref (&ts->derived);
1856
a8b3b0b6
CR		 1857 /* Add info for C interop and is_iso_c. */
1858 mio_integer (&ts->is_c_interop);
1859 mio_integer (&ts->is_iso_c);
1860
1861 /* If the typespec is for an identifier either from iso_c_binding, or
1862 a constant that was initialized to an identifier from it, use the
1863 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1864 if (ts->is_iso_c)
1865 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1866 else
1867 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1868
3ea04f08
JJ		 1869 if (ts->type != BT_CHARACTER)
1870 {
1871 /* ts->cl is only valid for BT_CHARACTER. */
1872 mio_lparen ();
1873 mio_rparen ();
1874 }
1875 else
1876 mio_charlen (&ts->cl);
6de9cd9a
DN		 1877
1878 mio_rparen ();
1879}
1880
1881
1882static const mstring array_spec_types[] = {
1883 minit ("EXPLICIT", AS_EXPLICIT),
1884 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1885 minit ("DEFERRED", AS_DEFERRED),
1886 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1887 minit (NULL, -1)
1888};
1889
1890
1891static void
edf1eac2 1892mio_array_spec (gfc_array_spec **asp)
6de9cd9a
DN		 1893{
1894 gfc_array_spec *as;
1895 int i;
1896
1897 mio_lparen ();
1898
1899 if (iomode == IO_OUTPUT)
1900 {
1901 if (*asp == NULL)
1902 goto done;
1903 as = *asp;
1904 }
1905 else
1906 {
1907 if (peek_atom () == ATOM_RPAREN)
1908 {
1909 *asp = NULL;
1910 goto done;
1911 }
1912
1913 *asp = as = gfc_get_array_spec ();
1914 }
1915
1916 mio_integer (&as->rank);
edf1eac2 1917 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
6de9cd9a
DN		 1918
1919 for (i = 0; i < as->rank; i++)
1920 {
1921 mio_expr (&as->lower[i]);
1922 mio_expr (&as->upper[i]);
1923 }
1924
1925done:
1926 mio_rparen ();
1927}
1928
1929
1930/* Given a pointer to an array reference structure (which lives in a
1931 gfc_ref structure), find the corresponding array specification
1932 structure. Storing the pointer in the ref structure doesn't quite
1933 work when loading from a module. Generating code for an array
1f2959f0 1934 reference also needs more information than just the array spec. */
6de9cd9a
DN		 1935
1936static const mstring array_ref_types[] = {
1937 minit ("FULL", AR_FULL),
1938 minit ("ELEMENT", AR_ELEMENT),
1939 minit ("SECTION", AR_SECTION),
1940 minit (NULL, -1)
1941};
1942
edf1eac2 1943
6de9cd9a 1944static void
edf1eac2 1945mio_array_ref (gfc_array_ref *ar)
6de9cd9a
DN		 1946{
1947 int i;
1948
1949 mio_lparen ();
edf1eac2 1950 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
6de9cd9a
DN		 1951 mio_integer (&ar->dimen);
1952
1953 switch (ar->type)
1954 {
1955 case AR_FULL:
1956 break;
1957
1958 case AR_ELEMENT:
1959 for (i = 0; i < ar->dimen; i++)
1960 mio_expr (&ar->start[i]);
1961
1962 break;
1963
1964 case AR_SECTION:
1965 for (i = 0; i < ar->dimen; i++)
1966 {
1967 mio_expr (&ar->start[i]);
1968 mio_expr (&ar->end[i]);
1969 mio_expr (&ar->stride[i]);
1970 }
1971
1972 break;
1973
1974 case AR_UNKNOWN:
1975 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1976 }
1977
70fadd09
RS		 1978 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1979 we can't call mio_integer directly. Instead loop over each element
1980 and cast it to/from an integer. */
1981 if (iomode == IO_OUTPUT)
1982 {
1983 for (i = 0; i < ar->dimen; i++)
1984 {
1985 int tmp = (int)ar->dimen_type[i];
1986 write_atom (ATOM_INTEGER, &tmp);
1987 }
1988 }
1989 else
1990 {
1991 for (i = 0; i < ar->dimen; i++)
1992 {
1993 require_atom (ATOM_INTEGER);
1994 ar->dimen_type[i] = atom_int;
1995 }
1996 }
6de9cd9a
DN		 1997
1998 if (iomode == IO_INPUT)
1999 {
63645982 2000 ar->where = gfc_current_locus;
6de9cd9a
DN		 2001
2002 for (i = 0; i < ar->dimen; i++)
63645982 2003 ar->c_where[i] = gfc_current_locus;
6de9cd9a
DN		 2004 }
2005
2006 mio_rparen ();
2007}
2008
2009
2010/* Saves or restores a pointer. The pointer is converted back and
2011 forth from an integer. We return the pointer_info pointer so that
2012 the caller can take additional action based on the pointer type. */
2013
2014static pointer_info *
2015mio_pointer_ref (void *gp)
2016{
2017 pointer_info *p;
2018
2019 if (iomode == IO_OUTPUT)
2020 {
2021 p = get_pointer (*((char **) gp));
2022 write_atom (ATOM_INTEGER, &p->integer);
2023 }
2024 else
2025 {
2026 require_atom (ATOM_INTEGER);
2027 p = add_fixup (atom_int, gp);
2028 }
2029
2030 return p;
2031}
2032
2033
2034/* Save and load references to components that occur within
2035 expressions. We have to describe these references by a number and
2036 by name. The number is necessary for forward references during
2037 reading, and the name is necessary if the symbol already exists in
2038 the namespace and is not loaded again. */
2039
2040static void
edf1eac2 2041mio_component_ref (gfc_component **cp, gfc_symbol *sym)
6de9cd9a
DN		 2042{
2043 char name[GFC_MAX_SYMBOL_LEN + 1];
2044 gfc_component *q;
2045 pointer_info *p;
2046
2047 p = mio_pointer_ref (cp);
2048 if (p->type == P_UNKNOWN)
2049 p->type = P_COMPONENT;
2050
2051 if (iomode == IO_OUTPUT)
cb9e4f55 2052 mio_pool_string (&(*cp)->name);
6de9cd9a
DN		 2053 else
2054 {
2055 mio_internal_string (name);
2056
acff2da9
PT		 2057 /* It can happen that a component reference can be read before the
2058 associated derived type symbol has been loaded. Return now and
2059 wait for a later iteration of load_needed. */
2060 if (sym == NULL)
2061 return;
2062
6de9cd9a
DN		 2063 if (sym->components != NULL && p->u.pointer == NULL)
2064 {
2065 /* Symbol already loaded, so search by name. */
2066 for (q = sym->components; q; q = q->next)
2067 if (strcmp (q->name, name) == 0)
2068 break;
2069
2070 if (q == NULL)
2071 gfc_internal_error ("mio_component_ref(): Component not found");
2072
2073 associate_integer_pointer (p, q);
2074 }
2075
2076 /* Make sure this symbol will eventually be loaded. */
2077 p = find_pointer2 (sym);
2078 if (p->u.rsym.state == UNUSED)
2079 p->u.rsym.state = NEEDED;
2080 }
2081}
2082
2083
2084static void
edf1eac2 2085mio_component (gfc_component *c)
6de9cd9a
DN		 2086{
2087 pointer_info *p;
2088 int n;
2089
2090 mio_lparen ();
2091
2092 if (iomode == IO_OUTPUT)
2093 {
2094 p = get_pointer (c);
2095 mio_integer (&p->integer);
2096 }
2097 else
2098 {
2099 mio_integer (&n);
2100 p = get_integer (n);
2101 associate_integer_pointer (p, c);
2102 }
2103
2104 if (p->type == P_UNKNOWN)
2105 p->type = P_COMPONENT;
2106
cb9e4f55 2107 mio_pool_string (&c->name);
6de9cd9a
DN		 2108 mio_typespec (&c->ts);
2109 mio_array_spec (&c->as);
2110
2111 mio_integer (&c->dimension);
2112 mio_integer (&c->pointer);
5046aff5 2113 mio_integer (&c->allocatable);
2eae3dc7 2114 c->access = MIO_NAME (gfc_access) (c->access, access_types);
6de9cd9a
DN		 2115
2116 mio_expr (&c->initializer);
2117 mio_rparen ();
2118}
2119
2120
2121static void
edf1eac2 2122mio_component_list (gfc_component **cp)
6de9cd9a
DN		 2123{
2124 gfc_component *c, *tail;
2125
2126 mio_lparen ();
2127
2128 if (iomode == IO_OUTPUT)
2129 {
2130 for (c = *cp; c; c = c->next)
2131 mio_component (c);
2132 }
2133 else
2134 {
6de9cd9a
DN		 2135 *cp = NULL;
2136 tail = NULL;
2137
2138 for (;;)
2139 {
2140 if (peek_atom () == ATOM_RPAREN)
2141 break;
2142
2143 c = gfc_get_component ();
2144 mio_component (c);
2145
2146 if (tail == NULL)
2147 *cp = c;
2148 else
2149 tail->next = c;
2150
2151 tail = c;
2152 }
2153 }
2154
2155 mio_rparen ();
2156}
2157
2158
2159static void
edf1eac2 2160mio_actual_arg (gfc_actual_arglist *a)
6de9cd9a 2161{
6de9cd9a 2162 mio_lparen ();
cb9e4f55 2163 mio_pool_string (&a->name);
6de9cd9a
DN		 2164 mio_expr (&a->expr);
2165 mio_rparen ();
2166}
2167
2168
2169static void
edf1eac2 2170mio_actual_arglist (gfc_actual_arglist **ap)
6de9cd9a
DN		 2171{
2172 gfc_actual_arglist *a, *tail;
2173
2174 mio_lparen ();
2175
2176 if (iomode == IO_OUTPUT)
2177 {
2178 for (a = *ap; a; a = a->next)
2179 mio_actual_arg (a);
2180
2181 }
2182 else
2183 {
2184 tail = NULL;
2185
2186 for (;;)
2187 {
2188 if (peek_atom () != ATOM_LPAREN)
2189 break;
2190
2191 a = gfc_get_actual_arglist ();
2192
2193 if (tail == NULL)
2194 *ap = a;
2195 else
2196 tail->next = a;
2197
2198 tail = a;
2199 mio_actual_arg (a);
2200 }
2201 }
2202
2203 mio_rparen ();
2204}
2205
2206
2207/* Read and write formal argument lists. */
2208
2209static void
edf1eac2 2210mio_formal_arglist (gfc_symbol *sym)
6de9cd9a
DN		 2211{
2212 gfc_formal_arglist *f, *tail;
2213
2214 mio_lparen ();
2215
2216 if (iomode == IO_OUTPUT)
2217 {
2218 for (f = sym->formal; f; f = f->next)
2219 mio_symbol_ref (&f->sym);
6de9cd9a
DN		 2220 }
2221 else
2222 {
2223 sym->formal = tail = NULL;
2224
2225 while (peek_atom () != ATOM_RPAREN)
2226 {
2227 f = gfc_get_formal_arglist ();
2228 mio_symbol_ref (&f->sym);
2229
2230 if (sym->formal == NULL)
2231 sym->formal = f;
2232 else
2233 tail->next = f;
2234
2235 tail = f;
2236 }
2237 }
2238
2239 mio_rparen ();
2240}
2241
2242
2243/* Save or restore a reference to a symbol node. */
2244
2245void
edf1eac2 2246mio_symbol_ref (gfc_symbol **symp)
6de9cd9a
DN		 2247{
2248 pointer_info *p;
2249
2250 p = mio_pointer_ref (symp);
2251 if (p->type == P_UNKNOWN)
2252 p->type = P_SYMBOL;
2253
2254 if (iomode == IO_OUTPUT)
2255 {
2256 if (p->u.wsym.state == UNREFERENCED)
2257 p->u.wsym.state = NEEDS_WRITE;
2258 }
2259 else
2260 {
2261 if (p->u.rsym.state == UNUSED)
2262 p->u.rsym.state = NEEDED;
2263 }
2264}
2265
2266
2267/* Save or restore a reference to a symtree node. */
2268
2269static void
edf1eac2 2270mio_symtree_ref (gfc_symtree **stp)
6de9cd9a
DN		 2271{
2272 pointer_info *p;
2273 fixup_t *f;
2274
2275 if (iomode == IO_OUTPUT)
54129a64 2276 mio_symbol_ref (&(*stp)->n.sym);
6de9cd9a
DN		 2277 else
2278 {
2279 require_atom (ATOM_INTEGER);
2280 p = get_integer (atom_int);
613e2ac8 2281
fdecbf80
PT		 2282 /* An unused equivalence member; make a symbol and a symtree
2283 for it. */
613e2ac8 2284 if (in_load_equiv && p->u.rsym.symtree == NULL)
fdecbf80
PT		 2285 {
2286 /* Since this is not used, it must have a unique name. */
2287 p->u.rsym.symtree = get_unique_symtree (gfc_current_ns);
2288
2289 /* Make the symbol. */
2290 if (p->u.rsym.sym == NULL)
2291 {
2292 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2293 gfc_current_ns);
2294 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2295 }
2296
2297 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2298 p->u.rsym.symtree->n.sym->refs++;
2299 p->u.rsym.referenced = 1;
2300 }
613e2ac8 2301
6de9cd9a 2302 if (p->type == P_UNKNOWN)
edf1eac2 2303 p->type = P_SYMBOL;
6de9cd9a
DN		 2304
2305 if (p->u.rsym.state == UNUSED)
2306 p->u.rsym.state = NEEDED;
2307
2308 if (p->u.rsym.symtree != NULL)
edf1eac2
SK		 2309 {
2310 *stp = p->u.rsym.symtree;
2311 }
6de9cd9a 2312 else
edf1eac2
SK		 2313 {
2314 f = gfc_getmem (sizeof (fixup_t));
6de9cd9a 2315
edf1eac2
SK		 2316 f->next = p->u.rsym.stfixup;
2317 p->u.rsym.stfixup = f;
6de9cd9a 2318
66e4ab31 2319 f->pointer = (void **) stp;
edf1eac2 2320 }
6de9cd9a
DN		 2321 }
2322}
2323
edf1eac2 2324
6de9cd9a 2325static void
edf1eac2 2326mio_iterator (gfc_iterator **ip)
6de9cd9a
DN		 2327{
2328 gfc_iterator *iter;
2329
2330 mio_lparen ();
2331
2332 if (iomode == IO_OUTPUT)
2333 {
2334 if (*ip == NULL)
2335 goto done;
2336 }
2337 else
2338 {
2339 if (peek_atom () == ATOM_RPAREN)
2340 {
2341 *ip = NULL;
2342 goto done;
2343 }
2344
2345 *ip = gfc_get_iterator ();
2346 }
2347
2348 iter = *ip;
2349
2350 mio_expr (&iter->var);
2351 mio_expr (&iter->start);
2352 mio_expr (&iter->end);
2353 mio_expr (&iter->step);
2354
2355done:
2356 mio_rparen ();
2357}
2358
2359
6de9cd9a 2360static void
edf1eac2 2361mio_constructor (gfc_constructor **cp)
6de9cd9a
DN		 2362{
2363 gfc_constructor *c, *tail;
2364
2365 mio_lparen ();
2366
2367 if (iomode == IO_OUTPUT)
2368 {
2369 for (c = *cp; c; c = c->next)
2370 {
2371 mio_lparen ();
2372 mio_expr (&c->expr);
2373 mio_iterator (&c->iterator);
2374 mio_rparen ();
2375 }
2376 }
2377 else
2378 {
6de9cd9a
DN		 2379 *cp = NULL;
2380 tail = NULL;
2381
2382 while (peek_atom () != ATOM_RPAREN)
2383 {
2384 c = gfc_get_constructor ();
2385
2386 if (tail == NULL)
2387 *cp = c;
2388 else
2389 tail->next = c;
2390
2391 tail = c;
2392
2393 mio_lparen ();
2394 mio_expr (&c->expr);
2395 mio_iterator (&c->iterator);
2396 mio_rparen ();
2397 }
2398 }
2399
2400 mio_rparen ();
2401}
2402
2403
6de9cd9a
DN		 2404static const mstring ref_types[] = {
2405 minit ("ARRAY", REF_ARRAY),
2406 minit ("COMPONENT", REF_COMPONENT),
2407 minit ("SUBSTRING", REF_SUBSTRING),
2408 minit (NULL, -1)
2409};
2410
2411
2412static void
edf1eac2 2413mio_ref (gfc_ref **rp)
6de9cd9a
DN		 2414{
2415 gfc_ref *r;
2416
2417 mio_lparen ();
2418
2419 r = *rp;
edf1eac2 2420 r->type = MIO_NAME (ref_type) (r->type, ref_types);
6de9cd9a
DN		 2421
2422 switch (r->type)
2423 {
2424 case REF_ARRAY:
2425 mio_array_ref (&r->u.ar);
2426 break;
2427
2428 case REF_COMPONENT:
2429 mio_symbol_ref (&r->u.c.sym);
2430 mio_component_ref (&r->u.c.component, r->u.c.sym);
2431 break;
2432
2433 case REF_SUBSTRING:
2434 mio_expr (&r->u.ss.start);
2435 mio_expr (&r->u.ss.end);
2436 mio_charlen (&r->u.ss.length);
2437 break;
2438 }
2439
2440 mio_rparen ();
2441}
2442
2443
2444static void
edf1eac2 2445mio_ref_list (gfc_ref **rp)
6de9cd9a
DN		 2446{
2447 gfc_ref *ref, *head, *tail;
2448
2449 mio_lparen ();
2450
2451 if (iomode == IO_OUTPUT)
2452 {
2453 for (ref = *rp; ref; ref = ref->next)
2454 mio_ref (&ref);
2455 }
2456 else
2457 {
2458 head = tail = NULL;
2459
2460 while (peek_atom () != ATOM_RPAREN)
2461 {
2462 if (head == NULL)
2463 head = tail = gfc_get_ref ();
2464 else
2465 {
2466 tail->next = gfc_get_ref ();
2467 tail = tail->next;
2468 }
2469
2470 mio_ref (&tail);
2471 }
2472
2473 *rp = head;
2474 }
2475
2476 mio_rparen ();
2477}
2478
2479
2480/* Read and write an integer value. */
2481
2482static void
edf1eac2 2483mio_gmp_integer (mpz_t *integer)
6de9cd9a
DN		 2484{
2485 char *p;
2486
2487 if (iomode == IO_INPUT)
2488 {
2489 if (parse_atom () != ATOM_STRING)
2490 bad_module ("Expected integer string");
2491
2492 mpz_init (*integer);
2493 if (mpz_set_str (*integer, atom_string, 10))
2494 bad_module ("Error converting integer");
2495
2496 gfc_free (atom_string);
6de9cd9a
DN		 2497 }
2498 else
2499 {
2500 p = mpz_get_str (NULL, 10, *integer);
2501 write_atom (ATOM_STRING, p);
2502 gfc_free (p);
2503 }
2504}
2505
2506
2507static void
edf1eac2 2508mio_gmp_real (mpfr_t *real)
6de9cd9a
DN		 2509{
2510 mp_exp_t exponent;
2511 char *p;
2512
2513 if (iomode == IO_INPUT)
2514 {
2515 if (parse_atom () != ATOM_STRING)
2516 bad_module ("Expected real string");
2517
f8e566e5
SK		 2518 mpfr_init (*real);
2519 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
6de9cd9a 2520 gfc_free (atom_string);
6de9cd9a
DN		 2521 }
2522 else
2523 {
f8e566e5 2524 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
6de9cd9a
DN		 2525 atom_string = gfc_getmem (strlen (p) + 20);
2526
2527 sprintf (atom_string, "0.%s@%ld", p, exponent);
78f2fb08
TS		 2528
2529 /* Fix negative numbers. */
2530 if (atom_string[2] == '-')
2531 {
2532 atom_string[0] = '-';
2533 atom_string[1] = '0';
2534 atom_string[2] = '.';
2535 }
2536
6de9cd9a
DN		 2537 write_atom (ATOM_STRING, atom_string);
2538
2539 gfc_free (atom_string);
2540 gfc_free (p);
2541 }
2542}
2543
2544
2545/* Save and restore the shape of an array constructor. */
2546
2547static void
edf1eac2 2548mio_shape (mpz_t **pshape, int rank)
6de9cd9a
DN		 2549{
2550 mpz_t *shape;
2551 atom_type t;
2552 int n;
2553
2554 /* A NULL shape is represented by (). */
2555 mio_lparen ();
2556
2557 if (iomode == IO_OUTPUT)
2558 {
2559 shape = *pshape;
2560 if (!shape)
2561 {
2562 mio_rparen ();
2563 return;
2564 }
2565 }
2566 else
2567 {
2568 t = peek_atom ();
2569 if (t == ATOM_RPAREN)
2570 {
2571 *pshape = NULL;
2572 mio_rparen ();
2573 return;
2574 }
2575
2576 shape = gfc_get_shape (rank);
2577 *pshape = shape;
2578 }
2579
2580 for (n = 0; n < rank; n++)
2581 mio_gmp_integer (&shape[n]);
2582
2583 mio_rparen ();
2584}
2585
2586
2587static const mstring expr_types[] = {
2588 minit ("OP", EXPR_OP),
2589 minit ("FUNCTION", EXPR_FUNCTION),
2590 minit ("CONSTANT", EXPR_CONSTANT),
2591 minit ("VARIABLE", EXPR_VARIABLE),
2592 minit ("SUBSTRING", EXPR_SUBSTRING),
2593 minit ("STRUCTURE", EXPR_STRUCTURE),
2594 minit ("ARRAY", EXPR_ARRAY),
2595 minit ("NULL", EXPR_NULL),
2596 minit (NULL, -1)
2597};
2598
2599/* INTRINSIC_ASSIGN is missing because it is used as an index for
2600 generic operators, not in expressions. INTRINSIC_USER is also
f7b529fa 2601 replaced by the correct function name by the time we see it. */
6de9cd9a
DN		 2602
2603static const mstring intrinsics[] =
2604{
2605 minit ("UPLUS", INTRINSIC_UPLUS),
2606 minit ("UMINUS", INTRINSIC_UMINUS),
2607 minit ("PLUS", INTRINSIC_PLUS),
2608 minit ("MINUS", INTRINSIC_MINUS),
2609 minit ("TIMES", INTRINSIC_TIMES),
2610 minit ("DIVIDE", INTRINSIC_DIVIDE),
2611 minit ("POWER", INTRINSIC_POWER),
2612 minit ("CONCAT", INTRINSIC_CONCAT),
2613 minit ("AND", INTRINSIC_AND),
2614 minit ("OR", INTRINSIC_OR),
2615 minit ("EQV", INTRINSIC_EQV),
2616 minit ("NEQV", INTRINSIC_NEQV),
2617 minit ("EQ", INTRINSIC_EQ),
2618 minit ("NE", INTRINSIC_NE),
2619 minit ("GT", INTRINSIC_GT),
2620 minit ("GE", INTRINSIC_GE),
2621 minit ("LT", INTRINSIC_LT),
2622 minit ("LE", INTRINSIC_LE),
2623 minit ("NOT", INTRINSIC_NOT),
2414e1d6 2624 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
6de9cd9a
DN		 2625 minit (NULL, -1)
2626};
2627
54129a64
PT		 2628
2629/* Remedy a couple of situations where the gfc_expr's can be defective. */
2630
2631static void
2632fix_mio_expr (gfc_expr *e)
2633{
2634 gfc_symtree *ns_st = NULL;
2635 const char *fname;
2636
2637 if (iomode != IO_OUTPUT)
2638 return;
2639
2640 if (e->symtree)
2641 {
2642 /* If this is a symtree for a symbol that came from a contained module
2643 namespace, it has a unique name and we should look in the current
2644 namespace to see if the required, non-contained symbol is available
2645 yet. If so, the latter should be written. */
66e4ab31 2646 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
54129a64 2647 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
edf1eac2 2648 e->symtree->n.sym->name);
54129a64
PT		 2649
2650 /* On the other hand, if the existing symbol is the module name or the
2651 new symbol is a dummy argument, do not do the promotion. */
2652 if (ns_st && ns_st->n.sym
edf1eac2
SK		 2653 && ns_st->n.sym->attr.flavor != FL_MODULE
2654 && !e->symtree->n.sym->attr.dummy)
54129a64
PT		 2655 e->symtree = ns_st;
2656 }
2657 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2658 {
2659 /* In some circumstances, a function used in an initialization
2660 expression, in one use associated module, can fail to be
2661 coupled to its symtree when used in a specification
2662 expression in another module. */
edf1eac2
SK		 2663 fname = e->value.function.esym ? e->value.function.esym->name
2664 : e->value.function.isym->name;
54129a64
PT		 2665 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2666 }
2667}
2668
2669
6de9cd9a
DN		 2670/* Read and write expressions. The form "()" is allowed to indicate a
2671 NULL expression. */
2672
2673static void
edf1eac2 2674mio_expr (gfc_expr **ep)
6de9cd9a
DN		 2675{
2676 gfc_expr *e;
2677 atom_type t;
2678 int flag;
2679
2680 mio_lparen ();
2681
2682 if (iomode == IO_OUTPUT)
2683 {
2684 if (*ep == NULL)
2685 {
2686 mio_rparen ();
2687 return;
2688 }
2689
2690 e = *ep;
edf1eac2 2691 MIO_NAME (expr_t) (e->expr_type, expr_types);
6de9cd9a
DN		 2692 }
2693 else
2694 {
2695 t = parse_atom ();
2696 if (t == ATOM_RPAREN)
2697 {
2698 *ep = NULL;
2699 return;
2700 }
2701
2702 if (t != ATOM_NAME)
2703 bad_module ("Expected expression type");
2704
2705 e = *ep = gfc_get_expr ();
63645982 2706 e->where = gfc_current_locus;
6de9cd9a
DN		 2707 e->expr_type = (expr_t) find_enum (expr_types);
2708 }
2709
2710 mio_typespec (&e->ts);
2711 mio_integer (&e->rank);
2712
54129a64
PT		 2713 fix_mio_expr (e);
2714
6de9cd9a
DN		 2715 switch (e->expr_type)
2716 {
2717 case EXPR_OP:
58b03ab2 2718 e->value.op.operator
edf1eac2 2719 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
6de9cd9a 2720
58b03ab2 2721 switch (e->value.op.operator)
6de9cd9a
DN		 2722 {
2723 case INTRINSIC_UPLUS:
2724 case INTRINSIC_UMINUS:
2725 case INTRINSIC_NOT:
083cc293 2726 case INTRINSIC_PARENTHESES:
58b03ab2 2727 mio_expr (&e->value.op.op1);
6de9cd9a
DN		 2728 break;
2729
2730 case INTRINSIC_PLUS:
2731 case INTRINSIC_MINUS:
2732 case INTRINSIC_TIMES:
2733 case INTRINSIC_DIVIDE:
2734 case INTRINSIC_POWER:
2735 case INTRINSIC_CONCAT:
2736 case INTRINSIC_AND:
2737 case INTRINSIC_OR:
2738 case INTRINSIC_EQV:
2739 case INTRINSIC_NEQV:
2740 case INTRINSIC_EQ:
2741 case INTRINSIC_NE:
2742 case INTRINSIC_GT:
2743 case INTRINSIC_GE:
2744 case INTRINSIC_LT:
2745 case INTRINSIC_LE:
58b03ab2
TS		 2746 mio_expr (&e->value.op.op1);
2747 mio_expr (&e->value.op.op2);
6de9cd9a
DN		 2748 break;
2749
2750 default:
2751 bad_module ("Bad operator");
2752 }
2753
2754 break;
2755
2756 case EXPR_FUNCTION:
2757 mio_symtree_ref (&e->symtree);
2758 mio_actual_arglist (&e->value.function.actual);
2759
2760 if (iomode == IO_OUTPUT)
2761 {
6b25a558
RH		 2762 e->value.function.name
2763 = mio_allocated_string (e->value.function.name);
6de9cd9a
DN		 2764 flag = e->value.function.esym != NULL;
2765 mio_integer (&flag);
2766 if (flag)
2767 mio_symbol_ref (&e->value.function.esym);
2768 else
2769 write_atom (ATOM_STRING, e->value.function.isym->name);
6de9cd9a
DN		 2770 }
2771 else
2772 {
2773 require_atom (ATOM_STRING);
2774 e->value.function.name = gfc_get_string (atom_string);
2775 gfc_free (atom_string);
2776
2777 mio_integer (&flag);
2778 if (flag)
2779 mio_symbol_ref (&e->value.function.esym);
2780 else
2781 {
2782 require_atom (ATOM_STRING);
2783 e->value.function.isym = gfc_find_function (atom_string);
2784 gfc_free (atom_string);
2785 }
2786 }
2787
2788 break;
2789
2790 case EXPR_VARIABLE:
2791 mio_symtree_ref (&e->symtree);
2792 mio_ref_list (&e->ref);
2793 break;
2794
2795 case EXPR_SUBSTRING:
edf1eac2
SK		 2796 e->value.character.string
2797 = (char *) mio_allocated_string (e->value.character.string);
eac33acc 2798 mio_ref_list (&e->ref);
6de9cd9a
DN		 2799 break;
2800
2801 case EXPR_STRUCTURE:
2802 case EXPR_ARRAY:
2803 mio_constructor (&e->value.constructor);
2804 mio_shape (&e->shape, e->rank);
2805 break;
2806
2807 case EXPR_CONSTANT:
2808 switch (e->ts.type)
2809 {
2810 case BT_INTEGER:
2811 mio_gmp_integer (&e->value.integer);
2812 break;
2813
2814 case BT_REAL:
edf1eac2 2815 gfc_set_model_kind (e->ts.kind);
6de9cd9a
DN		 2816 mio_gmp_real (&e->value.real);
2817 break;
2818
2819 case BT_COMPLEX:
edf1eac2 2820 gfc_set_model_kind (e->ts.kind);
6de9cd9a
DN		 2821 mio_gmp_real (&e->value.complex.r);
2822 mio_gmp_real (&e->value.complex.i);
2823 break;
2824
2825 case BT_LOGICAL:
2826 mio_integer (&e->value.logical);
2827 break;
2828
2829 case BT_CHARACTER:
2830 mio_integer (&e->value.character.length);
edf1eac2
SK		 2831 e->value.character.string
2832 = (char *) mio_allocated_string (e->value.character.string);
6de9cd9a
DN		 2833 break;
2834
2835 default:
2836 bad_module ("Bad type in constant expression");
2837 }
2838
2839 break;
2840
2841 case EXPR_NULL:
2842 break;
2843 }
2844
2845 mio_rparen ();
2846}
2847
2848
66e4ab31 2849/* Read and write namelists. */
15f9ce29
TS		 2850
2851static void
edf1eac2 2852mio_namelist (gfc_symbol *sym)
15f9ce29
TS		 2853{
2854 gfc_namelist *n, *m;
2855 const char *check_name;
2856
2857 mio_lparen ();
2858
2859 if (iomode == IO_OUTPUT)
2860 {
2861 for (n = sym->namelist; n; n = n->next)
2862 mio_symbol_ref (&n->sym);
2863 }
2864 else
2865 {
2866 /* This departure from the standard is flagged as an error.
2867 It does, in fact, work correctly. TODO: Allow it
2868 conditionally? */
2869 if (sym->attr.flavor == FL_NAMELIST)
2870 {
2871 check_name = find_use_name (sym->name);
2872 if (check_name && strcmp (check_name, sym->name) != 0)
edf1eac2
SK		 2873 gfc_error ("Namelist %s cannot be renamed by USE "
2874 "association to %s", sym->name, check_name);
15f9ce29
TS		 2875 }
2876
2877 m = NULL;
2878 while (peek_atom () != ATOM_RPAREN)
2879 {
2880 n = gfc_get_namelist ();
2881 mio_symbol_ref (&n->sym);
2882
2883 if (sym->namelist == NULL)
2884 sym->namelist = n;
2885 else
2886 m->next = n;
2887
2888 m = n;
2889 }
2890 sym->namelist_tail = m;
2891 }
2892
2893 mio_rparen ();
2894}
2895
2896
6de9cd9a
DN		 2897/* Save/restore lists of gfc_interface stuctures. When loading an
2898 interface, we are really appending to the existing list of
2899 interfaces. Checking for duplicate and ambiguous interfaces has to
2900 be done later when all symbols have been loaded. */
2901
2902static void
edf1eac2 2903mio_interface_rest (gfc_interface **ip)
6de9cd9a
DN		 2904{
2905 gfc_interface *tail, *p;
2906
2907 if (iomode == IO_OUTPUT)
2908 {
2909 if (ip != NULL)
2910 for (p = *ip; p; p = p->next)
2911 mio_symbol_ref (&p->sym);
2912 }
2913 else
2914 {
6de9cd9a
DN		 2915 if (*ip == NULL)
2916 tail = NULL;
2917 else
2918 {
2919 tail = *ip;
2920 while (tail->next)
2921 tail = tail->next;
2922 }
2923
2924 for (;;)
2925 {
2926 if (peek_atom () == ATOM_RPAREN)
2927 break;
2928
2929 p = gfc_get_interface ();
5c76089a 2930 p->where = gfc_current_locus;
6de9cd9a
DN		 2931 mio_symbol_ref (&p->sym);
2932
2933 if (tail == NULL)
2934 *ip = p;
2935 else
2936 tail->next = p;
2937
2938 tail = p;
2939 }
2940 }
2941
2942 mio_rparen ();
2943}
2944
2945
2946/* Save/restore a nameless operator interface. */
2947
2948static void
edf1eac2 2949mio_interface (gfc_interface **ip)
6de9cd9a 2950{
6de9cd9a
DN		 2951 mio_lparen ();
2952 mio_interface_rest (ip);
2953}
2954
2955
2956/* Save/restore a named operator interface. */
2957
2958static void
cb9e4f55 2959mio_symbol_interface (const char **name, const char **module,
edf1eac2 2960 gfc_interface **ip)
6de9cd9a 2961{
6de9cd9a 2962 mio_lparen ();
cb9e4f55
TS		 2963 mio_pool_string (name);
2964 mio_pool_string (module);
6de9cd9a
DN		 2965 mio_interface_rest (ip);
2966}
2967
2968
2969static void
edf1eac2 2970mio_namespace_ref (gfc_namespace **nsp)
6de9cd9a
DN		 2971{
2972 gfc_namespace *ns;
2973 pointer_info *p;
2974
2975 p = mio_pointer_ref (nsp);
2976
2977 if (p->type == P_UNKNOWN)
2978 p->type = P_NAMESPACE;
2979
3d79abbd 2980 if (iomode == IO_INPUT && p->integer != 0)
6de9cd9a 2981 {
edf1eac2 2982 ns = (gfc_namespace *) p->u.pointer;
3d79abbd
PB		 2983 if (ns == NULL)
2984 {
0366dfe9 2985 ns = gfc_get_namespace (NULL, 0);
3d79abbd
PB		 2986 associate_integer_pointer (p, ns);
2987 }
2988 else
2989 ns->refs++;
6de9cd9a
DN		 2990 }
2991}
2992
2993
edf1eac2
SK		 2994/* Unlike most other routines, the address of the symbol node is already
2995 fixed on input and the name/module has already been filled in. */
6de9cd9a
DN		 2996
2997static void
edf1eac2 2998mio_symbol (gfc_symbol *sym)
6de9cd9a 2999{
a8b3b0b6
CR		 3000 int intmod = INTMOD_NONE;
3001
6de9cd9a
DN		 3002 gfc_formal_arglist *formal;
3003
3004 mio_lparen ();
3005
3006 mio_symbol_attribute (&sym->attr);
3007 mio_typespec (&sym->ts);
3008
3009 /* Contained procedures don't have formal namespaces. Instead we output the
3010 procedure namespace. The will contain the formal arguments. */
3011 if (iomode == IO_OUTPUT)
3012 {
3013 formal = sym->formal;
3014 while (formal && !formal->sym)
3015 formal = formal->next;
3016
3017 if (formal)
3018 mio_namespace_ref (&formal->sym->ns);
3019 else
3020 mio_namespace_ref (&sym->formal_ns);
3021 }
3022 else
3023 {
3024 mio_namespace_ref (&sym->formal_ns);
3025 if (sym->formal_ns)
3026 {
3027 sym->formal_ns->proc_name = sym;
3028 sym->refs++;
3029 }
3030 }
3031
66e4ab31 3032 /* Save/restore common block links. */
6de9cd9a
DN		 3033 mio_symbol_ref (&sym->common_next);
3034
3035 mio_formal_arglist (sym);
3036
8598a113
TS		 3037 if (sym->attr.flavor == FL_PARAMETER)
3038 mio_expr (&sym->value);
3039
6de9cd9a
DN		 3040 mio_array_spec (&sym->as);
3041
3042 mio_symbol_ref (&sym->result);
3043
b122dc6a
JJ		 3044 if (sym->attr.cray_pointee)
3045 mio_symbol_ref (&sym->cp_pointer);
3046
6de9cd9a
DN		 3047 /* Note that components are always saved, even if they are supposed
3048 to be private. Component access is checked during searching. */
3049
3050 mio_component_list (&sym->components);
3051
3052 if (sym->components != NULL)
edf1eac2
SK		 3053 sym->component_access
3054 = MIO_NAME (gfc_access) (sym->component_access, access_types);
6de9cd9a 3055
15f9ce29 3056 mio_namelist (sym);
a8b3b0b6
CR		 3057
3058 /* Add the fields that say whether this is from an intrinsic module,
3059 and if so, what symbol it is within the module. */
3060/* mio_integer (&(sym->from_intmod)); */
3061 if (iomode == IO_OUTPUT)
3062 {
3063 intmod = sym->from_intmod;
3064 mio_integer (&intmod);
3065 }
3066 else
3067 {
3068 mio_integer (&intmod);
3069 sym->from_intmod = intmod;
3070 }
3071
3072 mio_integer (&(sym->intmod_sym_id));
3073
6de9cd9a
DN		 3074 mio_rparen ();
3075}
3076
3077
3078/************************* Top level subroutines *************************/
3079
3080/* Skip a list between balanced left and right parens. */
3081
3082static void
3083skip_list (void)
3084{
3085 int level;
3086
3087 level = 0;
3088 do
3089 {
3090 switch (parse_atom ())
3091 {
3092 case ATOM_LPAREN:
3093 level++;
3094 break;
3095
3096 case ATOM_RPAREN:
3097 level--;
3098 break;
3099
3100 case ATOM_STRING:
3101 gfc_free (atom_string);
3102 break;
3103
3104 case ATOM_NAME:
3105 case ATOM_INTEGER:
3106 break;
3107 }
3108 }
3109 while (level > 0);
3110}
3111
3112
3113/* Load operator interfaces from the module. Interfaces are unusual
3114 in that they attach themselves to existing symbols. */
3115
3116static void
3117load_operator_interfaces (void)
3118{
3119 const char *p;
3120 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3121 gfc_user_op *uop;
3122
3123 mio_lparen ();
3124
3125 while (peek_atom () != ATOM_RPAREN)
3126 {
3127 mio_lparen ();
3128
3129 mio_internal_string (name);
3130 mio_internal_string (module);
3131
3132 /* Decide if we need to load this one or not. */
3133 p = find_use_name (name);
3134 if (p == NULL)
3135 {
3136 while (parse_atom () != ATOM_RPAREN);
3137 }
3138 else
3139 {
3140 uop = gfc_get_uop (p);
3141 mio_interface_rest (&uop->operator);
3142 }
3143 }
3144
3145 mio_rparen ();
3146}
3147
3148
3149/* Load interfaces from the module. Interfaces are unusual in that
3150 they attach themselves to existing symbols. */
3151
3152static void
3153load_generic_interfaces (void)
3154{
3155 const char *p;
3156 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3157 gfc_symbol *sym;
1027275d
PT		 3158 gfc_interface *generic = NULL;
3159 int n, i;
6de9cd9a
DN		 3160
3161 mio_lparen ();
3162
3163 while (peek_atom () != ATOM_RPAREN)
3164 {
3165 mio_lparen ();
3166
3167 mio_internal_string (name);
3168 mio_internal_string (module);
3169
1027275d
PT		 3170 n = number_use_names (name);
3171 n = n ? n : 1;
6de9cd9a 3172
1027275d 3173 for (i = 1; i <= n; i++)
6de9cd9a 3174 {
1027275d
PT		 3175 /* Decide if we need to load this one or not. */
3176 p = find_use_name_n (name, &i);
6de9cd9a 3177
1027275d
PT		 3178 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3179 {
3180 while (parse_atom () != ATOM_RPAREN);
edf1eac2 3181 continue;
1027275d 3182 }
6de9cd9a 3183
1027275d
PT		 3184 if (sym == NULL)
3185 {
3186 gfc_get_symbol (p, NULL, &sym);
6de9cd9a 3187
1027275d
PT		 3188 sym->attr.flavor = FL_PROCEDURE;
3189 sym->attr.generic = 1;
3190 sym->attr.use_assoc = 1;
3191 }
9914f8cf
PT		 3192 else
3193 {
3194 /* Unless sym is a generic interface, this reference
3195 is ambiguous. */
3196 gfc_symtree *st;
3197 p = p ? p : name;
3198 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
9dd8004e 3199 if (!sym->attr.generic
66e4ab31
SK		 3200 && sym->module != NULL
3201 && strcmp(module, sym->module) != 0)
9dd8004e 3202 st->ambiguous = 1;
9914f8cf 3203 }
1027275d
PT		 3204 if (i == 1)
3205 {
3206 mio_interface_rest (&sym->generic);
3207 generic = sym->generic;
3208 }
3209 else
3210 {
3211 sym->generic = generic;
3212 sym->attr.generic_copy = 1;
3213 }
3214 }
6de9cd9a
DN		 3215 }
3216
3217 mio_rparen ();
3218}
3219
3220
9056bd70
TS		 3221/* Load common blocks. */
3222
3223static void
edf1eac2 3224load_commons (void)
9056bd70 3225{
edf1eac2 3226 char name[GFC_MAX_SYMBOL_LEN + 1];
9056bd70
TS		 3227 gfc_common_head *p;
3228
3229 mio_lparen ();
3230
3231 while (peek_atom () != ATOM_RPAREN)
3232 {
6c7a4dfd 3233 int flags;
9056bd70
TS		 3234 mio_lparen ();
3235 mio_internal_string (name);
3236
53814b8f 3237 p = gfc_get_common (name, 1);
9056bd70
TS		 3238
3239 mio_symbol_ref (&p->head);
6c7a4dfd
JJ		 3240 mio_integer (&flags);
3241 if (flags & 1)
3242 p->saved = 1;
3243 if (flags & 2)
3244 p->threadprivate = 1;
9056bd70
TS		 3245 p->use_assoc = 1;
3246
a8b3b0b6
CR		 3247 /* Get whether this was a bind(c) common or not. */
3248 mio_integer (&p->is_bind_c);
3249 /* Get the binding label. */
3250 mio_internal_string (p->binding_label);
3251
edf1eac2 3252 mio_rparen ();
9056bd70
TS		 3253 }
3254
edf1eac2 3255 mio_rparen ();
9056bd70
TS		 3256}
3257
edf1eac2 3258
66e4ab31
SK		 3259/* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3260 so that unused variables are not loaded and so that the expression can
3261 be safely freed. */
30aabb86
PT		 3262
3263static void
edf1eac2 3264load_equiv (void)
30aabb86 3265{
613e2ac8
PT		 3266 gfc_equiv *head, *tail, *end, *eq;
3267 bool unused;
30aabb86 3268
edf1eac2 3269 mio_lparen ();
613e2ac8 3270 in_load_equiv = true;
30aabb86
PT		 3271
3272 end = gfc_current_ns->equiv;
edf1eac2 3273 while (end != NULL && end->next != NULL)
30aabb86
PT		 3274 end = end->next;
3275
66e4ab31 3276 while (peek_atom () != ATOM_RPAREN) {
edf1eac2 3277 mio_lparen ();
30aabb86
PT		 3278 head = tail = NULL;
3279
edf1eac2 3280 while(peek_atom () != ATOM_RPAREN)
30aabb86
PT		 3281 {
3282 if (head == NULL)
edf1eac2 3283 head = tail = gfc_get_equiv ();
30aabb86
PT		 3284 else
3285 {
edf1eac2 3286 tail->eq = gfc_get_equiv ();
30aabb86
PT		 3287 tail = tail->eq;
3288 }
3289
edf1eac2
SK		 3290 mio_pool_string (&tail->module);
3291 mio_expr (&tail->expr);
30aabb86
PT		 3292 }
3293
fdecbf80
PT		 3294 /* Unused equivalence members have a unique name. */
3295 unused = true;
613e2ac8
PT		 3296 for (eq = head; eq; eq = eq->eq)
3297 {
fdecbf80 3298 if (!check_unique_name (eq->expr->symtree->name))
613e2ac8 3299 {
fdecbf80 3300 unused = false;
613e2ac8
PT		 3301 break;
3302 }
3303 }
3304
3305 if (unused)
3306 {
3307 for (eq = head; eq; eq = head)
3308 {
3309 head = eq->eq;
3310 gfc_free_expr (eq->expr);
3311 gfc_free (eq);
3312 }
3313 }
3314
30aabb86
PT		 3315 if (end == NULL)
3316 gfc_current_ns->equiv = head;
3317 else
3318 end->next = head;
3319
613e2ac8
PT		 3320 if (head != NULL)
3321 end = head;
3322
edf1eac2 3323 mio_rparen ();
30aabb86
PT		 3324 }
3325
edf1eac2 3326 mio_rparen ();
613e2ac8 3327 in_load_equiv = false;
30aabb86 3328}
9056bd70 3329
66e4ab31 3330
6de9cd9a
DN		 3331/* Recursive function to traverse the pointer_info tree and load a
3332 needed symbol. We return nonzero if we load a symbol and stop the
3333 traversal, because the act of loading can alter the tree. */
3334
3335static int
edf1eac2 3336load_needed (pointer_info *p)
6de9cd9a
DN		 3337{
3338 gfc_namespace *ns;
3339 pointer_info *q;
3340 gfc_symbol *sym;
26436493 3341 int rv;
6de9cd9a 3342
26436493 3343 rv = 0;
6de9cd9a 3344 if (p == NULL)
26436493
PT		 3345 return rv;
3346
3347 rv |= load_needed (p->left);
3348 rv |= load_needed (p->right);
6de9cd9a
DN		 3349
3350 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
26436493 3351 return rv;
6de9cd9a
DN		 3352
3353 p->u.rsym.state = USED;
3354
3355 set_module_locus (&p->u.rsym.where);
3356
3357 sym = p->u.rsym.sym;
3358 if (sym == NULL)
3359 {
3360 q = get_integer (p->u.rsym.ns);
3361
3362 ns = (gfc_namespace *) q->u.pointer;
3363 if (ns == NULL)
3364 {
3365 /* Create an interface namespace if necessary. These are
3366 the namespaces that hold the formal parameters of module
3367 procedures. */
3368
0366dfe9 3369 ns = gfc_get_namespace (NULL, 0);
6de9cd9a
DN		 3370 associate_integer_pointer (q, ns);
3371 }
3372
3373 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
cb9e4f55 3374 sym->module = gfc_get_string (p->u.rsym.module);
6de9cd9a
DN		 3375
3376 associate_integer_pointer (p, sym);
3377 }
3378
3379 mio_symbol (sym);
3380 sym->attr.use_assoc = 1;
993ef28f
PT		 3381 if (only_flag)
3382 sym->attr.use_only = 1;
6de9cd9a
DN		 3383
3384 return 1;
3385}
3386
3387
66e4ab31 3388/* Recursive function for cleaning up things after a module has been read. */
6de9cd9a
DN		 3389
3390static void
edf1eac2 3391read_cleanup (pointer_info *p)
6de9cd9a
DN		 3392{
3393 gfc_symtree *st;
3394 pointer_info *q;
3395
3396 if (p == NULL)
3397 return;
3398
3399 read_cleanup (p->left);
3400 read_cleanup (p->right);
3401
3402 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3403 {
3404 /* Add hidden symbols to the symtree. */
3405 q = get_integer (p->u.rsym.ns);
3406 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3407
3408 st->n.sym = p->u.rsym.sym;
3409 st->n.sym->refs++;
3410
3411 /* Fixup any symtree references. */
3412 p->u.rsym.symtree = st;
3413 resolve_fixups (p->u.rsym.stfixup, st);
3414 p->u.rsym.stfixup = NULL;
3415 }
3416
3417 /* Free unused symbols. */
3418 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3419 gfc_free_symbol (p->u.rsym.sym);
3420}
3421
3422
dcdc7b6c
PT		 3423/* Given a root symtree node and a symbol, try to find a symtree that
3424 references the symbol that is not a unique name. */
3425
3426static gfc_symtree *
3427find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3428{
3429 gfc_symtree *s = NULL;
3430
3431 if (st == NULL)
3432 return s;
3433
3434 s = find_symtree_for_symbol (st->right, sym);
3435 if (s != NULL)
3436 return s;
3437 s = find_symtree_for_symbol (st->left, sym);
3438 if (s != NULL)
3439 return s;
3440
3441 if (st->n.sym == sym && !check_unique_name (st->name))
3442 return st;
3443
3444 return s;
3445}
3446
3447
6de9cd9a
DN		 3448/* Read a module file. */
3449
3450static void
3451read_module (void)
3452{
3453 module_locus operator_interfaces, user_operators;
3454 const char *p;
3455 char name[GFC_MAX_SYMBOL_LEN + 1];
3456 gfc_intrinsic_op i;
acff2da9 3457 int ambiguous, j, nuse, symbol;
e8c30b5f 3458 pointer_info *info, *q;
6de9cd9a
DN		 3459 gfc_use_rename *u;
3460 gfc_symtree *st;
3461 gfc_symbol *sym;
3462
66e4ab31 3463 get_module_locus (&operator_interfaces); /* Skip these for now. */
6de9cd9a
DN		 3464 skip_list ();
3465
3466 get_module_locus (&user_operators);
3467 skip_list ();
3468 skip_list ();
30aabb86
PT		 3469
3470 /* Skip commons and equivalences for now. */
3471 skip_list ();
9056bd70 3472 skip_list ();
6de9cd9a
DN		 3473
3474 mio_lparen ();
3475
3476 /* Create the fixup nodes for all the symbols. */
3477
3478 while (peek_atom () != ATOM_RPAREN)
3479 {
3480 require_atom (ATOM_INTEGER);
3481 info = get_integer (atom_int);
3482
3483 info->type = P_SYMBOL;
3484 info->u.rsym.state = UNUSED;
3485
3486 mio_internal_string (info->u.rsym.true_name);
3487 mio_internal_string (info->u.rsym.module);
a8b3b0b6 3488 mio_internal_string (info->u.rsym.binding_label);
6de9cd9a 3489
a8b3b0b6 3490
6de9cd9a
DN		 3491 require_atom (ATOM_INTEGER);
3492 info->u.rsym.ns = atom_int;
3493
3494 get_module_locus (&info->u.rsym.where);
3495 skip_list ();
3496
3497 /* See if the symbol has already been loaded by a previous module.
acff2da9
PT		 3498 If so, we reference the existing symbol and prevent it from
3499 being loaded again. This should not happen if the symbol being
3500 read is an index for an assumed shape dummy array (ns != 1). */
6cda231e 3501
acff2da9
PT		 3502 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3503
3504 if (sym == NULL
edf1eac2 3505 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
6de9cd9a
DN		 3506 continue;
3507
3508 info->u.rsym.state = USED;
6de9cd9a 3509 info->u.rsym.sym = sym;
dcdc7b6c 3510
e8c30b5f
PT		 3511 /* Some symbols do not have a namespace (eg. formal arguments),
3512 so the automatic "unique symtree" mechanism must be suppressed
3513 by marking them as referenced. */
3514 q = get_integer (info->u.rsym.ns);
3515 if (q->u.pointer == NULL)
3516 {
3517 info->u.rsym.referenced = 1;
3518 continue;
3519 }
3520
dcdc7b6c
PT		 3521 /* If possible recycle the symtree that references the symbol.
3522 If a symtree is not found and the module does not import one,
3523 a unique-name symtree is found by read_cleanup. */
3524 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3525 if (st != NULL)
3526 {
3527 info->u.rsym.symtree = st;
3528 info->u.rsym.referenced = 1;
3529 }
6de9cd9a
DN		 3530 }
3531
3532 mio_rparen ();
3533
3534 /* Parse the symtree lists. This lets us mark which symbols need to
3535 be loaded. Renaming is also done at this point by replacing the
3536 symtree name. */
3537
3538 mio_lparen ();
3539
3540 while (peek_atom () != ATOM_RPAREN)
3541 {
3542 mio_internal_string (name);
3543 mio_integer (&ambiguous);
3544 mio_integer (&symbol);
3545
3546 info = get_integer (symbol);
3547
30aabb86
PT		 3548 /* See how many use names there are. If none, go through the start
3549 of the loop at least once. */
3550 nuse = number_use_names (name);
3551 if (nuse == 0)
3552 nuse = 1;
6de9cd9a 3553
30aabb86 3554 for (j = 1; j <= nuse; j++)
6de9cd9a 3555 {
30aabb86
PT		 3556 /* Get the jth local name for this symbol. */
3557 p = find_use_name_n (name, &j);
6de9cd9a 3558
ac497e6a
TB		 3559 if (p == NULL && strcmp (name, module_name) == 0)
3560 p = name;
3561
aec78e73 3562 /* Skip symtree nodes not in an ONLY clause, unless there
66e4ab31 3563 is an existing symtree loaded from another USE statement. */
30aabb86 3564 if (p == NULL)
aec78e73
PT		 3565 {
3566 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3567 if (st != NULL)
3568 info->u.rsym.symtree = st;
3569 continue;
3570 }
6de9cd9a 3571
30aabb86 3572 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
6de9cd9a 3573
30aabb86 3574 if (st != NULL)
6de9cd9a 3575 {
aec78e73 3576 /* Check for ambiguous symbols. */
30aabb86
PT		 3577 if (st->n.sym != info->u.rsym.sym)
3578 st->ambiguous = 1;
3579 info->u.rsym.symtree = st;
6de9cd9a 3580 }
30aabb86
PT		 3581 else
3582 {
edf1eac2
SK		 3583 /* Create a symtree node in the current namespace for this
3584 symbol. */
3585 st = check_unique_name (p)
3586 ? get_unique_symtree (gfc_current_ns)
3587 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
30aabb86
PT		 3588
3589 st->ambiguous = ambiguous;
3590
3591 sym = info->u.rsym.sym;
3592
3593 /* Create a symbol node if it doesn't already exist. */
3594 if (sym == NULL)
3595 {
edf1eac2
SK		 3596 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3597 gfc_current_ns);
3598 sym = info->u.rsym.sym;
30aabb86 3599 sym->module = gfc_get_string (info->u.rsym.module);
a8b3b0b6
CR		 3600
3601 /* TODO: hmm, can we test this? Do we know it will be
3602 initialized to zeros? */
3603 if (info->u.rsym.binding_label[0] != '\0')
3604 strcpy (sym->binding_label, info->u.rsym.binding_label);
30aabb86
PT		 3605 }
3606
3607 st->n.sym = sym;
3608 st->n.sym->refs++;
6de9cd9a 3609
30aabb86
PT		 3610 /* Store the symtree pointing to this symbol. */
3611 info->u.rsym.symtree = st;
6de9cd9a 3612
30aabb86 3613 if (info->u.rsym.state == UNUSED)
edf1eac2 3614 info->u.rsym.state = NEEDED;
30aabb86
PT		 3615 info->u.rsym.referenced = 1;
3616 }
6de9cd9a
DN		 3617 }
3618 }
3619
3620 mio_rparen ();
3621
3622 /* Load intrinsic operator interfaces. */
3623 set_module_locus (&operator_interfaces);
3624 mio_lparen ();
3625
3626 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3627 {
3628 if (i == INTRINSIC_USER)
3629 continue;
3630
3631 if (only_flag)
3632 {
3633 u = find_use_operator (i);
3634
3635 if (u == NULL)
3636 {
3637 skip_list ();
3638 continue;
3639 }
3640
3641 u->found = 1;
3642 }
3643
3644 mio_interface (&gfc_current_ns->operator[i]);
3645 }
3646
3647 mio_rparen ();
3648
3649 /* Load generic and user operator interfaces. These must follow the
3650 loading of symtree because otherwise symbols can be marked as
3651 ambiguous. */
3652
3653 set_module_locus (&user_operators);
3654
3655 load_operator_interfaces ();
3656 load_generic_interfaces ();
3657
9056bd70 3658 load_commons ();
edf1eac2 3659 load_equiv ();
9056bd70 3660
6de9cd9a
DN		 3661 /* At this point, we read those symbols that are needed but haven't
3662 been loaded yet. If one symbol requires another, the other gets
3663 marked as NEEDED if its previous state was UNUSED. */
3664
3665 while (load_needed (pi_root));
3666
edf1eac2 3667 /* Make sure all elements of the rename-list were found in the module. */
6de9cd9a
DN		 3668
3669 for (u = gfc_rename_list; u; u = u->next)
3670 {
3671 if (u->found)
3672 continue;
3673
3674 if (u->operator == INTRINSIC_NONE)
3675 {
3676 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3677 u->use_name, &u->where, module_name);
3678 continue;
3679 }
3680
3681 if (u->operator == INTRINSIC_USER)
3682 {
edf1eac2
SK		 3683 gfc_error ("User operator '%s' referenced at %L not found "
3684 "in module '%s'", u->use_name, &u->where, module_name);
6de9cd9a
DN		 3685 continue;
3686 }
3687
edf1eac2
SK		 3688 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3689 "in module '%s'", gfc_op2string (u->operator), &u->where,
3690 module_name);
6de9cd9a
DN		 3691 }
3692
3693 gfc_check_interfaces (gfc_current_ns);
3694
3695 /* Clean up symbol nodes that were never loaded, create references
3696 to hidden symbols. */
3697
3698 read_cleanup (pi_root);
3699}
3700
3701
3702/* Given an access type that is specific to an entity and the default
131ac5dd
BM		 3703 access, return nonzero if the entity is publicly accessible. If the
3704 element is declared as PUBLIC, then it is public; if declared
3705 PRIVATE, then private, and otherwise it is public unless the default
3706 access in this context has been declared PRIVATE. */
6de9cd9a 3707
af30f793
PB		 3708bool
3709gfc_check_access (gfc_access specific_access, gfc_access default_access)
6de9cd9a 3710{
6de9cd9a 3711 if (specific_access == ACCESS_PUBLIC)
af30f793 3712 return TRUE;
6de9cd9a 3713 if (specific_access == ACCESS_PRIVATE)
af30f793 3714 return FALSE;
6de9cd9a 3715
131ac5dd 3716 return default_access != ACCESS_PRIVATE;
6de9cd9a
DN		 3717}
3718
3719
66e4ab31 3720/* Write a common block to the module. */
9056bd70
TS		 3721
3722static void
3723write_common (gfc_symtree *st)
3724{
3725 gfc_common_head *p;
30aabb86 3726 const char * name;
6c7a4dfd 3727 int flags;
a8b3b0b6
CR		 3728 const char *label;
3729
9056bd70
TS		 3730 if (st == NULL)
3731 return;
3732
edf1eac2
SK		 3733 write_common (st->left);
3734 write_common (st->right);
9056bd70 3735
edf1eac2 3736 mio_lparen ();
30aabb86
PT		 3737
3738 /* Write the unmangled name. */
3739 name = st->n.common->name;
3740
edf1eac2 3741 mio_pool_string (&name);
9056bd70
TS		 3742
3743 p = st->n.common;
edf1eac2 3744 mio_symbol_ref (&p->head);
6c7a4dfd
JJ		 3745 flags = p->saved ? 1 : 0;
3746 if (p->threadprivate) flags |= 2;
edf1eac2 3747 mio_integer (&flags);
9056bd70 3748
a8b3b0b6
CR		 3749 /* Write out whether the common block is bind(c) or not. */
3750 mio_integer (&(p->is_bind_c));
3751
3752 /* Write out the binding label, or the com name if no label given. */
3753 if (p->is_bind_c)
3754 {
3755 label = p->binding_label;
3756 mio_pool_string (&label);
3757 }
3758 else
3759 {
3760 label = p->name;
3761 mio_pool_string (&label);
3762 }
3763
edf1eac2 3764 mio_rparen ();
9056bd70
TS		 3765}
3766
a8b3b0b6
CR		 3767
3768/* Write the blank common block to the module. */
30aabb86
PT		 3769
3770static void
3771write_blank_common (void)
3772{
3773 const char * name = BLANK_COMMON_NAME;
6c7a4dfd 3774 int saved;
a8b3b0b6
CR		 3775 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3776 this, but it hasn't been checked. Just making it so for now. */
3777 int is_bind_c = 0;
30aabb86
PT		 3778
3779 if (gfc_current_ns->blank_common.head == NULL)
3780 return;
3781
edf1eac2 3782 mio_lparen ();
30aabb86 3783
edf1eac2 3784 mio_pool_string (&name);
30aabb86 3785
edf1eac2 3786 mio_symbol_ref (&gfc_current_ns->blank_common.head);
6c7a4dfd 3787 saved = gfc_current_ns->blank_common.saved;
edf1eac2 3788 mio_integer (&saved);
30aabb86 3789
a8b3b0b6
CR		 3790 /* Write out whether the common block is bind(c) or not. */
3791 mio_integer (&is_bind_c);
3792
3793 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3794 it doesn't matter because the label isn't used. */
3795 mio_pool_string (&name);
3796
edf1eac2 3797 mio_rparen ();
30aabb86
PT		 3798}
3799
edf1eac2 3800
30aabb86
PT		 3801/* Write equivalences to the module. */
3802
3803static void
edf1eac2 3804write_equiv (void)
30aabb86
PT		 3805{
3806 gfc_equiv *eq, *e;
3807 int num;
3808
3809 num = 0;
edf1eac2 3810 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
30aabb86 3811 {
edf1eac2 3812 mio_lparen ();
30aabb86 3813
edf1eac2 3814 for (e = eq; e; e = e->eq)
30aabb86
PT		 3815 {
3816 if (e->module == NULL)
edf1eac2
SK		 3817 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3818 mio_allocated_string (e->module);
3819 mio_expr (&e->expr);
30aabb86
PT		 3820 }
3821
3822 num++;
edf1eac2 3823 mio_rparen ();
30aabb86
PT		 3824 }
3825}
9056bd70 3826
edf1eac2 3827
6de9cd9a
DN		 3828/* Write a symbol to the module. */
3829
3830static void
edf1eac2 3831write_symbol (int n, gfc_symbol *sym)
6de9cd9a 3832{
a8b3b0b6 3833 const char *label;
6de9cd9a
DN		 3834
3835 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3836 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3837
3838 mio_integer (&n);
cb9e4f55 3839 mio_pool_string (&sym->name);
6de9cd9a 3840
cb9e4f55 3841 mio_pool_string (&sym->module);
a8b3b0b6
CR		 3842 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3843 {
3844 label = sym->binding_label;
3845 mio_pool_string (&label);
3846 }
3847 else
3848 mio_pool_string (&sym->name);
3849
6de9cd9a
DN		 3850 mio_pointer_ref (&sym->ns);
3851
3852 mio_symbol (sym);
3853 write_char ('\n');
3854}
3855
3856
3857/* Recursive traversal function to write the initial set of symbols to
3858 the module. We check to see if the symbol should be written
3859 according to the access specification. */
3860
3861static void
edf1eac2 3862write_symbol0 (gfc_symtree *st)
6de9cd9a
DN		 3863{
3864 gfc_symbol *sym;
3865 pointer_info *p;
3866
3867 if (st == NULL)
3868 return;
3869
3870 write_symbol0 (st->left);
3871 write_symbol0 (st->right);
3872
3873 sym = st->n.sym;
cb9e4f55
TS		 3874 if (sym->module == NULL)
3875 sym->module = gfc_get_string (module_name);
6de9cd9a
DN		 3876
3877 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3878 && !sym->attr.subroutine && !sym->attr.function)
3879 return;
3880
af30f793 3881 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
6de9cd9a
DN		 3882 return;
3883
3884 p = get_pointer (sym);
3885 if (p->type == P_UNKNOWN)
3886 p->type = P_SYMBOL;
3887
3888 if (p->u.wsym.state == WRITTEN)
3889 return;
3890
3891 write_symbol (p->integer, sym);
3892 p->u.wsym.state = WRITTEN;
6de9cd9a
DN		 3893}
3894
3895
3896/* Recursive traversal function to write the secondary set of symbols
3897 to the module file. These are symbols that were not public yet are
3898 needed by the public symbols or another dependent symbol. The act
3899 of writing a symbol can modify the pointer_info tree, so we cease
3900 traversal if we find a symbol to write. We return nonzero if a
3901 symbol was written and pass that information upwards. */
3902
3903static int
edf1eac2 3904write_symbol1 (pointer_info *p)
6de9cd9a 3905{
66e4ab31 3906
6de9cd9a
DN		 3907 if (p == NULL)
3908 return 0;
3909
3910 if (write_symbol1 (p->left))
3911 return 1;
3912 if (write_symbol1 (p->right))
3913 return 1;
3914
3915 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3916 return 0;
3917
3918 p->u.wsym.state = WRITTEN;
3919 write_symbol (p->integer, p->u.wsym.sym);
3920
3921 return 1;
3922}
3923
3924
3925/* Write operator interfaces associated with a symbol. */
3926
3927static void
edf1eac2 3928write_operator (gfc_user_op *uop)
6de9cd9a
DN		 3929{
3930 static char nullstring[] = "";
cb9e4f55 3931 const char *p = nullstring;
6de9cd9a
DN		 3932
3933 if (uop->operator == NULL
af30f793 3934 || !gfc_check_access (uop->access, uop->ns->default_access))
6de9cd9a
DN		 3935 return;
3936
cb9e4f55 3937 mio_symbol_interface (&uop->name, &p, &uop->operator);
6de9cd9a
DN		 3938}
3939
3940
3941/* Write generic interfaces associated with a symbol. */
3942
3943static void
edf1eac2 3944write_generic (gfc_symbol *sym)
6de9cd9a 3945{
6de9cd9a 3946 if (sym->generic == NULL
af30f793 3947 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
6de9cd9a
DN		 3948 return;
3949
9dd8004e
PT		 3950 if (sym->module == NULL)
3951 sym->module = gfc_get_string (module_name);
3952
cb9e4f55 3953 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
6de9cd9a
DN		 3954}
3955
3956
3957static void
edf1eac2 3958write_symtree (gfc_symtree *st)
6de9cd9a
DN		 3959{
3960 gfc_symbol *sym;
3961 pointer_info *p;
3962
3963 sym = st->n.sym;
af30f793 3964 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
6de9cd9a
DN		 3965 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3966 && !sym->attr.subroutine && !sym->attr.function))
3967 return;
3968
3969 if (check_unique_name (st->name))
3970 return;
3971
3972 p = find_pointer (sym);
3973 if (p == NULL)
3974 gfc_internal_error ("write_symtree(): Symbol not written");
3975
cb9e4f55 3976 mio_pool_string (&st->name);
6de9cd9a
DN		 3977 mio_integer (&st->ambiguous);
3978 mio_integer (&p->integer);
3979}
3980
3981
3982static void
3983write_module (void)
3984{
3985 gfc_intrinsic_op i;
3986
3987 /* Write the operator interfaces. */
3988 mio_lparen ();
3989
3990 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3991 {
3992 if (i == INTRINSIC_USER)
3993 continue;
3994
af30f793
PB		 3995 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
3996 gfc_current_ns->default_access)
6de9cd9a
DN		 3997 ? &gfc_current_ns->operator[i] : NULL);
3998 }
3999
4000 mio_rparen ();
4001 write_char ('\n');
4002 write_char ('\n');
4003
4004 mio_lparen ();
4005 gfc_traverse_user_op (gfc_current_ns, write_operator);
4006 mio_rparen ();
4007 write_char ('\n');
4008 write_char ('\n');
4009
4010 mio_lparen ();
4011 gfc_traverse_ns (gfc_current_ns, write_generic);
4012 mio_rparen ();
4013 write_char ('\n');
4014 write_char ('\n');
4015
9056bd70 4016 mio_lparen ();
30aabb86 4017 write_blank_common ();
9056bd70
TS		 4018 write_common (gfc_current_ns->common_root);
4019 mio_rparen ();
4020 write_char ('\n');
4021 write_char ('\n');
4022
edf1eac2
SK		 4023 mio_lparen ();
4024 write_equiv ();
4025 mio_rparen ();
4026 write_char ('\n');
4027 write_char ('\n');
30aabb86 4028
6de9cd9a
DN		 4029 /* Write symbol information. First we traverse all symbols in the
4030 primary namespace, writing those that need to be written.
4031 Sometimes writing one symbol will cause another to need to be
4032 written. A list of these symbols ends up on the write stack, and
4033 we end by popping the bottom of the stack and writing the symbol
4034 until the stack is empty. */
4035
4036 mio_lparen ();
4037
4038 write_symbol0 (gfc_current_ns->sym_root);
4039 while (write_symbol1 (pi_root));
4040
4041 mio_rparen ();
4042
4043 write_char ('\n');
4044 write_char ('\n');
4045
4046 mio_lparen ();
9056bd70 4047 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
6de9cd9a
DN		 4048 mio_rparen ();
4049}
4050
4051
1e9ecf6d
FXC		 4052/* Read a MD5 sum from the header of a module file. If the file cannot
4053 be opened, or we have any other error, we return -1. */
4054
4055static int
4056read_md5_from_module_file (const char * filename, unsigned char md5[16])
4057{
4058 FILE *file;
4059 char buf[1024];
4060 int n;
4061
4062 /* Open the file. */
4063 if ((file = fopen (filename, "r")) == NULL)
4064 return -1;
4065
4066 /* Read two lines. */
4067 if (fgets (buf, sizeof (buf) - 1, file) == NULL
4068 || fgets (buf, sizeof (buf) - 1, file) == NULL)
4069 {
4070 fclose (file);
4071 return -1;
4072 }
4073
4074 /* Close the file. */
4075 fclose (file);
4076
4077 /* If the header is not what we expect, or is too short, bail out. */
4078 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4079 return -1;
4080
4081 /* Now, we have a real MD5, read it into the array. */
4082 for (n = 0; n < 16; n++)
4083 {
4084 unsigned int x;
4085
4086 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4087 return -1;
4088
4089 md5[n] = x;
4090 }
4091
4092 return 0;
4093}
4094
66e4ab31 4095
6de9cd9a
DN		 4096/* Given module, dump it to disk. If there was an error while
4097 processing the module, dump_flag will be set to zero and we delete
4098 the module file, even if it was already there. */
4099
4100void
4101gfc_dump_module (const char *name, int dump_flag)
4102{
200cfbe7 4103 int n;
1e9ecf6d 4104 char *filename, *filename_tmp, *p;
6de9cd9a 4105 time_t now;
1e9ecf6d
FXC		 4106 fpos_t md5_pos;
4107 unsigned char md5_new[16], md5_old[16];
6de9cd9a 4108
200cfbe7 4109 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6de9cd9a 4110 if (gfc_option.module_dir != NULL)
200cfbe7 4111 {
1e9ecf6d
FXC		 4112 n += strlen (gfc_option.module_dir);
4113 filename = (char *) alloca (n);
200cfbe7
SK		 4114 strcpy (filename, gfc_option.module_dir);
4115 strcat (filename, name);
4116 }
4117 else
4118 {
4119 filename = (char *) alloca (n);
4120 strcpy (filename, name);
4121 }
6de9cd9a
DN		 4122 strcat (filename, MODULE_EXTENSION);
4123
1e9ecf6d
FXC		 4124 /* Name of the temporary file used to write the module. */
4125 filename_tmp = (char *) alloca (n + 1);
4126 strcpy (filename_tmp, filename);
4127 strcat (filename_tmp, "0");
4128
4129 /* There was an error while processing the module. We delete the
4130 module file, even if it was already there. */
6de9cd9a
DN		 4131 if (!dump_flag)
4132 {
4133 unlink (filename);
4134 return;
4135 }
4136
1e9ecf6d
FXC		 4137 /* Write the module to the temporary file. */
4138 module_fp = fopen (filename_tmp, "w");
6de9cd9a 4139 if (module_fp == NULL)
87bdc5f8 4140 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
1e9ecf6d 4141 filename_tmp, strerror (errno));
6de9cd9a 4142
1e9ecf6d 4143 /* Write the header, including space reserved for the MD5 sum. */
6de9cd9a
DN		 4144 now = time (NULL);
4145 p = ctime (&now);
4146
4147 *strchr (p, '\n') = '\0';
4148
1e9ecf6d 4149 fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
d4fa05b9 4150 gfc_source_file, p);
1e9ecf6d
FXC		 4151 fgetpos (module_fp, &md5_pos);
4152 fputs ("00000000000000000000000000000000 -- "
66e4ab31 4153 "If you edit this, you'll get what you deserve.\n\n", module_fp);
6de9cd9a 4154
1e9ecf6d
FXC		 4155 /* Initialize the MD5 context that will be used for output. */
4156 md5_init_ctx (&ctx);
4157
4158 /* Write the module itself. */
6de9cd9a
DN		 4159 iomode = IO_OUTPUT;
4160 strcpy (module_name, name);
4161
4162 init_pi_tree ();
4163
4164 write_module ();
4165
4166 free_pi_tree (pi_root);
4167 pi_root = NULL;
4168
4169 write_char ('\n');
4170
1e9ecf6d
FXC		 4171 /* Write the MD5 sum to the header of the module file. */
4172 md5_finish_ctx (&ctx, md5_new);
4173 fsetpos (module_fp, &md5_pos);
4174 for (n = 0; n < 16; n++)
4175 fprintf (module_fp, "%02x", md5_new[n]);
4176
6de9cd9a
DN		 4177 if (fclose (module_fp))
4178 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
1e9ecf6d
FXC		 4179 filename_tmp, strerror (errno));
4180
4181 /* Read the MD5 from the header of the old module file and compare. */
4182 if (read_md5_from_module_file (filename, md5_old) != 0
4183 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4184 {
4185 /* Module file have changed, replace the old one. */
4186 unlink (filename);
4187 rename (filename_tmp, filename);
4188 }
4189 else
4190 unlink (filename_tmp);
6de9cd9a
DN		 4191}
4192
4193
a8b3b0b6
CR		 4194static void
4195sort_iso_c_rename_list (void)
4196{
4197 gfc_use_rename *tmp_list = NULL;
4198 gfc_use_rename *curr;
4199 gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4200 int c_kind;
4201 int i;
4202
4203 for (curr = gfc_rename_list; curr; curr = curr->next)
4204 {
4205 c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4206 if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4207 {
4208 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4209 "intrinsic module ISO_C_BINDING.", curr->use_name,
4210 &curr->where);
4211 }
4212 else
4213 /* Put it in the list. */
4214 kinds_used[c_kind] = curr;
4215 }
4216
4217 /* Make a new (sorted) rename list. */
4218 i = 0;
4219 while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4220 i++;
4221
4222 if (i < ISOCBINDING_NUMBER)
4223 {
4224 tmp_list = kinds_used[i];
4225
4226 i++;
4227 curr = tmp_list;
4228 for (; i < ISOCBINDING_NUMBER; i++)
4229 if (kinds_used[i] != NULL)
4230 {
4231 curr->next = kinds_used[i];
4232 curr = curr->next;
4233 curr->next = NULL;
4234 }
4235 }
4236
4237 gfc_rename_list = tmp_list;
4238}
4239
4240
4241/* Import the instrinsic ISO_C_BINDING module, generating symbols in
4242 the current namespace for all named constants, pointer types, and
4243 procedures in the module unless the only clause was used or a rename
4244 list was provided. */
4245
4246static void
4247import_iso_c_binding_module (void)
4248{
4249 gfc_symbol *mod_sym = NULL;
4250 gfc_symtree *mod_symtree = NULL;
4251 const char *iso_c_module_name = "__iso_c_binding";
4252 gfc_use_rename *u;
4253 int i;
4254 char *local_name;
4255
4256 /* Look only in the current namespace. */
4257 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4258
4259 if (mod_symtree == NULL)
4260 {
4261 /* symtree doesn't already exist in current namespace. */
4262 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4263
4264 if (mod_symtree != NULL)
4265 mod_sym = mod_symtree->n.sym;
4266 else
4267 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4268 "create symbol for %s", iso_c_module_name);
4269
4270 mod_sym->attr.flavor = FL_MODULE;
4271 mod_sym->attr.intrinsic = 1;
4272 mod_sym->module = gfc_get_string (iso_c_module_name);
4273 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4274 }
4275
4276 /* Generate the symbols for the named constants representing
4277 the kinds for intrinsic data types. */
4278 if (only_flag)
4279 {
4280 /* Sort the rename list because there are dependencies between types
4281 and procedures (e.g., c_loc needs c_ptr). */
4282 sort_iso_c_rename_list ();
4283
4284 for (u = gfc_rename_list; u; u = u->next)
4285 {
4286 i = get_c_kind (u->use_name, c_interop_kinds_table);
4287
4288 if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4289 {
4290 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4291 "intrinsic module ISO_C_BINDING.", u->use_name,
4292 &u->where);
4293 continue;
4294 }
4295
4296 generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4297 }
4298 }
4299 else
4300 {
4301 for (i = 0; i < ISOCBINDING_NUMBER; i++)
4302 {
4303 local_name = NULL;
4304 for (u = gfc_rename_list; u; u = u->next)
4305 {
4306 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4307 {
4308 local_name = u->local_name;
4309 u->found = 1;
4310 break;
4311 }
4312 }
4313 generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4314 }
4315
4316 for (u = gfc_rename_list; u; u = u->next)
4317 {
4318 if (u->found)
4319 continue;
4320
4321 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4322 "module ISO_C_BINDING", u->use_name, &u->where);
4323 }
4324 }
4325}
4326
4327
39f87c03 4328/* Add an integer named constant from a given module. */
a8b3b0b6 4329
39f87c03 4330static void
a8b3b0b6
CR		 4331create_int_parameter (const char *name, int value, const char *modname,
4332 intmod_id module, int id)
39f87c03 4333{
edf1eac2
SK		 4334 gfc_symtree *tmp_symtree;
4335 gfc_symbol *sym;
39f87c03
FXC		 4336
4337 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4338 if (tmp_symtree != NULL)
4339 {
4340 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4341 return;
4342 else
4343 gfc_error ("Symbol '%s' already declared", name);
4344 }
4345
4346 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4347 sym = tmp_symtree->n.sym;
4348
4349 sym->module = gfc_get_string (modname);
4350 sym->attr.flavor = FL_PARAMETER;
4351 sym->ts.type = BT_INTEGER;
4352 sym->ts.kind = gfc_default_integer_kind;
4353 sym->value = gfc_int_expr (value);
4354 sym->attr.use_assoc = 1;
a8b3b0b6
CR		 4355 sym->from_intmod = module;
4356 sym->intmod_sym_id = id;
39f87c03
FXC		 4357}
4358
edf1eac2 4359
39f87c03 4360/* USE the ISO_FORTRAN_ENV intrinsic module. */
edf1eac2 4361
39f87c03
FXC		 4362static void
4363use_iso_fortran_env_module (void)
4364{
4365 static char mod[] = "iso_fortran_env";
4366 const char *local_name;
4367 gfc_use_rename *u;
4368 gfc_symbol *mod_sym;
4369 gfc_symtree *mod_symtree;
4370 int i;
4371
a8b3b0b6
CR		 4372 intmod_sym symbol[] = {
4373#define NAMED_INTCST(a,b,c) { a, b, 0 },
39f87c03
FXC		 4374#include "iso-fortran-env.def"
4375#undef NAMED_INTCST
a8b3b0b6 4376 { ISOFORTRANENV_INVALID, NULL, -1234 } };
39f87c03
FXC		 4377
4378 i = 0;
a8b3b0b6 4379#define NAMED_INTCST(a,b,c) symbol[i++].value = c;
39f87c03
FXC		 4380#include "iso-fortran-env.def"
4381#undef NAMED_INTCST
4382
4383 /* Generate the symbol for the module itself. */
4384 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4385 if (mod_symtree == NULL)
4386 {
4387 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4388 gcc_assert (mod_symtree);
4389 mod_sym = mod_symtree->n.sym;
4390
4391 mod_sym->attr.flavor = FL_MODULE;
4392 mod_sym->attr.intrinsic = 1;
4393 mod_sym->module = gfc_get_string (mod);
a8b3b0b6 4394 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
39f87c03
FXC		 4395 }
4396 else
4397 if (!mod_symtree->n.sym->attr.intrinsic)
4398 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4399 "non-intrinsic module name used previously", mod);
4400
4401 /* Generate the symbols for the module integer named constants. */
4402 if (only_flag)
4403 for (u = gfc_rename_list; u; u = u->next)
4404 {
a8b3b0b6
CR		 4405 for (i = 0; symbol[i].name; i++)
4406 if (strcmp (symbol[i].name, u->use_name) == 0)
39f87c03
FXC		 4407 break;
4408
a8b3b0b6 4409 if (symbol[i].name == NULL)
39f87c03
FXC		 4410 {
4411 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4412 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4413 &u->where);
4414 continue;
4415 }
4416
4417 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
a8b3b0b6 4418 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
39f87c03
FXC		 4419 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4420 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4421 "incompatible with option %s", &u->where,
4422 gfc_option.flag_default_integer
4423 ? "-fdefault-integer-8" : "-fdefault-real-8");
4424
4425 create_int_parameter (u->local_name[0] ? u->local_name
a8b3b0b6
CR		 4426 : symbol[i].name,
4427 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4428 symbol[i].id);
39f87c03
FXC		 4429 }
4430 else
4431 {
a8b3b0b6 4432 for (i = 0; symbol[i].name; i++)
39f87c03
FXC		 4433 {
4434 local_name = NULL;
4435 for (u = gfc_rename_list; u; u = u->next)
4436 {
a8b3b0b6 4437 if (strcmp (symbol[i].name, u->use_name) == 0)
39f87c03
FXC		 4438 {
4439 local_name = u->local_name;
4440 u->found = 1;
4441 break;
4442 }
4443 }
4444
4445 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
a8b3b0b6 4446 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
39f87c03
FXC		 4447 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4448 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4449 "incompatible with option %s",
4450 gfc_option.flag_default_integer
4451 ? "-fdefault-integer-8" : "-fdefault-real-8");
4452
a8b3b0b6
CR		 4453 create_int_parameter (local_name ? local_name : symbol[i].name,
4454 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4455 symbol[i].id);
39f87c03
FXC		 4456 }
4457
4458 for (u = gfc_rename_list; u; u = u->next)
4459 {
4460 if (u->found)
4461 continue;
4462
4463 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4464 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4465 }
4466 }
4467}
4468
edf1eac2 4469
6de9cd9a
DN		 4470/* Process a USE directive. */
4471
4472void
4473gfc_use_module (void)
4474{
200cfbe7 4475 char *filename;
6de9cd9a 4476 gfc_state_data *p;
982186b1 4477 int c, line, start;
39f87c03 4478 gfc_symtree *mod_symtree;
6de9cd9a 4479
edf1eac2
SK		 4480 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4481 + 1);
6de9cd9a
DN		 4482 strcpy (filename, module_name);
4483 strcat (filename, MODULE_EXTENSION);
4484
31198773
FXC		 4485 /* First, try to find an non-intrinsic module, unless the USE statement
4486 specified that the module is intrinsic. */
4487 module_fp = NULL;
4488 if (!specified_int)
4489 module_fp = gfc_open_included_file (filename, true, true);
4490
4491 /* Then, see if it's an intrinsic one, unless the USE statement
4492 specified that the module is non-intrinsic. */
4493 if (module_fp == NULL && !specified_nonint)
4494 {
31198773 4495 if (strcmp (module_name, "iso_fortran_env") == 0
edf1eac2
SK		 4496 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4497 "intrinsic module at %C") != FAILURE)
31198773 4498 {
edf1eac2
SK		 4499 use_iso_fortran_env_module ();
4500 return;
31198773 4501 }
31198773 4502
a8b3b0b6
CR		 4503 if (strcmp (module_name, "iso_c_binding") == 0
4504 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4505 "ISO_C_BINDING module at %C") != FAILURE)
4506 {
4507 import_iso_c_binding_module();
4508 return;
4509 }
4510
31198773
FXC		 4511 module_fp = gfc_open_intrinsic_module (filename);
4512
4513 if (module_fp == NULL && specified_int)
a8b3b0b6
CR		 4514 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4515 module_name);
31198773
FXC		 4516 }
4517
6de9cd9a 4518 if (module_fp == NULL)
87bdc5f8 4519 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6de9cd9a
DN		 4520 filename, strerror (errno));
4521
39f87c03
FXC		 4522 /* Check that we haven't already USEd an intrinsic module with the
4523 same name. */
4524
4525 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4526 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4527 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4528 "intrinsic module name used previously", module_name);
4529
6de9cd9a
DN		 4530 iomode = IO_INPUT;
4531 module_line = 1;
4532 module_column = 1;
982186b1 4533 start = 0;
6de9cd9a 4534
982186b1
PT		 4535 /* Skip the first two lines of the module, after checking that this is
4536 a gfortran module file. */
6de9cd9a
DN		 4537 line = 0;
4538 while (line < 2)
4539 {
4540 c = module_char ();
4541 if (c == EOF)
4542 bad_module ("Unexpected end of module");
982186b1
PT		 4543 if (start++ < 2)
4544 parse_name (c);
4545 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
edf1eac2 4546 || (start == 2 && strcmp (atom_name, " module") != 0))
982186b1 4547 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
edf1eac2 4548 "file", filename);
982186b1 4549
6de9cd9a
DN		 4550 if (c == '\n')
4551 line++;
4552 }
4553
4554 /* Make sure we're not reading the same module that we may be building. */
4555 for (p = gfc_state_stack; p; p = p->previous)
4556 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4557 gfc_fatal_error ("Can't USE the same module we're building!");
4558
4559 init_pi_tree ();
4560 init_true_name_tree ();
4561
4562 read_module ();
4563
4564 free_true_name (true_name_root);
4565 true_name_root = NULL;
4566
4567 free_pi_tree (pi_root);
4568 pi_root = NULL;
4569
4570 fclose (module_fp);
4571}
4572
4573
4574void
4575gfc_module_init_2 (void)
4576{
6de9cd9a
DN		 4577 last_atom = ATOM_LPAREN;
4578}
4579
4580
4581void
4582gfc_module_done_2 (void)
4583{
6de9cd9a
DN		 4584 free_rename ();
4585}
GNU Compiler Collection
This page took 1.362474 seconds and 5 git commands to generate.