1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2013 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 sequence of atoms, which can be left or right parenthesis, names,
24 integers or strings. Parenthesis are always matched which allows
25 us to skip over sections at high speed without having to know
26 anything about the internal structure of the lists. A "name" is
27 usually a fortran 95 identifier, but can also start with '@' in
28 order to reference a hidden symbol.
29
30 The first line of a module is an informational message about what
31 created the module, the file it came from and when it was created.
32 The second line is a warning for people not to edit the module.
33 The rest of the module looks like:
34
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
37 ...
38 )
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
40 ...
41 )
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
43 ...
44 )
45 ( ( <common name> <symbol> <saved flag>)
46 ...
47 )
48
49 ( equivalence list )
50
51 ( <Symbol Number (in no particular order)>
52 <True name of symbol>
53 <Module name of symbol>
54 ( <symbol information> )
55 ...
56 )
57 ( <Symtree name>
58 <Ambiguous flag>
59 <Symbol number>
60 ...
61 )
62
63 In general, symbols refer to other symbols by their symbol number,
64 which are zero based. Symbols are written to the module in no
65 particular order. */
66
67 #include "config.h"
68 #include "system.h"
69 #include "coretypes.h"
70 #include "gfortran.h"
71 #include "arith.h"
72 #include "match.h"
73 #include "parse.h" /* FIXME */
74 #include "md5.h"
75 #include "constructor.h"
76 #include "cpp.h"
77 #include "tree.h"
78
79 #define MODULE_EXTENSION ".mod"
80
81 /* Don't put any single quote (') in MOD_VERSION,
82 if yout want it to be recognized. */
83 #define MOD_VERSION "10"
84
85
86 /* Structure that describes a position within a module file. */
87
88 typedef struct
89 {
90 int column, line;
91 fpos_t pos;
92 }
93 module_locus;
94
95 /* Structure for list of symbols of intrinsic modules. */
96 typedef struct
97 {
98 int id;
99 const char *name;
100 int value;
101 int standard;
102 }
103 intmod_sym;
104
105
106 typedef enum
107 {
108 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
109 }
110 pointer_t;
111
112 /* The fixup structure lists pointers to pointers that have to
113 be updated when a pointer value becomes known. */
114
115 typedef struct fixup_t
116 {
117 void **pointer;
118 struct fixup_t *next;
119 }
120 fixup_t;
121
122
123 /* Structure for holding extra info needed for pointers being read. */
124
125 enum gfc_rsym_state
126 {
127 UNUSED,
128 NEEDED,
129 USED
130 };
131
132 enum gfc_wsym_state
133 {
134 UNREFERENCED = 0,
135 NEEDS_WRITE,
136 WRITTEN
137 };
138
139 typedef struct pointer_info
140 {
141 BBT_HEADER (pointer_info);
142 int integer;
143 pointer_t type;
144
145 /* The first component of each member of the union is the pointer
146 being stored. */
147
148 fixup_t *fixup;
149
150 union
151 {
152 void *pointer; /* Member for doing pointer searches. */
153
154 struct
155 {
156 gfc_symbol *sym;
157 char *true_name, *module, *binding_label;
158 fixup_t *stfixup;
159 gfc_symtree *symtree;
160 enum gfc_rsym_state state;
161 int ns, referenced, renamed;
162 module_locus where;
163 }
164 rsym;
165
166 struct
167 {
168 gfc_symbol *sym;
169 enum gfc_wsym_state state;
170 }
171 wsym;
172 }
173 u;
174
175 }
176 pointer_info;
177
178 #define gfc_get_pointer_info() XCNEW (pointer_info)
179
180
181 /* Local variables */
182
183 /* The FILE for the module we're reading or writing. */
184 static FILE *module_fp;
185
186 /* MD5 context structure. */
187 static struct md5_ctx ctx;
188
189 /* The name of the module we're reading (USE'ing) or writing. */
190 static const char *module_name;
191 static gfc_use_list *module_list;
192
193 static int module_line, module_column, only_flag;
194 static int prev_module_line, prev_module_column, prev_character;
195
196 static enum
197 { IO_INPUT, IO_OUTPUT }
198 iomode;
199
200 static gfc_use_rename *gfc_rename_list;
201 static pointer_info *pi_root;
202 static int symbol_number; /* Counter for assigning symbol numbers */
203
204 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
205 static bool in_load_equiv;
206
207
208
209 /*****************************************************************/
210
211 /* Pointer/integer conversion. Pointers between structures are stored
212 as integers in the module file. The next couple of subroutines
213 handle this translation for reading and writing. */
214
215 /* Recursively free the tree of pointer structures. */
216
217 static void
free_pi_tree(pointer_info * p)218 free_pi_tree (pointer_info *p)
219 {
220 if (p == NULL)
221 return;
222
223 if (p->fixup != NULL)
224 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
225
226 free_pi_tree (p->left);
227 free_pi_tree (p->right);
228
229 if (iomode == IO_INPUT)
230 {
231 XDELETEVEC (p->u.rsym.true_name);
232 XDELETEVEC (p->u.rsym.module);
233 XDELETEVEC (p->u.rsym.binding_label);
234 }
235
236 free (p);
237 }
238
239
240 /* Compare pointers when searching by pointer. Used when writing a
241 module. */
242
243 static int
compare_pointers(void * _sn1,void * _sn2)244 compare_pointers (void *_sn1, void *_sn2)
245 {
246 pointer_info *sn1, *sn2;
247
248 sn1 = (pointer_info *) _sn1;
249 sn2 = (pointer_info *) _sn2;
250
251 if (sn1->u.pointer < sn2->u.pointer)
252 return -1;
253 if (sn1->u.pointer > sn2->u.pointer)
254 return 1;
255
256 return 0;
257 }
258
259
260 /* Compare integers when searching by integer. Used when reading a
261 module. */
262
263 static int
compare_integers(void * _sn1,void * _sn2)264 compare_integers (void *_sn1, void *_sn2)
265 {
266 pointer_info *sn1, *sn2;
267
268 sn1 = (pointer_info *) _sn1;
269 sn2 = (pointer_info *) _sn2;
270
271 if (sn1->integer < sn2->integer)
272 return -1;
273 if (sn1->integer > sn2->integer)
274 return 1;
275
276 return 0;
277 }
278
279
280 /* Initialize the pointer_info tree. */
281
282 static void
init_pi_tree(void)283 init_pi_tree (void)
284 {
285 compare_fn compare;
286 pointer_info *p;
287
288 pi_root = NULL;
289 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
290
291 /* Pointer 0 is the NULL pointer. */
292 p = gfc_get_pointer_info ();
293 p->u.pointer = NULL;
294 p->integer = 0;
295 p->type = P_OTHER;
296
297 gfc_insert_bbt (&pi_root, p, compare);
298
299 /* Pointer 1 is the current namespace. */
300 p = gfc_get_pointer_info ();
301 p->u.pointer = gfc_current_ns;
302 p->integer = 1;
303 p->type = P_NAMESPACE;
304
305 gfc_insert_bbt (&pi_root, p, compare);
306
307 symbol_number = 2;
308 }
309
310
311 /* During module writing, call here with a pointer to something,
312 returning the pointer_info node. */
313
314 static pointer_info *
find_pointer(void * gp)315 find_pointer (void *gp)
316 {
317 pointer_info *p;
318
319 p = pi_root;
320 while (p != NULL)
321 {
322 if (p->u.pointer == gp)
323 break;
324 p = (gp < p->u.pointer) ? p->left : p->right;
325 }
326
327 return p;
328 }
329
330
331 /* Given a pointer while writing, returns the pointer_info tree node,
332 creating it if it doesn't exist. */
333
334 static pointer_info *
get_pointer(void * gp)335 get_pointer (void *gp)
336 {
337 pointer_info *p;
338
339 p = find_pointer (gp);
340 if (p != NULL)
341 return p;
342
343 /* Pointer doesn't have an integer. Give it one. */
344 p = gfc_get_pointer_info ();
345
346 p->u.pointer = gp;
347 p->integer = symbol_number++;
348
349 gfc_insert_bbt (&pi_root, p, compare_pointers);
350
351 return p;
352 }
353
354
355 /* Given an integer during reading, find it in the pointer_info tree,
356 creating the node if not found. */
357
358 static pointer_info *
get_integer(int integer)359 get_integer (int integer)
360 {
361 pointer_info *p, t;
362 int c;
363
364 t.integer = integer;
365
366 p = pi_root;
367 while (p != NULL)
368 {
369 c = compare_integers (&t, p);
370 if (c == 0)
371 break;
372
373 p = (c < 0) ? p->left : p->right;
374 }
375
376 if (p != NULL)
377 return p;
378
379 p = gfc_get_pointer_info ();
380 p->integer = integer;
381 p->u.pointer = NULL;
382
383 gfc_insert_bbt (&pi_root, p, compare_integers);
384
385 return p;
386 }
387
388
389 /* Resolve any fixups using a known pointer. */
390
391 static void
resolve_fixups(fixup_t * f,void * gp)392 resolve_fixups (fixup_t *f, void *gp)
393 {
394 fixup_t *next;
395
396 for (; f; f = next)
397 {
398 next = f->next;
399 *(f->pointer) = gp;
400 free (f);
401 }
402 }
403
404
405 /* Convert a string such that it starts with a lower-case character. Used
406 to convert the symtree name of a derived-type to the symbol name or to
407 the name of the associated generic function. */
408
409 static const char *
dt_lower_string(const char * name)410 dt_lower_string (const char *name)
411 {
412 if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
413 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
414 &name[1]);
415 return gfc_get_string (name);
416 }
417
418
419 /* Convert a string such that it starts with an upper-case character. Used to
420 return the symtree-name for a derived type; the symbol name itself and the
421 symtree/symbol name of the associated generic function start with a lower-
422 case character. */
423
424 static const char *
dt_upper_string(const char * name)425 dt_upper_string (const char *name)
426 {
427 if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
428 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
429 &name[1]);
430 return gfc_get_string (name);
431 }
432
433 /* Call here during module reading when we know what pointer to
434 associate with an integer. Any fixups that exist are resolved at
435 this time. */
436
437 static void
associate_integer_pointer(pointer_info * p,void * gp)438 associate_integer_pointer (pointer_info *p, void *gp)
439 {
440 if (p->u.pointer != NULL)
441 gfc_internal_error ("associate_integer_pointer(): Already associated");
442
443 p->u.pointer = gp;
444
445 resolve_fixups (p->fixup, gp);
446
447 p->fixup = NULL;
448 }
449
450
451 /* During module reading, given an integer and a pointer to a pointer,
452 either store the pointer from an already-known value or create a
453 fixup structure in order to store things later. Returns zero if
454 the reference has been actually stored, or nonzero if the reference
455 must be fixed later (i.e., associate_integer_pointer must be called
456 sometime later. Returns the pointer_info structure. */
457
458 static pointer_info *
add_fixup(int integer,void * gp)459 add_fixup (int integer, void *gp)
460 {
461 pointer_info *p;
462 fixup_t *f;
463 char **cp;
464
465 p = get_integer (integer);
466
467 if (p->integer == 0 || p->u.pointer != NULL)
468 {
469 cp = (char **) gp;
470 *cp = (char *) p->u.pointer;
471 }
472 else
473 {
474 f = XCNEW (fixup_t);
475
476 f->next = p->fixup;
477 p->fixup = f;
478
479 f->pointer = (void **) gp;
480 }
481
482 return p;
483 }
484
485
486 /*****************************************************************/
487
488 /* Parser related subroutines */
489
490 /* Free the rename list left behind by a USE statement. */
491
492 static void
free_rename(gfc_use_rename * list)493 free_rename (gfc_use_rename *list)
494 {
495 gfc_use_rename *next;
496
497 for (; list; list = next)
498 {
499 next = list->next;
500 free (list);
501 }
502 }
503
504
505 /* Match a USE statement. */
506
507 match
gfc_match_use(void)508 gfc_match_use (void)
509 {
510 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
511 gfc_use_rename *tail = NULL, *new_use;
512 interface_type type, type2;
513 gfc_intrinsic_op op;
514 match m;
515 gfc_use_list *use_list;
516
517 use_list = gfc_get_use_list ();
518
519 if (gfc_match (" , ") == MATCH_YES)
520 {
521 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
522 {
523 if (gfc_notify_std (GFC_STD_F2003, "module "
524 "nature in USE statement at %C") == FAILURE)
525 goto cleanup;
526
527 if (strcmp (module_nature, "intrinsic") == 0)
528 use_list->intrinsic = true;
529 else
530 {
531 if (strcmp (module_nature, "non_intrinsic") == 0)
532 use_list->non_intrinsic = true;
533 else
534 {
535 gfc_error ("Module nature in USE statement at %C shall "
536 "be either INTRINSIC or NON_INTRINSIC");
537 goto cleanup;
538 }
539 }
540 }
541 else
542 {
543 /* Help output a better error message than "Unclassifiable
544 statement". */
545 gfc_match (" %n", module_nature);
546 if (strcmp (module_nature, "intrinsic") == 0
547 || strcmp (module_nature, "non_intrinsic") == 0)
548 gfc_error ("\"::\" was expected after module nature at %C "
549 "but was not found");
550 free (use_list);
551 return m;
552 }
553 }
554 else
555 {
556 m = gfc_match (" ::");
557 if (m == MATCH_YES &&
558 gfc_notify_std (GFC_STD_F2003,
559 "\"USE :: module\" at %C") == FAILURE)
560 goto cleanup;
561
562 if (m != MATCH_YES)
563 {
564 m = gfc_match ("% ");
565 if (m != MATCH_YES)
566 {
567 free (use_list);
568 return m;
569 }
570 }
571 }
572
573 use_list->where = gfc_current_locus;
574
575 m = gfc_match_name (name);
576 if (m != MATCH_YES)
577 {
578 free (use_list);
579 return m;
580 }
581
582 use_list->module_name = gfc_get_string (name);
583
584 if (gfc_match_eos () == MATCH_YES)
585 goto done;
586
587 if (gfc_match_char (',') != MATCH_YES)
588 goto syntax;
589
590 if (gfc_match (" only :") == MATCH_YES)
591 use_list->only_flag = true;
592
593 if (gfc_match_eos () == MATCH_YES)
594 goto done;
595
596 for (;;)
597 {
598 /* Get a new rename struct and add it to the rename list. */
599 new_use = gfc_get_use_rename ();
600 new_use->where = gfc_current_locus;
601 new_use->found = 0;
602
603 if (use_list->rename == NULL)
604 use_list->rename = new_use;
605 else
606 tail->next = new_use;
607 tail = new_use;
608
609 /* See what kind of interface we're dealing with. Assume it is
610 not an operator. */
611 new_use->op = INTRINSIC_NONE;
612 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
613 goto cleanup;
614
615 switch (type)
616 {
617 case INTERFACE_NAMELESS:
618 gfc_error ("Missing generic specification in USE statement at %C");
619 goto cleanup;
620
621 case INTERFACE_USER_OP:
622 case INTERFACE_GENERIC:
623 m = gfc_match (" =>");
624
625 if (type == INTERFACE_USER_OP && m == MATCH_YES
626 && (gfc_notify_std (GFC_STD_F2003, "Renaming "
627 "operators in USE statements at %C")
628 == FAILURE))
629 goto cleanup;
630
631 if (type == INTERFACE_USER_OP)
632 new_use->op = INTRINSIC_USER;
633
634 if (use_list->only_flag)
635 {
636 if (m != MATCH_YES)
637 strcpy (new_use->use_name, name);
638 else
639 {
640 strcpy (new_use->local_name, name);
641 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
642 if (type != type2)
643 goto syntax;
644 if (m == MATCH_NO)
645 goto syntax;
646 if (m == MATCH_ERROR)
647 goto cleanup;
648 }
649 }
650 else
651 {
652 if (m != MATCH_YES)
653 goto syntax;
654 strcpy (new_use->local_name, name);
655
656 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
657 if (type != type2)
658 goto syntax;
659 if (m == MATCH_NO)
660 goto syntax;
661 if (m == MATCH_ERROR)
662 goto cleanup;
663 }
664
665 if (strcmp (new_use->use_name, use_list->module_name) == 0
666 || strcmp (new_use->local_name, use_list->module_name) == 0)
667 {
668 gfc_error ("The name '%s' at %C has already been used as "
669 "an external module name.", use_list->module_name);
670 goto cleanup;
671 }
672 break;
673
674 case INTERFACE_INTRINSIC_OP:
675 new_use->op = op;
676 break;
677
678 default:
679 gcc_unreachable ();
680 }
681
682 if (gfc_match_eos () == MATCH_YES)
683 break;
684 if (gfc_match_char (',') != MATCH_YES)
685 goto syntax;
686 }
687
688 done:
689 if (module_list)
690 {
691 gfc_use_list *last = module_list;
692 while (last->next)
693 last = last->next;
694 last->next = use_list;
695 }
696 else
697 module_list = use_list;
698
699 return MATCH_YES;
700
701 syntax:
702 gfc_syntax_error (ST_USE);
703
704 cleanup:
705 free_rename (use_list->rename);
706 free (use_list);
707 return MATCH_ERROR;
708 }
709
710
711 /* Given a name and a number, inst, return the inst name
712 under which to load this symbol. Returns NULL if this
713 symbol shouldn't be loaded. If inst is zero, returns
714 the number of instances of this name. If interface is
715 true, a user-defined operator is sought, otherwise only
716 non-operators are sought. */
717
718 static const char *
find_use_name_n(const char * name,int * inst,bool interface)719 find_use_name_n (const char *name, int *inst, bool interface)
720 {
721 gfc_use_rename *u;
722 const char *low_name = NULL;
723 int i;
724
725 /* For derived types. */
726 if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
727 low_name = dt_lower_string (name);
728
729 i = 0;
730 for (u = gfc_rename_list; u; u = u->next)
731 {
732 if ((!low_name && strcmp (u->use_name, name) != 0)
733 || (low_name && strcmp (u->use_name, low_name) != 0)
734 || (u->op == INTRINSIC_USER && !interface)
735 || (u->op != INTRINSIC_USER && interface))
736 continue;
737 if (++i == *inst)
738 break;
739 }
740
741 if (!*inst)
742 {
743 *inst = i;
744 return NULL;
745 }
746
747 if (u == NULL)
748 return only_flag ? NULL : name;
749
750 u->found = 1;
751
752 if (low_name)
753 {
754 if (u->local_name[0] == '\0')
755 return name;
756 return dt_upper_string (u->local_name);
757 }
758
759 return (u->local_name[0] != '\0') ? u->local_name : name;
760 }
761
762
763 /* Given a name, return the name under which to load this symbol.
764 Returns NULL if this symbol shouldn't be loaded. */
765
766 static const char *
find_use_name(const char * name,bool interface)767 find_use_name (const char *name, bool interface)
768 {
769 int i = 1;
770 return find_use_name_n (name, &i, interface);
771 }
772
773
774 /* Given a real name, return the number of use names associated with it. */
775
776 static int
number_use_names(const char * name,bool interface)777 number_use_names (const char *name, bool interface)
778 {
779 int i = 0;
780 find_use_name_n (name, &i, interface);
781 return i;
782 }
783
784
785 /* Try to find the operator in the current list. */
786
787 static gfc_use_rename *
find_use_operator(gfc_intrinsic_op op)788 find_use_operator (gfc_intrinsic_op op)
789 {
790 gfc_use_rename *u;
791
792 for (u = gfc_rename_list; u; u = u->next)
793 if (u->op == op)
794 return u;
795
796 return NULL;
797 }
798
799
800 /*****************************************************************/
801
802 /* The next couple of subroutines maintain a tree used to avoid a
803 brute-force search for a combination of true name and module name.
804 While symtree names, the name that a particular symbol is known by
805 can changed with USE statements, we still have to keep track of the
806 true names to generate the correct reference, and also avoid
807 loading the same real symbol twice in a program unit.
808
809 When we start reading, the true name tree is built and maintained
810 as symbols are read. The tree is searched as we load new symbols
811 to see if it already exists someplace in the namespace. */
812
813 typedef struct true_name
814 {
815 BBT_HEADER (true_name);
816 const char *name;
817 gfc_symbol *sym;
818 }
819 true_name;
820
821 static true_name *true_name_root;
822
823
824 /* Compare two true_name structures. */
825
826 static int
compare_true_names(void * _t1,void * _t2)827 compare_true_names (void *_t1, void *_t2)
828 {
829 true_name *t1, *t2;
830 int c;
831
832 t1 = (true_name *) _t1;
833 t2 = (true_name *) _t2;
834
835 c = ((t1->sym->module > t2->sym->module)
836 - (t1->sym->module < t2->sym->module));
837 if (c != 0)
838 return c;
839
840 return strcmp (t1->name, t2->name);
841 }
842
843
844 /* Given a true name, search the true name tree to see if it exists
845 within the main namespace. */
846
847 static gfc_symbol *
find_true_name(const char * name,const char * module)848 find_true_name (const char *name, const char *module)
849 {
850 true_name t, *p;
851 gfc_symbol sym;
852 int c;
853
854 t.name = gfc_get_string (name);
855 if (module != NULL)
856 sym.module = gfc_get_string (module);
857 else
858 sym.module = NULL;
859 t.sym = &sym;
860
861 p = true_name_root;
862 while (p != NULL)
863 {
864 c = compare_true_names ((void *) (&t), (void *) p);
865 if (c == 0)
866 return p->sym;
867
868 p = (c < 0) ? p->left : p->right;
869 }
870
871 return NULL;
872 }
873
874
875 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
876
877 static void
add_true_name(gfc_symbol * sym)878 add_true_name (gfc_symbol *sym)
879 {
880 true_name *t;
881
882 t = XCNEW (true_name);
883 t->sym = sym;
884 if (sym->attr.flavor == FL_DERIVED)
885 t->name = dt_upper_string (sym->name);
886 else
887 t->name = sym->name;
888
889 gfc_insert_bbt (&true_name_root, t, compare_true_names);
890 }
891
892
893 /* Recursive function to build the initial true name tree by
894 recursively traversing the current namespace. */
895
896 static void
build_tnt(gfc_symtree * st)897 build_tnt (gfc_symtree *st)
898 {
899 const char *name;
900 if (st == NULL)
901 return;
902
903 build_tnt (st->left);
904 build_tnt (st->right);
905
906 if (st->n.sym->attr.flavor == FL_DERIVED)
907 name = dt_upper_string (st->n.sym->name);
908 else
909 name = st->n.sym->name;
910
911 if (find_true_name (name, st->n.sym->module) != NULL)
912 return;
913
914 add_true_name (st->n.sym);
915 }
916
917
918 /* Initialize the true name tree with the current namespace. */
919
920 static void
init_true_name_tree(void)921 init_true_name_tree (void)
922 {
923 true_name_root = NULL;
924 build_tnt (gfc_current_ns->sym_root);
925 }
926
927
928 /* Recursively free a true name tree node. */
929
930 static void
free_true_name(true_name * t)931 free_true_name (true_name *t)
932 {
933 if (t == NULL)
934 return;
935 free_true_name (t->left);
936 free_true_name (t->right);
937
938 free (t);
939 }
940
941
942 /*****************************************************************/
943
944 /* Module reading and writing. */
945
946 typedef enum
947 {
948 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
949 }
950 atom_type;
951
952 static atom_type last_atom;
953
954
955 /* The name buffer must be at least as long as a symbol name. Right
956 now it's not clear how we're going to store numeric constants--
957 probably as a hexadecimal string, since this will allow the exact
958 number to be preserved (this can't be done by a decimal
959 representation). Worry about that later. TODO! */
960
961 #define MAX_ATOM_SIZE 100
962
963 static int atom_int;
964 static char *atom_string, atom_name[MAX_ATOM_SIZE];
965
966
967 /* Report problems with a module. Error reporting is not very
968 elaborate, since this sorts of errors shouldn't really happen.
969 This subroutine never returns. */
970
971 static void bad_module (const char *) ATTRIBUTE_NORETURN;
972
973 static void
bad_module(const char * msgid)974 bad_module (const char *msgid)
975 {
976 fclose (module_fp);
977
978 switch (iomode)
979 {
980 case IO_INPUT:
981 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
982 module_name, module_line, module_column, msgid);
983 break;
984 case IO_OUTPUT:
985 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
986 module_name, module_line, module_column, msgid);
987 break;
988 default:
989 gfc_fatal_error ("Module %s at line %d column %d: %s",
990 module_name, module_line, module_column, msgid);
991 break;
992 }
993 }
994
995
996 /* Set the module's input pointer. */
997
998 static void
set_module_locus(module_locus * m)999 set_module_locus (module_locus *m)
1000 {
1001 module_column = m->column;
1002 module_line = m->line;
1003 fsetpos (module_fp, &m->pos);
1004 }
1005
1006
1007 /* Get the module's input pointer so that we can restore it later. */
1008
1009 static void
get_module_locus(module_locus * m)1010 get_module_locus (module_locus *m)
1011 {
1012 m->column = module_column;
1013 m->line = module_line;
1014 fgetpos (module_fp, &m->pos);
1015 }
1016
1017
1018 /* Get the next character in the module, updating our reckoning of
1019 where we are. */
1020
1021 static int
module_char(void)1022 module_char (void)
1023 {
1024 int c;
1025
1026 c = getc (module_fp);
1027
1028 if (c == EOF)
1029 bad_module ("Unexpected EOF");
1030
1031 prev_module_line = module_line;
1032 prev_module_column = module_column;
1033 prev_character = c;
1034
1035 if (c == '\n')
1036 {
1037 module_line++;
1038 module_column = 0;
1039 }
1040
1041 module_column++;
1042 return c;
1043 }
1044
1045 /* Unget a character while remembering the line and column. Works for
1046 a single character only. */
1047
1048 static void
module_unget_char(void)1049 module_unget_char (void)
1050 {
1051 module_line = prev_module_line;
1052 module_column = prev_module_column;
1053 ungetc (prev_character, module_fp);
1054 }
1055
1056 /* Parse a string constant. The delimiter is guaranteed to be a
1057 single quote. */
1058
1059 static void
parse_string(void)1060 parse_string (void)
1061 {
1062 int c;
1063 size_t cursz = 30;
1064 size_t len = 0;
1065
1066 atom_string = XNEWVEC (char, cursz);
1067
1068 for ( ; ; )
1069 {
1070 c = module_char ();
1071
1072 if (c == '\'')
1073 {
1074 int c2 = module_char ();
1075 if (c2 != '\'')
1076 {
1077 module_unget_char ();
1078 break;
1079 }
1080 }
1081
1082 if (len >= cursz)
1083 {
1084 cursz *= 2;
1085 atom_string = XRESIZEVEC (char, atom_string, cursz);
1086 }
1087 atom_string[len] = c;
1088 len++;
1089 }
1090
1091 atom_string = XRESIZEVEC (char, atom_string, len + 1);
1092 atom_string[len] = '\0'; /* C-style string for debug purposes. */
1093 }
1094
1095
1096 /* Parse a small integer. */
1097
1098 static void
parse_integer(int c)1099 parse_integer (int c)
1100 {
1101 atom_int = c - '0';
1102
1103 for (;;)
1104 {
1105 c = module_char ();
1106 if (!ISDIGIT (c))
1107 {
1108 module_unget_char ();
1109 break;
1110 }
1111
1112 atom_int = 10 * atom_int + c - '0';
1113 if (atom_int > 99999999)
1114 bad_module ("Integer overflow");
1115 }
1116
1117 }
1118
1119
1120 /* Parse a name. */
1121
1122 static void
parse_name(int c)1123 parse_name (int c)
1124 {
1125 char *p;
1126 int len;
1127
1128 p = atom_name;
1129
1130 *p++ = c;
1131 len = 1;
1132
1133 for (;;)
1134 {
1135 c = module_char ();
1136 if (!ISALNUM (c) && c != '_' && c != '-')
1137 {
1138 module_unget_char ();
1139 break;
1140 }
1141
1142 *p++ = c;
1143 if (++len > GFC_MAX_SYMBOL_LEN)
1144 bad_module ("Name too long");
1145 }
1146
1147 *p = '\0';
1148
1149 }
1150
1151
1152 /* Read the next atom in the module's input stream. */
1153
1154 static atom_type
parse_atom(void)1155 parse_atom (void)
1156 {
1157 int c;
1158
1159 do
1160 {
1161 c = module_char ();
1162 }
1163 while (c == ' ' || c == '\r' || c == '\n');
1164
1165 switch (c)
1166 {
1167 case '(':
1168 return ATOM_LPAREN;
1169
1170 case ')':
1171 return ATOM_RPAREN;
1172
1173 case '\'':
1174 parse_string ();
1175 return ATOM_STRING;
1176
1177 case '0':
1178 case '1':
1179 case '2':
1180 case '3':
1181 case '4':
1182 case '5':
1183 case '6':
1184 case '7':
1185 case '8':
1186 case '9':
1187 parse_integer (c);
1188 return ATOM_INTEGER;
1189
1190 case 'a':
1191 case 'b':
1192 case 'c':
1193 case 'd':
1194 case 'e':
1195 case 'f':
1196 case 'g':
1197 case 'h':
1198 case 'i':
1199 case 'j':
1200 case 'k':
1201 case 'l':
1202 case 'm':
1203 case 'n':
1204 case 'o':
1205 case 'p':
1206 case 'q':
1207 case 'r':
1208 case 's':
1209 case 't':
1210 case 'u':
1211 case 'v':
1212 case 'w':
1213 case 'x':
1214 case 'y':
1215 case 'z':
1216 case 'A':
1217 case 'B':
1218 case 'C':
1219 case 'D':
1220 case 'E':
1221 case 'F':
1222 case 'G':
1223 case 'H':
1224 case 'I':
1225 case 'J':
1226 case 'K':
1227 case 'L':
1228 case 'M':
1229 case 'N':
1230 case 'O':
1231 case 'P':
1232 case 'Q':
1233 case 'R':
1234 case 'S':
1235 case 'T':
1236 case 'U':
1237 case 'V':
1238 case 'W':
1239 case 'X':
1240 case 'Y':
1241 case 'Z':
1242 parse_name (c);
1243 return ATOM_NAME;
1244
1245 default:
1246 bad_module ("Bad name");
1247 }
1248
1249 /* Not reached. */
1250 }
1251
1252
1253 /* Peek at the next atom on the input. */
1254
1255 static atom_type
peek_atom(void)1256 peek_atom (void)
1257 {
1258 int c;
1259
1260 do
1261 {
1262 c = module_char ();
1263 }
1264 while (c == ' ' || c == '\r' || c == '\n');
1265
1266 switch (c)
1267 {
1268 case '(':
1269 module_unget_char ();
1270 return ATOM_LPAREN;
1271
1272 case ')':
1273 module_unget_char ();
1274 return ATOM_RPAREN;
1275
1276 case '\'':
1277 module_unget_char ();
1278 return ATOM_STRING;
1279
1280 case '0':
1281 case '1':
1282 case '2':
1283 case '3':
1284 case '4':
1285 case '5':
1286 case '6':
1287 case '7':
1288 case '8':
1289 case '9':
1290 module_unget_char ();
1291 return ATOM_INTEGER;
1292
1293 case 'a':
1294 case 'b':
1295 case 'c':
1296 case 'd':
1297 case 'e':
1298 case 'f':
1299 case 'g':
1300 case 'h':
1301 case 'i':
1302 case 'j':
1303 case 'k':
1304 case 'l':
1305 case 'm':
1306 case 'n':
1307 case 'o':
1308 case 'p':
1309 case 'q':
1310 case 'r':
1311 case 's':
1312 case 't':
1313 case 'u':
1314 case 'v':
1315 case 'w':
1316 case 'x':
1317 case 'y':
1318 case 'z':
1319 case 'A':
1320 case 'B':
1321 case 'C':
1322 case 'D':
1323 case 'E':
1324 case 'F':
1325 case 'G':
1326 case 'H':
1327 case 'I':
1328 case 'J':
1329 case 'K':
1330 case 'L':
1331 case 'M':
1332 case 'N':
1333 case 'O':
1334 case 'P':
1335 case 'Q':
1336 case 'R':
1337 case 'S':
1338 case 'T':
1339 case 'U':
1340 case 'V':
1341 case 'W':
1342 case 'X':
1343 case 'Y':
1344 case 'Z':
1345 module_unget_char ();
1346 return ATOM_NAME;
1347
1348 default:
1349 bad_module ("Bad name");
1350 }
1351 }
1352
1353
1354 /* Read the next atom from the input, requiring that it be a
1355 particular kind. */
1356
1357 static void
require_atom(atom_type type)1358 require_atom (atom_type type)
1359 {
1360 atom_type t;
1361 const char *p;
1362 int column, line;
1363
1364 column = module_column;
1365 line = module_line;
1366
1367 t = parse_atom ();
1368 if (t != type)
1369 {
1370 switch (type)
1371 {
1372 case ATOM_NAME:
1373 p = _("Expected name");
1374 break;
1375 case ATOM_LPAREN:
1376 p = _("Expected left parenthesis");
1377 break;
1378 case ATOM_RPAREN:
1379 p = _("Expected right parenthesis");
1380 break;
1381 case ATOM_INTEGER:
1382 p = _("Expected integer");
1383 break;
1384 case ATOM_STRING:
1385 p = _("Expected string");
1386 break;
1387 default:
1388 gfc_internal_error ("require_atom(): bad atom type required");
1389 }
1390
1391 module_column = column;
1392 module_line = line;
1393 bad_module (p);
1394 }
1395 }
1396
1397
1398 /* Given a pointer to an mstring array, require that the current input
1399 be one of the strings in the array. We return the enum value. */
1400
1401 static int
find_enum(const mstring * m)1402 find_enum (const mstring *m)
1403 {
1404 int i;
1405
1406 i = gfc_string2code (m, atom_name);
1407 if (i >= 0)
1408 return i;
1409
1410 bad_module ("find_enum(): Enum not found");
1411
1412 /* Not reached. */
1413 }
1414
1415
1416 /* Read a string. The caller is responsible for freeing. */
1417
1418 static char*
read_string(void)1419 read_string (void)
1420 {
1421 char* p;
1422 require_atom (ATOM_STRING);
1423 p = atom_string;
1424 atom_string = NULL;
1425 return p;
1426 }
1427
1428
1429 /**************** Module output subroutines ***************************/
1430
1431 /* Output a character to a module file. */
1432
1433 static void
write_char(char out)1434 write_char (char out)
1435 {
1436 if (putc (out, module_fp) == EOF)
1437 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1438
1439 /* Add this to our MD5. */
1440 md5_process_bytes (&out, sizeof (out), &ctx);
1441
1442 if (out != '\n')
1443 module_column++;
1444 else
1445 {
1446 module_column = 1;
1447 module_line++;
1448 }
1449 }
1450
1451
1452 /* Write an atom to a module. The line wrapping isn't perfect, but it
1453 should work most of the time. This isn't that big of a deal, since
1454 the file really isn't meant to be read by people anyway. */
1455
1456 static void
write_atom(atom_type atom,const void * v)1457 write_atom (atom_type atom, const void *v)
1458 {
1459 char buffer[20];
1460 int i, len;
1461 const char *p;
1462
1463 switch (atom)
1464 {
1465 case ATOM_STRING:
1466 case ATOM_NAME:
1467 p = (const char *) v;
1468 break;
1469
1470 case ATOM_LPAREN:
1471 p = "(";
1472 break;
1473
1474 case ATOM_RPAREN:
1475 p = ")";
1476 break;
1477
1478 case ATOM_INTEGER:
1479 i = *((const int *) v);
1480 if (i < 0)
1481 gfc_internal_error ("write_atom(): Writing negative integer");
1482
1483 sprintf (buffer, "%d", i);
1484 p = buffer;
1485 break;
1486
1487 default:
1488 gfc_internal_error ("write_atom(): Trying to write dab atom");
1489
1490 }
1491
1492 if(p == NULL || *p == '\0')
1493 len = 0;
1494 else
1495 len = strlen (p);
1496
1497 if (atom != ATOM_RPAREN)
1498 {
1499 if (module_column + len > 72)
1500 write_char ('\n');
1501 else
1502 {
1503
1504 if (last_atom != ATOM_LPAREN && module_column != 1)
1505 write_char (' ');
1506 }
1507 }
1508
1509 if (atom == ATOM_STRING)
1510 write_char ('\'');
1511
1512 while (p != NULL && *p)
1513 {
1514 if (atom == ATOM_STRING && *p == '\'')
1515 write_char ('\'');
1516 write_char (*p++);
1517 }
1518
1519 if (atom == ATOM_STRING)
1520 write_char ('\'');
1521
1522 last_atom = atom;
1523 }
1524
1525
1526
1527 /***************** Mid-level I/O subroutines *****************/
1528
1529 /* These subroutines let their caller read or write atoms without
1530 caring about which of the two is actually happening. This lets a
1531 subroutine concentrate on the actual format of the data being
1532 written. */
1533
1534 static void mio_expr (gfc_expr **);
1535 pointer_info *mio_symbol_ref (gfc_symbol **);
1536 pointer_info *mio_interface_rest (gfc_interface **);
1537 static void mio_symtree_ref (gfc_symtree **);
1538
1539 /* Read or write an enumerated value. On writing, we return the input
1540 value for the convenience of callers. We avoid using an integer
1541 pointer because enums are sometimes inside bitfields. */
1542
1543 static int
mio_name(int t,const mstring * m)1544 mio_name (int t, const mstring *m)
1545 {
1546 if (iomode == IO_OUTPUT)
1547 write_atom (ATOM_NAME, gfc_code2string (m, t));
1548 else
1549 {
1550 require_atom (ATOM_NAME);
1551 t = find_enum (m);
1552 }
1553
1554 return t;
1555 }
1556
1557 /* Specialization of mio_name. */
1558
1559 #define DECL_MIO_NAME(TYPE) \
1560 static inline TYPE \
1561 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1562 { \
1563 return (TYPE) mio_name ((int) t, m); \
1564 }
1565 #define MIO_NAME(TYPE) mio_name_##TYPE
1566
1567 static void
mio_lparen(void)1568 mio_lparen (void)
1569 {
1570 if (iomode == IO_OUTPUT)
1571 write_atom (ATOM_LPAREN, NULL);
1572 else
1573 require_atom (ATOM_LPAREN);
1574 }
1575
1576
1577 static void
mio_rparen(void)1578 mio_rparen (void)
1579 {
1580 if (iomode == IO_OUTPUT)
1581 write_atom (ATOM_RPAREN, NULL);
1582 else
1583 require_atom (ATOM_RPAREN);
1584 }
1585
1586
1587 static void
mio_integer(int * ip)1588 mio_integer (int *ip)
1589 {
1590 if (iomode == IO_OUTPUT)
1591 write_atom (ATOM_INTEGER, ip);
1592 else
1593 {
1594 require_atom (ATOM_INTEGER);
1595 *ip = atom_int;
1596 }
1597 }
1598
1599
1600 /* Read or write a gfc_intrinsic_op value. */
1601
1602 static void
mio_intrinsic_op(gfc_intrinsic_op * op)1603 mio_intrinsic_op (gfc_intrinsic_op* op)
1604 {
1605 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1606 if (iomode == IO_OUTPUT)
1607 {
1608 int converted = (int) *op;
1609 write_atom (ATOM_INTEGER, &converted);
1610 }
1611 else
1612 {
1613 require_atom (ATOM_INTEGER);
1614 *op = (gfc_intrinsic_op) atom_int;
1615 }
1616 }
1617
1618
1619 /* Read or write a character pointer that points to a string on the heap. */
1620
1621 static const char *
mio_allocated_string(const char * s)1622 mio_allocated_string (const char *s)
1623 {
1624 if (iomode == IO_OUTPUT)
1625 {
1626 write_atom (ATOM_STRING, s);
1627 return s;
1628 }
1629 else
1630 {
1631 require_atom (ATOM_STRING);
1632 return atom_string;
1633 }
1634 }
1635
1636
1637 /* Functions for quoting and unquoting strings. */
1638
1639 static char *
quote_string(const gfc_char_t * s,const size_t slength)1640 quote_string (const gfc_char_t *s, const size_t slength)
1641 {
1642 const gfc_char_t *p;
1643 char *res, *q;
1644 size_t len = 0, i;
1645
1646 /* Calculate the length we'll need: a backslash takes two ("\\"),
1647 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1648 for (p = s, i = 0; i < slength; p++, i++)
1649 {
1650 if (*p == '\\')
1651 len += 2;
1652 else if (!gfc_wide_is_printable (*p))
1653 len += 10;
1654 else
1655 len++;
1656 }
1657
1658 q = res = XCNEWVEC (char, len + 1);
1659 for (p = s, i = 0; i < slength; p++, i++)
1660 {
1661 if (*p == '\\')
1662 *q++ = '\\', *q++ = '\\';
1663 else if (!gfc_wide_is_printable (*p))
1664 {
1665 sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1666 (unsigned HOST_WIDE_INT) *p);
1667 q += 10;
1668 }
1669 else
1670 *q++ = (unsigned char) *p;
1671 }
1672
1673 res[len] = '\0';
1674 return res;
1675 }
1676
1677 static gfc_char_t *
unquote_string(const char * s)1678 unquote_string (const char *s)
1679 {
1680 size_t len, i;
1681 const char *p;
1682 gfc_char_t *res;
1683
1684 for (p = s, len = 0; *p; p++, len++)
1685 {
1686 if (*p != '\\')
1687 continue;
1688
1689 if (p[1] == '\\')
1690 p++;
1691 else if (p[1] == 'U')
1692 p += 9; /* That is a "\U????????". */
1693 else
1694 gfc_internal_error ("unquote_string(): got bad string");
1695 }
1696
1697 res = gfc_get_wide_string (len + 1);
1698 for (i = 0, p = s; i < len; i++, p++)
1699 {
1700 gcc_assert (*p);
1701
1702 if (*p != '\\')
1703 res[i] = (unsigned char) *p;
1704 else if (p[1] == '\\')
1705 {
1706 res[i] = (unsigned char) '\\';
1707 p++;
1708 }
1709 else
1710 {
1711 /* We read the 8-digits hexadecimal constant that follows. */
1712 int j;
1713 unsigned n;
1714 gfc_char_t c = 0;
1715
1716 gcc_assert (p[1] == 'U');
1717 for (j = 0; j < 8; j++)
1718 {
1719 c = c << 4;
1720 gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1721 c += n;
1722 }
1723
1724 res[i] = c;
1725 p += 9;
1726 }
1727 }
1728
1729 res[len] = '\0';
1730 return res;
1731 }
1732
1733
1734 /* Read or write a character pointer that points to a wide string on the
1735 heap, performing quoting/unquoting of nonprintable characters using the
1736 form \U???????? (where each ? is a hexadecimal digit).
1737 Length is the length of the string, only known and used in output mode. */
1738
1739 static const gfc_char_t *
mio_allocated_wide_string(const gfc_char_t * s,const size_t length)1740 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1741 {
1742 if (iomode == IO_OUTPUT)
1743 {
1744 char *quoted = quote_string (s, length);
1745 write_atom (ATOM_STRING, quoted);
1746 free (quoted);
1747 return s;
1748 }
1749 else
1750 {
1751 gfc_char_t *unquoted;
1752
1753 require_atom (ATOM_STRING);
1754 unquoted = unquote_string (atom_string);
1755 free (atom_string);
1756 return unquoted;
1757 }
1758 }
1759
1760
1761 /* Read or write a string that is in static memory. */
1762
1763 static void
mio_pool_string(const char ** stringp)1764 mio_pool_string (const char **stringp)
1765 {
1766 /* TODO: one could write the string only once, and refer to it via a
1767 fixup pointer. */
1768
1769 /* As a special case we have to deal with a NULL string. This
1770 happens for the 'module' member of 'gfc_symbol's that are not in a
1771 module. We read / write these as the empty string. */
1772 if (iomode == IO_OUTPUT)
1773 {
1774 const char *p = *stringp == NULL ? "" : *stringp;
1775 write_atom (ATOM_STRING, p);
1776 }
1777 else
1778 {
1779 require_atom (ATOM_STRING);
1780 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1781 free (atom_string);
1782 }
1783 }
1784
1785
1786 /* Read or write a string that is inside of some already-allocated
1787 structure. */
1788
1789 static void
mio_internal_string(char * string)1790 mio_internal_string (char *string)
1791 {
1792 if (iomode == IO_OUTPUT)
1793 write_atom (ATOM_STRING, string);
1794 else
1795 {
1796 require_atom (ATOM_STRING);
1797 strcpy (string, atom_string);
1798 free (atom_string);
1799 }
1800 }
1801
1802
1803 typedef enum
1804 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1805 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1806 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1807 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1808 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
1809 AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
1810 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
1811 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1812 AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1813 AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
1814 AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY
1815 }
1816 ab_attribute;
1817
1818 static const mstring attr_bits[] =
1819 {
1820 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1821 minit ("ARTIFICIAL", AB_ARTIFICIAL),
1822 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
1823 minit ("DIMENSION", AB_DIMENSION),
1824 minit ("CODIMENSION", AB_CODIMENSION),
1825 minit ("CONTIGUOUS", AB_CONTIGUOUS),
1826 minit ("EXTERNAL", AB_EXTERNAL),
1827 minit ("INTRINSIC", AB_INTRINSIC),
1828 minit ("OPTIONAL", AB_OPTIONAL),
1829 minit ("POINTER", AB_POINTER),
1830 minit ("VOLATILE", AB_VOLATILE),
1831 minit ("TARGET", AB_TARGET),
1832 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1833 minit ("DUMMY", AB_DUMMY),
1834 minit ("RESULT", AB_RESULT),
1835 minit ("DATA", AB_DATA),
1836 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1837 minit ("IN_COMMON", AB_IN_COMMON),
1838 minit ("FUNCTION", AB_FUNCTION),
1839 minit ("SUBROUTINE", AB_SUBROUTINE),
1840 minit ("SEQUENCE", AB_SEQUENCE),
1841 minit ("ELEMENTAL", AB_ELEMENTAL),
1842 minit ("PURE", AB_PURE),
1843 minit ("RECURSIVE", AB_RECURSIVE),
1844 minit ("GENERIC", AB_GENERIC),
1845 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1846 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1847 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1848 minit ("IS_BIND_C", AB_IS_BIND_C),
1849 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1850 minit ("IS_ISO_C", AB_IS_ISO_C),
1851 minit ("VALUE", AB_VALUE),
1852 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1853 minit ("COARRAY_COMP", AB_COARRAY_COMP),
1854 minit ("LOCK_COMP", AB_LOCK_COMP),
1855 minit ("POINTER_COMP", AB_POINTER_COMP),
1856 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
1857 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1858 minit ("ZERO_COMP", AB_ZERO_COMP),
1859 minit ("PROTECTED", AB_PROTECTED),
1860 minit ("ABSTRACT", AB_ABSTRACT),
1861 minit ("IS_CLASS", AB_IS_CLASS),
1862 minit ("PROCEDURE", AB_PROCEDURE),
1863 minit ("PROC_POINTER", AB_PROC_POINTER),
1864 minit ("VTYPE", AB_VTYPE),
1865 minit ("VTAB", AB_VTAB),
1866 minit ("CLASS_POINTER", AB_CLASS_POINTER),
1867 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
1868 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
1869 minit (NULL, -1)
1870 };
1871
1872 /* For binding attributes. */
1873 static const mstring binding_passing[] =
1874 {
1875 minit ("PASS", 0),
1876 minit ("NOPASS", 1),
1877 minit (NULL, -1)
1878 };
1879 static const mstring binding_overriding[] =
1880 {
1881 minit ("OVERRIDABLE", 0),
1882 minit ("NON_OVERRIDABLE", 1),
1883 minit ("DEFERRED", 2),
1884 minit (NULL, -1)
1885 };
1886 static const mstring binding_generic[] =
1887 {
1888 minit ("SPECIFIC", 0),
1889 minit ("GENERIC", 1),
1890 minit (NULL, -1)
1891 };
1892 static const mstring binding_ppc[] =
1893 {
1894 minit ("NO_PPC", 0),
1895 minit ("PPC", 1),
1896 minit (NULL, -1)
1897 };
1898
1899 /* Specialization of mio_name. */
1900 DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME(ar_type)1901 DECL_MIO_NAME (ar_type)
1902 DECL_MIO_NAME (array_type)
1903 DECL_MIO_NAME (bt)
1904 DECL_MIO_NAME (expr_t)
1905 DECL_MIO_NAME (gfc_access)
1906 DECL_MIO_NAME (gfc_intrinsic_op)
1907 DECL_MIO_NAME (ifsrc)
1908 DECL_MIO_NAME (save_state)
1909 DECL_MIO_NAME (procedure_type)
1910 DECL_MIO_NAME (ref_type)
1911 DECL_MIO_NAME (sym_flavor)
1912 DECL_MIO_NAME (sym_intent)
1913 #undef DECL_MIO_NAME
1914
1915 /* Symbol attributes are stored in list with the first three elements
1916 being the enumerated fields, while the remaining elements (if any)
1917 indicate the individual attribute bits. The access field is not
1918 saved-- it controls what symbols are exported when a module is
1919 written. */
1920
1921 static void
1922 mio_symbol_attribute (symbol_attribute *attr)
1923 {
1924 atom_type t;
1925 unsigned ext_attr,extension_level;
1926
1927 mio_lparen ();
1928
1929 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1930 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1931 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1932 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1933 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1934
1935 ext_attr = attr->ext_attr;
1936 mio_integer ((int *) &ext_attr);
1937 attr->ext_attr = ext_attr;
1938
1939 extension_level = attr->extension;
1940 mio_integer ((int *) &extension_level);
1941 attr->extension = extension_level;
1942
1943 if (iomode == IO_OUTPUT)
1944 {
1945 if (attr->allocatable)
1946 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1947 if (attr->artificial)
1948 MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
1949 if (attr->asynchronous)
1950 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
1951 if (attr->dimension)
1952 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1953 if (attr->codimension)
1954 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
1955 if (attr->contiguous)
1956 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
1957 if (attr->external)
1958 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1959 if (attr->intrinsic)
1960 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1961 if (attr->optional)
1962 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1963 if (attr->pointer)
1964 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1965 if (attr->class_pointer)
1966 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
1967 if (attr->is_protected)
1968 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1969 if (attr->value)
1970 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1971 if (attr->volatile_)
1972 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1973 if (attr->target)
1974 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1975 if (attr->threadprivate)
1976 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1977 if (attr->dummy)
1978 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1979 if (attr->result)
1980 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1981 /* We deliberately don't preserve the "entry" flag. */
1982
1983 if (attr->data)
1984 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1985 if (attr->in_namelist)
1986 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1987 if (attr->in_common)
1988 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1989
1990 if (attr->function)
1991 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1992 if (attr->subroutine)
1993 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1994 if (attr->generic)
1995 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1996 if (attr->abstract)
1997 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1998
1999 if (attr->sequence)
2000 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2001 if (attr->elemental)
2002 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2003 if (attr->pure)
2004 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2005 if (attr->implicit_pure)
2006 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2007 if (attr->unlimited_polymorphic)
2008 MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2009 if (attr->recursive)
2010 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2011 if (attr->always_explicit)
2012 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2013 if (attr->cray_pointer)
2014 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2015 if (attr->cray_pointee)
2016 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2017 if (attr->is_bind_c)
2018 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2019 if (attr->is_c_interop)
2020 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2021 if (attr->is_iso_c)
2022 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2023 if (attr->alloc_comp)
2024 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2025 if (attr->pointer_comp)
2026 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2027 if (attr->proc_pointer_comp)
2028 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2029 if (attr->private_comp)
2030 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2031 if (attr->coarray_comp)
2032 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2033 if (attr->lock_comp)
2034 MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2035 if (attr->zero_comp)
2036 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2037 if (attr->is_class)
2038 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2039 if (attr->procedure)
2040 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2041 if (attr->proc_pointer)
2042 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2043 if (attr->vtype)
2044 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2045 if (attr->vtab)
2046 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2047
2048 mio_rparen ();
2049
2050 }
2051 else
2052 {
2053 for (;;)
2054 {
2055 t = parse_atom ();
2056 if (t == ATOM_RPAREN)
2057 break;
2058 if (t != ATOM_NAME)
2059 bad_module ("Expected attribute bit name");
2060
2061 switch ((ab_attribute) find_enum (attr_bits))
2062 {
2063 case AB_ALLOCATABLE:
2064 attr->allocatable = 1;
2065 break;
2066 case AB_ARTIFICIAL:
2067 attr->artificial = 1;
2068 break;
2069 case AB_ASYNCHRONOUS:
2070 attr->asynchronous = 1;
2071 break;
2072 case AB_DIMENSION:
2073 attr->dimension = 1;
2074 break;
2075 case AB_CODIMENSION:
2076 attr->codimension = 1;
2077 break;
2078 case AB_CONTIGUOUS:
2079 attr->contiguous = 1;
2080 break;
2081 case AB_EXTERNAL:
2082 attr->external = 1;
2083 break;
2084 case AB_INTRINSIC:
2085 attr->intrinsic = 1;
2086 break;
2087 case AB_OPTIONAL:
2088 attr->optional = 1;
2089 break;
2090 case AB_POINTER:
2091 attr->pointer = 1;
2092 break;
2093 case AB_CLASS_POINTER:
2094 attr->class_pointer = 1;
2095 break;
2096 case AB_PROTECTED:
2097 attr->is_protected = 1;
2098 break;
2099 case AB_VALUE:
2100 attr->value = 1;
2101 break;
2102 case AB_VOLATILE:
2103 attr->volatile_ = 1;
2104 break;
2105 case AB_TARGET:
2106 attr->target = 1;
2107 break;
2108 case AB_THREADPRIVATE:
2109 attr->threadprivate = 1;
2110 break;
2111 case AB_DUMMY:
2112 attr->dummy = 1;
2113 break;
2114 case AB_RESULT:
2115 attr->result = 1;
2116 break;
2117 case AB_DATA:
2118 attr->data = 1;
2119 break;
2120 case AB_IN_NAMELIST:
2121 attr->in_namelist = 1;
2122 break;
2123 case AB_IN_COMMON:
2124 attr->in_common = 1;
2125 break;
2126 case AB_FUNCTION:
2127 attr->function = 1;
2128 break;
2129 case AB_SUBROUTINE:
2130 attr->subroutine = 1;
2131 break;
2132 case AB_GENERIC:
2133 attr->generic = 1;
2134 break;
2135 case AB_ABSTRACT:
2136 attr->abstract = 1;
2137 break;
2138 case AB_SEQUENCE:
2139 attr->sequence = 1;
2140 break;
2141 case AB_ELEMENTAL:
2142 attr->elemental = 1;
2143 break;
2144 case AB_PURE:
2145 attr->pure = 1;
2146 break;
2147 case AB_IMPLICIT_PURE:
2148 attr->implicit_pure = 1;
2149 break;
2150 case AB_UNLIMITED_POLY:
2151 attr->unlimited_polymorphic = 1;
2152 break;
2153 case AB_RECURSIVE:
2154 attr->recursive = 1;
2155 break;
2156 case AB_ALWAYS_EXPLICIT:
2157 attr->always_explicit = 1;
2158 break;
2159 case AB_CRAY_POINTER:
2160 attr->cray_pointer = 1;
2161 break;
2162 case AB_CRAY_POINTEE:
2163 attr->cray_pointee = 1;
2164 break;
2165 case AB_IS_BIND_C:
2166 attr->is_bind_c = 1;
2167 break;
2168 case AB_IS_C_INTEROP:
2169 attr->is_c_interop = 1;
2170 break;
2171 case AB_IS_ISO_C:
2172 attr->is_iso_c = 1;
2173 break;
2174 case AB_ALLOC_COMP:
2175 attr->alloc_comp = 1;
2176 break;
2177 case AB_COARRAY_COMP:
2178 attr->coarray_comp = 1;
2179 break;
2180 case AB_LOCK_COMP:
2181 attr->lock_comp = 1;
2182 break;
2183 case AB_POINTER_COMP:
2184 attr->pointer_comp = 1;
2185 break;
2186 case AB_PROC_POINTER_COMP:
2187 attr->proc_pointer_comp = 1;
2188 break;
2189 case AB_PRIVATE_COMP:
2190 attr->private_comp = 1;
2191 break;
2192 case AB_ZERO_COMP:
2193 attr->zero_comp = 1;
2194 break;
2195 case AB_IS_CLASS:
2196 attr->is_class = 1;
2197 break;
2198 case AB_PROCEDURE:
2199 attr->procedure = 1;
2200 break;
2201 case AB_PROC_POINTER:
2202 attr->proc_pointer = 1;
2203 break;
2204 case AB_VTYPE:
2205 attr->vtype = 1;
2206 break;
2207 case AB_VTAB:
2208 attr->vtab = 1;
2209 break;
2210 }
2211 }
2212 }
2213 }
2214
2215
2216 static const mstring bt_types[] = {
2217 minit ("INTEGER", BT_INTEGER),
2218 minit ("REAL", BT_REAL),
2219 minit ("COMPLEX", BT_COMPLEX),
2220 minit ("LOGICAL", BT_LOGICAL),
2221 minit ("CHARACTER", BT_CHARACTER),
2222 minit ("DERIVED", BT_DERIVED),
2223 minit ("CLASS", BT_CLASS),
2224 minit ("PROCEDURE", BT_PROCEDURE),
2225 minit ("UNKNOWN", BT_UNKNOWN),
2226 minit ("VOID", BT_VOID),
2227 minit ("ASSUMED", BT_ASSUMED),
2228 minit (NULL, -1)
2229 };
2230
2231
2232 static void
mio_charlen(gfc_charlen ** clp)2233 mio_charlen (gfc_charlen **clp)
2234 {
2235 gfc_charlen *cl;
2236
2237 mio_lparen ();
2238
2239 if (iomode == IO_OUTPUT)
2240 {
2241 cl = *clp;
2242 if (cl != NULL)
2243 mio_expr (&cl->length);
2244 }
2245 else
2246 {
2247 if (peek_atom () != ATOM_RPAREN)
2248 {
2249 cl = gfc_new_charlen (gfc_current_ns, NULL);
2250 mio_expr (&cl->length);
2251 *clp = cl;
2252 }
2253 }
2254
2255 mio_rparen ();
2256 }
2257
2258
2259 /* See if a name is a generated name. */
2260
2261 static int
check_unique_name(const char * name)2262 check_unique_name (const char *name)
2263 {
2264 return *name == '@';
2265 }
2266
2267
2268 static void
mio_typespec(gfc_typespec * ts)2269 mio_typespec (gfc_typespec *ts)
2270 {
2271 mio_lparen ();
2272
2273 ts->type = MIO_NAME (bt) (ts->type, bt_types);
2274
2275 if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
2276 mio_integer (&ts->kind);
2277 else
2278 mio_symbol_ref (&ts->u.derived);
2279
2280 mio_symbol_ref (&ts->interface);
2281
2282 /* Add info for C interop and is_iso_c. */
2283 mio_integer (&ts->is_c_interop);
2284 mio_integer (&ts->is_iso_c);
2285
2286 /* If the typespec is for an identifier either from iso_c_binding, or
2287 a constant that was initialized to an identifier from it, use the
2288 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2289 if (ts->is_iso_c)
2290 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2291 else
2292 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2293
2294 if (ts->type != BT_CHARACTER)
2295 {
2296 /* ts->u.cl is only valid for BT_CHARACTER. */
2297 mio_lparen ();
2298 mio_rparen ();
2299 }
2300 else
2301 mio_charlen (&ts->u.cl);
2302
2303 /* So as not to disturb the existing API, use an ATOM_NAME to
2304 transmit deferred characteristic for characters (F2003). */
2305 if (iomode == IO_OUTPUT)
2306 {
2307 if (ts->type == BT_CHARACTER && ts->deferred)
2308 write_atom (ATOM_NAME, "DEFERRED_CL");
2309 }
2310 else if (peek_atom () != ATOM_RPAREN)
2311 {
2312 if (parse_atom () != ATOM_NAME)
2313 bad_module ("Expected string");
2314 ts->deferred = 1;
2315 }
2316
2317 mio_rparen ();
2318 }
2319
2320
2321 static const mstring array_spec_types[] = {
2322 minit ("EXPLICIT", AS_EXPLICIT),
2323 minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2324 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2325 minit ("DEFERRED", AS_DEFERRED),
2326 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2327 minit (NULL, -1)
2328 };
2329
2330
2331 static void
mio_array_spec(gfc_array_spec ** asp)2332 mio_array_spec (gfc_array_spec **asp)
2333 {
2334 gfc_array_spec *as;
2335 int i;
2336
2337 mio_lparen ();
2338
2339 if (iomode == IO_OUTPUT)
2340 {
2341 int rank;
2342
2343 if (*asp == NULL)
2344 goto done;
2345 as = *asp;
2346
2347 /* mio_integer expects nonnegative values. */
2348 rank = as->rank > 0 ? as->rank : 0;
2349 mio_integer (&rank);
2350 }
2351 else
2352 {
2353 if (peek_atom () == ATOM_RPAREN)
2354 {
2355 *asp = NULL;
2356 goto done;
2357 }
2358
2359 *asp = as = gfc_get_array_spec ();
2360 mio_integer (&as->rank);
2361 }
2362
2363 mio_integer (&as->corank);
2364 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2365
2366 if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2367 as->rank = -1;
2368 if (iomode == IO_INPUT && as->corank)
2369 as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2370
2371 if (as->rank + as->corank > 0)
2372 for (i = 0; i < as->rank + as->corank; i++)
2373 {
2374 mio_expr (&as->lower[i]);
2375 mio_expr (&as->upper[i]);
2376 }
2377
2378 done:
2379 mio_rparen ();
2380 }
2381
2382
2383 /* Given a pointer to an array reference structure (which lives in a
2384 gfc_ref structure), find the corresponding array specification
2385 structure. Storing the pointer in the ref structure doesn't quite
2386 work when loading from a module. Generating code for an array
2387 reference also needs more information than just the array spec. */
2388
2389 static const mstring array_ref_types[] = {
2390 minit ("FULL", AR_FULL),
2391 minit ("ELEMENT", AR_ELEMENT),
2392 minit ("SECTION", AR_SECTION),
2393 minit (NULL, -1)
2394 };
2395
2396
2397 static void
mio_array_ref(gfc_array_ref * ar)2398 mio_array_ref (gfc_array_ref *ar)
2399 {
2400 int i;
2401
2402 mio_lparen ();
2403 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2404 mio_integer (&ar->dimen);
2405
2406 switch (ar->type)
2407 {
2408 case AR_FULL:
2409 break;
2410
2411 case AR_ELEMENT:
2412 for (i = 0; i < ar->dimen; i++)
2413 mio_expr (&ar->start[i]);
2414
2415 break;
2416
2417 case AR_SECTION:
2418 for (i = 0; i < ar->dimen; i++)
2419 {
2420 mio_expr (&ar->start[i]);
2421 mio_expr (&ar->end[i]);
2422 mio_expr (&ar->stride[i]);
2423 }
2424
2425 break;
2426
2427 case AR_UNKNOWN:
2428 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2429 }
2430
2431 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2432 we can't call mio_integer directly. Instead loop over each element
2433 and cast it to/from an integer. */
2434 if (iomode == IO_OUTPUT)
2435 {
2436 for (i = 0; i < ar->dimen; i++)
2437 {
2438 int tmp = (int)ar->dimen_type[i];
2439 write_atom (ATOM_INTEGER, &tmp);
2440 }
2441 }
2442 else
2443 {
2444 for (i = 0; i < ar->dimen; i++)
2445 {
2446 require_atom (ATOM_INTEGER);
2447 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2448 }
2449 }
2450
2451 if (iomode == IO_INPUT)
2452 {
2453 ar->where = gfc_current_locus;
2454
2455 for (i = 0; i < ar->dimen; i++)
2456 ar->c_where[i] = gfc_current_locus;
2457 }
2458
2459 mio_rparen ();
2460 }
2461
2462
2463 /* Saves or restores a pointer. The pointer is converted back and
2464 forth from an integer. We return the pointer_info pointer so that
2465 the caller can take additional action based on the pointer type. */
2466
2467 static pointer_info *
mio_pointer_ref(void * gp)2468 mio_pointer_ref (void *gp)
2469 {
2470 pointer_info *p;
2471
2472 if (iomode == IO_OUTPUT)
2473 {
2474 p = get_pointer (*((char **) gp));
2475 write_atom (ATOM_INTEGER, &p->integer);
2476 }
2477 else
2478 {
2479 require_atom (ATOM_INTEGER);
2480 p = add_fixup (atom_int, gp);
2481 }
2482
2483 return p;
2484 }
2485
2486
2487 /* Save and load references to components that occur within
2488 expressions. We have to describe these references by a number and
2489 by name. The number is necessary for forward references during
2490 reading, and the name is necessary if the symbol already exists in
2491 the namespace and is not loaded again. */
2492
2493 static void
mio_component_ref(gfc_component ** cp)2494 mio_component_ref (gfc_component **cp)
2495 {
2496 pointer_info *p;
2497
2498 p = mio_pointer_ref (cp);
2499 if (p->type == P_UNKNOWN)
2500 p->type = P_COMPONENT;
2501 }
2502
2503
2504 static void mio_namespace_ref (gfc_namespace **nsp);
2505 static void mio_formal_arglist (gfc_formal_arglist **formal);
2506 static void mio_typebound_proc (gfc_typebound_proc** proc);
2507
2508 static void
mio_component(gfc_component * c,int vtype)2509 mio_component (gfc_component *c, int vtype)
2510 {
2511 pointer_info *p;
2512 int n;
2513
2514 mio_lparen ();
2515
2516 if (iomode == IO_OUTPUT)
2517 {
2518 p = get_pointer (c);
2519 mio_integer (&p->integer);
2520 }
2521 else
2522 {
2523 mio_integer (&n);
2524 p = get_integer (n);
2525 associate_integer_pointer (p, c);
2526 }
2527
2528 if (p->type == P_UNKNOWN)
2529 p->type = P_COMPONENT;
2530
2531 mio_pool_string (&c->name);
2532 mio_typespec (&c->ts);
2533 mio_array_spec (&c->as);
2534
2535 mio_symbol_attribute (&c->attr);
2536 if (c->ts.type == BT_CLASS)
2537 c->attr.class_ok = 1;
2538 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2539
2540 if (!vtype || strcmp (c->name, "_final") == 0
2541 || strcmp (c->name, "_hash") == 0)
2542 mio_expr (&c->initializer);
2543
2544 if (c->attr.proc_pointer)
2545 mio_typebound_proc (&c->tb);
2546
2547 mio_rparen ();
2548 }
2549
2550
2551 static void
mio_component_list(gfc_component ** cp,int vtype)2552 mio_component_list (gfc_component **cp, int vtype)
2553 {
2554 gfc_component *c, *tail;
2555
2556 mio_lparen ();
2557
2558 if (iomode == IO_OUTPUT)
2559 {
2560 for (c = *cp; c; c = c->next)
2561 mio_component (c, vtype);
2562 }
2563 else
2564 {
2565 *cp = NULL;
2566 tail = NULL;
2567
2568 for (;;)
2569 {
2570 if (peek_atom () == ATOM_RPAREN)
2571 break;
2572
2573 c = gfc_get_component ();
2574 mio_component (c, vtype);
2575
2576 if (tail == NULL)
2577 *cp = c;
2578 else
2579 tail->next = c;
2580
2581 tail = c;
2582 }
2583 }
2584
2585 mio_rparen ();
2586 }
2587
2588
2589 static void
mio_actual_arg(gfc_actual_arglist * a)2590 mio_actual_arg (gfc_actual_arglist *a)
2591 {
2592 mio_lparen ();
2593 mio_pool_string (&a->name);
2594 mio_expr (&a->expr);
2595 mio_rparen ();
2596 }
2597
2598
2599 static void
mio_actual_arglist(gfc_actual_arglist ** ap)2600 mio_actual_arglist (gfc_actual_arglist **ap)
2601 {
2602 gfc_actual_arglist *a, *tail;
2603
2604 mio_lparen ();
2605
2606 if (iomode == IO_OUTPUT)
2607 {
2608 for (a = *ap; a; a = a->next)
2609 mio_actual_arg (a);
2610
2611 }
2612 else
2613 {
2614 tail = NULL;
2615
2616 for (;;)
2617 {
2618 if (peek_atom () != ATOM_LPAREN)
2619 break;
2620
2621 a = gfc_get_actual_arglist ();
2622
2623 if (tail == NULL)
2624 *ap = a;
2625 else
2626 tail->next = a;
2627
2628 tail = a;
2629 mio_actual_arg (a);
2630 }
2631 }
2632
2633 mio_rparen ();
2634 }
2635
2636
2637 /* Read and write formal argument lists. */
2638
2639 static void
mio_formal_arglist(gfc_formal_arglist ** formal)2640 mio_formal_arglist (gfc_formal_arglist **formal)
2641 {
2642 gfc_formal_arglist *f, *tail;
2643
2644 mio_lparen ();
2645
2646 if (iomode == IO_OUTPUT)
2647 {
2648 for (f = *formal; f; f = f->next)
2649 mio_symbol_ref (&f->sym);
2650 }
2651 else
2652 {
2653 *formal = tail = NULL;
2654
2655 while (peek_atom () != ATOM_RPAREN)
2656 {
2657 f = gfc_get_formal_arglist ();
2658 mio_symbol_ref (&f->sym);
2659
2660 if (*formal == NULL)
2661 *formal = f;
2662 else
2663 tail->next = f;
2664
2665 tail = f;
2666 }
2667 }
2668
2669 mio_rparen ();
2670 }
2671
2672
2673 /* Save or restore a reference to a symbol node. */
2674
2675 pointer_info *
mio_symbol_ref(gfc_symbol ** symp)2676 mio_symbol_ref (gfc_symbol **symp)
2677 {
2678 pointer_info *p;
2679
2680 p = mio_pointer_ref (symp);
2681 if (p->type == P_UNKNOWN)
2682 p->type = P_SYMBOL;
2683
2684 if (iomode == IO_OUTPUT)
2685 {
2686 if (p->u.wsym.state == UNREFERENCED)
2687 p->u.wsym.state = NEEDS_WRITE;
2688 }
2689 else
2690 {
2691 if (p->u.rsym.state == UNUSED)
2692 p->u.rsym.state = NEEDED;
2693 }
2694 return p;
2695 }
2696
2697
2698 /* Save or restore a reference to a symtree node. */
2699
2700 static void
mio_symtree_ref(gfc_symtree ** stp)2701 mio_symtree_ref (gfc_symtree **stp)
2702 {
2703 pointer_info *p;
2704 fixup_t *f;
2705
2706 if (iomode == IO_OUTPUT)
2707 mio_symbol_ref (&(*stp)->n.sym);
2708 else
2709 {
2710 require_atom (ATOM_INTEGER);
2711 p = get_integer (atom_int);
2712
2713 /* An unused equivalence member; make a symbol and a symtree
2714 for it. */
2715 if (in_load_equiv && p->u.rsym.symtree == NULL)
2716 {
2717 /* Since this is not used, it must have a unique name. */
2718 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2719
2720 /* Make the symbol. */
2721 if (p->u.rsym.sym == NULL)
2722 {
2723 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2724 gfc_current_ns);
2725 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2726 }
2727
2728 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2729 p->u.rsym.symtree->n.sym->refs++;
2730 p->u.rsym.referenced = 1;
2731
2732 /* If the symbol is PRIVATE and in COMMON, load_commons will
2733 generate a fixup symbol, which must be associated. */
2734 if (p->fixup)
2735 resolve_fixups (p->fixup, p->u.rsym.sym);
2736 p->fixup = NULL;
2737 }
2738
2739 if (p->type == P_UNKNOWN)
2740 p->type = P_SYMBOL;
2741
2742 if (p->u.rsym.state == UNUSED)
2743 p->u.rsym.state = NEEDED;
2744
2745 if (p->u.rsym.symtree != NULL)
2746 {
2747 *stp = p->u.rsym.symtree;
2748 }
2749 else
2750 {
2751 f = XCNEW (fixup_t);
2752
2753 f->next = p->u.rsym.stfixup;
2754 p->u.rsym.stfixup = f;
2755
2756 f->pointer = (void **) stp;
2757 }
2758 }
2759 }
2760
2761
2762 static void
mio_iterator(gfc_iterator ** ip)2763 mio_iterator (gfc_iterator **ip)
2764 {
2765 gfc_iterator *iter;
2766
2767 mio_lparen ();
2768
2769 if (iomode == IO_OUTPUT)
2770 {
2771 if (*ip == NULL)
2772 goto done;
2773 }
2774 else
2775 {
2776 if (peek_atom () == ATOM_RPAREN)
2777 {
2778 *ip = NULL;
2779 goto done;
2780 }
2781
2782 *ip = gfc_get_iterator ();
2783 }
2784
2785 iter = *ip;
2786
2787 mio_expr (&iter->var);
2788 mio_expr (&iter->start);
2789 mio_expr (&iter->end);
2790 mio_expr (&iter->step);
2791
2792 done:
2793 mio_rparen ();
2794 }
2795
2796
2797 static void
mio_constructor(gfc_constructor_base * cp)2798 mio_constructor (gfc_constructor_base *cp)
2799 {
2800 gfc_constructor *c;
2801
2802 mio_lparen ();
2803
2804 if (iomode == IO_OUTPUT)
2805 {
2806 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
2807 {
2808 mio_lparen ();
2809 mio_expr (&c->expr);
2810 mio_iterator (&c->iterator);
2811 mio_rparen ();
2812 }
2813 }
2814 else
2815 {
2816 while (peek_atom () != ATOM_RPAREN)
2817 {
2818 c = gfc_constructor_append_expr (cp, NULL, NULL);
2819
2820 mio_lparen ();
2821 mio_expr (&c->expr);
2822 mio_iterator (&c->iterator);
2823 mio_rparen ();
2824 }
2825 }
2826
2827 mio_rparen ();
2828 }
2829
2830
2831 static const mstring ref_types[] = {
2832 minit ("ARRAY", REF_ARRAY),
2833 minit ("COMPONENT", REF_COMPONENT),
2834 minit ("SUBSTRING", REF_SUBSTRING),
2835 minit (NULL, -1)
2836 };
2837
2838
2839 static void
mio_ref(gfc_ref ** rp)2840 mio_ref (gfc_ref **rp)
2841 {
2842 gfc_ref *r;
2843
2844 mio_lparen ();
2845
2846 r = *rp;
2847 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2848
2849 switch (r->type)
2850 {
2851 case REF_ARRAY:
2852 mio_array_ref (&r->u.ar);
2853 break;
2854
2855 case REF_COMPONENT:
2856 mio_symbol_ref (&r->u.c.sym);
2857 mio_component_ref (&r->u.c.component);
2858 break;
2859
2860 case REF_SUBSTRING:
2861 mio_expr (&r->u.ss.start);
2862 mio_expr (&r->u.ss.end);
2863 mio_charlen (&r->u.ss.length);
2864 break;
2865 }
2866
2867 mio_rparen ();
2868 }
2869
2870
2871 static void
mio_ref_list(gfc_ref ** rp)2872 mio_ref_list (gfc_ref **rp)
2873 {
2874 gfc_ref *ref, *head, *tail;
2875
2876 mio_lparen ();
2877
2878 if (iomode == IO_OUTPUT)
2879 {
2880 for (ref = *rp; ref; ref = ref->next)
2881 mio_ref (&ref);
2882 }
2883 else
2884 {
2885 head = tail = NULL;
2886
2887 while (peek_atom () != ATOM_RPAREN)
2888 {
2889 if (head == NULL)
2890 head = tail = gfc_get_ref ();
2891 else
2892 {
2893 tail->next = gfc_get_ref ();
2894 tail = tail->next;
2895 }
2896
2897 mio_ref (&tail);
2898 }
2899
2900 *rp = head;
2901 }
2902
2903 mio_rparen ();
2904 }
2905
2906
2907 /* Read and write an integer value. */
2908
2909 static void
mio_gmp_integer(mpz_t * integer)2910 mio_gmp_integer (mpz_t *integer)
2911 {
2912 char *p;
2913
2914 if (iomode == IO_INPUT)
2915 {
2916 if (parse_atom () != ATOM_STRING)
2917 bad_module ("Expected integer string");
2918
2919 mpz_init (*integer);
2920 if (mpz_set_str (*integer, atom_string, 10))
2921 bad_module ("Error converting integer");
2922
2923 free (atom_string);
2924 }
2925 else
2926 {
2927 p = mpz_get_str (NULL, 10, *integer);
2928 write_atom (ATOM_STRING, p);
2929 free (p);
2930 }
2931 }
2932
2933
2934 static void
mio_gmp_real(mpfr_t * real)2935 mio_gmp_real (mpfr_t *real)
2936 {
2937 mp_exp_t exponent;
2938 char *p;
2939
2940 if (iomode == IO_INPUT)
2941 {
2942 if (parse_atom () != ATOM_STRING)
2943 bad_module ("Expected real string");
2944
2945 mpfr_init (*real);
2946 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2947 free (atom_string);
2948 }
2949 else
2950 {
2951 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2952
2953 if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2954 {
2955 write_atom (ATOM_STRING, p);
2956 free (p);
2957 return;
2958 }
2959
2960 atom_string = XCNEWVEC (char, strlen (p) + 20);
2961
2962 sprintf (atom_string, "0.%s@%ld", p, exponent);
2963
2964 /* Fix negative numbers. */
2965 if (atom_string[2] == '-')
2966 {
2967 atom_string[0] = '-';
2968 atom_string[1] = '0';
2969 atom_string[2] = '.';
2970 }
2971
2972 write_atom (ATOM_STRING, atom_string);
2973
2974 free (atom_string);
2975 free (p);
2976 }
2977 }
2978
2979
2980 /* Save and restore the shape of an array constructor. */
2981
2982 static void
mio_shape(mpz_t ** pshape,int rank)2983 mio_shape (mpz_t **pshape, int rank)
2984 {
2985 mpz_t *shape;
2986 atom_type t;
2987 int n;
2988
2989 /* A NULL shape is represented by (). */
2990 mio_lparen ();
2991
2992 if (iomode == IO_OUTPUT)
2993 {
2994 shape = *pshape;
2995 if (!shape)
2996 {
2997 mio_rparen ();
2998 return;
2999 }
3000 }
3001 else
3002 {
3003 t = peek_atom ();
3004 if (t == ATOM_RPAREN)
3005 {
3006 *pshape = NULL;
3007 mio_rparen ();
3008 return;
3009 }
3010
3011 shape = gfc_get_shape (rank);
3012 *pshape = shape;
3013 }
3014
3015 for (n = 0; n < rank; n++)
3016 mio_gmp_integer (&shape[n]);
3017
3018 mio_rparen ();
3019 }
3020
3021
3022 static const mstring expr_types[] = {
3023 minit ("OP", EXPR_OP),
3024 minit ("FUNCTION", EXPR_FUNCTION),
3025 minit ("CONSTANT", EXPR_CONSTANT),
3026 minit ("VARIABLE", EXPR_VARIABLE),
3027 minit ("SUBSTRING", EXPR_SUBSTRING),
3028 minit ("STRUCTURE", EXPR_STRUCTURE),
3029 minit ("ARRAY", EXPR_ARRAY),
3030 minit ("NULL", EXPR_NULL),
3031 minit ("COMPCALL", EXPR_COMPCALL),
3032 minit (NULL, -1)
3033 };
3034
3035 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3036 generic operators, not in expressions. INTRINSIC_USER is also
3037 replaced by the correct function name by the time we see it. */
3038
3039 static const mstring intrinsics[] =
3040 {
3041 minit ("UPLUS", INTRINSIC_UPLUS),
3042 minit ("UMINUS", INTRINSIC_UMINUS),
3043 minit ("PLUS", INTRINSIC_PLUS),
3044 minit ("MINUS", INTRINSIC_MINUS),
3045 minit ("TIMES", INTRINSIC_TIMES),
3046 minit ("DIVIDE", INTRINSIC_DIVIDE),
3047 minit ("POWER", INTRINSIC_POWER),
3048 minit ("CONCAT", INTRINSIC_CONCAT),
3049 minit ("AND", INTRINSIC_AND),
3050 minit ("OR", INTRINSIC_OR),
3051 minit ("EQV", INTRINSIC_EQV),
3052 minit ("NEQV", INTRINSIC_NEQV),
3053 minit ("EQ_SIGN", INTRINSIC_EQ),
3054 minit ("EQ", INTRINSIC_EQ_OS),
3055 minit ("NE_SIGN", INTRINSIC_NE),
3056 minit ("NE", INTRINSIC_NE_OS),
3057 minit ("GT_SIGN", INTRINSIC_GT),
3058 minit ("GT", INTRINSIC_GT_OS),
3059 minit ("GE_SIGN", INTRINSIC_GE),
3060 minit ("GE", INTRINSIC_GE_OS),
3061 minit ("LT_SIGN", INTRINSIC_LT),
3062 minit ("LT", INTRINSIC_LT_OS),
3063 minit ("LE_SIGN", INTRINSIC_LE),
3064 minit ("LE", INTRINSIC_LE_OS),
3065 minit ("NOT", INTRINSIC_NOT),
3066 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3067 minit (NULL, -1)
3068 };
3069
3070
3071 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3072
3073 static void
fix_mio_expr(gfc_expr * e)3074 fix_mio_expr (gfc_expr *e)
3075 {
3076 gfc_symtree *ns_st = NULL;
3077 const char *fname;
3078
3079 if (iomode != IO_OUTPUT)
3080 return;
3081
3082 if (e->symtree)
3083 {
3084 /* If this is a symtree for a symbol that came from a contained module
3085 namespace, it has a unique name and we should look in the current
3086 namespace to see if the required, non-contained symbol is available
3087 yet. If so, the latter should be written. */
3088 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3089 {
3090 const char *name = e->symtree->n.sym->name;
3091 if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
3092 name = dt_upper_string (name);
3093 ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3094 }
3095
3096 /* On the other hand, if the existing symbol is the module name or the
3097 new symbol is a dummy argument, do not do the promotion. */
3098 if (ns_st && ns_st->n.sym
3099 && ns_st->n.sym->attr.flavor != FL_MODULE
3100 && !e->symtree->n.sym->attr.dummy)
3101 e->symtree = ns_st;
3102 }
3103 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
3104 {
3105 gfc_symbol *sym;
3106
3107 /* In some circumstances, a function used in an initialization
3108 expression, in one use associated module, can fail to be
3109 coupled to its symtree when used in a specification
3110 expression in another module. */
3111 fname = e->value.function.esym ? e->value.function.esym->name
3112 : e->value.function.isym->name;
3113 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3114
3115 if (e->symtree)
3116 return;
3117
3118 /* This is probably a reference to a private procedure from another
3119 module. To prevent a segfault, make a generic with no specific
3120 instances. If this module is used, without the required
3121 specific coming from somewhere, the appropriate error message
3122 is issued. */
3123 gfc_get_symbol (fname, gfc_current_ns, &sym);
3124 sym->attr.flavor = FL_PROCEDURE;
3125 sym->attr.generic = 1;
3126 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3127 gfc_commit_symbol (sym);
3128 }
3129 }
3130
3131
3132 /* Read and write expressions. The form "()" is allowed to indicate a
3133 NULL expression. */
3134
3135 static void
mio_expr(gfc_expr ** ep)3136 mio_expr (gfc_expr **ep)
3137 {
3138 gfc_expr *e;
3139 atom_type t;
3140 int flag;
3141
3142 mio_lparen ();
3143
3144 if (iomode == IO_OUTPUT)
3145 {
3146 if (*ep == NULL)
3147 {
3148 mio_rparen ();
3149 return;
3150 }
3151
3152 e = *ep;
3153 MIO_NAME (expr_t) (e->expr_type, expr_types);
3154 }
3155 else
3156 {
3157 t = parse_atom ();
3158 if (t == ATOM_RPAREN)
3159 {
3160 *ep = NULL;
3161 return;
3162 }
3163
3164 if (t != ATOM_NAME)
3165 bad_module ("Expected expression type");
3166
3167 e = *ep = gfc_get_expr ();
3168 e->where = gfc_current_locus;
3169 e->expr_type = (expr_t) find_enum (expr_types);
3170 }
3171
3172 mio_typespec (&e->ts);
3173 mio_integer (&e->rank);
3174
3175 fix_mio_expr (e);
3176
3177 switch (e->expr_type)
3178 {
3179 case EXPR_OP:
3180 e->value.op.op
3181 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3182
3183 switch (e->value.op.op)
3184 {
3185 case INTRINSIC_UPLUS:
3186 case INTRINSIC_UMINUS:
3187 case INTRINSIC_NOT:
3188 case INTRINSIC_PARENTHESES:
3189 mio_expr (&e->value.op.op1);
3190 break;
3191
3192 case INTRINSIC_PLUS:
3193 case INTRINSIC_MINUS:
3194 case INTRINSIC_TIMES:
3195 case INTRINSIC_DIVIDE:
3196 case INTRINSIC_POWER:
3197 case INTRINSIC_CONCAT:
3198 case INTRINSIC_AND:
3199 case INTRINSIC_OR:
3200 case INTRINSIC_EQV:
3201 case INTRINSIC_NEQV:
3202 case INTRINSIC_EQ:
3203 case INTRINSIC_EQ_OS:
3204 case INTRINSIC_NE:
3205 case INTRINSIC_NE_OS:
3206 case INTRINSIC_GT:
3207 case INTRINSIC_GT_OS:
3208 case INTRINSIC_GE:
3209 case INTRINSIC_GE_OS:
3210 case INTRINSIC_LT:
3211 case INTRINSIC_LT_OS:
3212 case INTRINSIC_LE:
3213 case INTRINSIC_LE_OS:
3214 mio_expr (&e->value.op.op1);
3215 mio_expr (&e->value.op.op2);
3216 break;
3217
3218 default:
3219 bad_module ("Bad operator");
3220 }
3221
3222 break;
3223
3224 case EXPR_FUNCTION:
3225 mio_symtree_ref (&e->symtree);
3226 mio_actual_arglist (&e->value.function.actual);
3227
3228 if (iomode == IO_OUTPUT)
3229 {
3230 e->value.function.name
3231 = mio_allocated_string (e->value.function.name);
3232 flag = e->value.function.esym != NULL;
3233 mio_integer (&flag);
3234 if (flag)
3235 mio_symbol_ref (&e->value.function.esym);
3236 else
3237 write_atom (ATOM_STRING, e->value.function.isym->name);
3238 }
3239 else
3240 {
3241 require_atom (ATOM_STRING);
3242 e->value.function.name = gfc_get_string (atom_string);
3243 free (atom_string);
3244
3245 mio_integer (&flag);
3246 if (flag)
3247 mio_symbol_ref (&e->value.function.esym);
3248 else
3249 {
3250 require_atom (ATOM_STRING);
3251 e->value.function.isym = gfc_find_function (atom_string);
3252 free (atom_string);
3253 }
3254 }
3255
3256 break;
3257
3258 case EXPR_VARIABLE:
3259 mio_symtree_ref (&e->symtree);
3260 mio_ref_list (&e->ref);
3261 break;
3262
3263 case EXPR_SUBSTRING:
3264 e->value.character.string
3265 = CONST_CAST (gfc_char_t *,
3266 mio_allocated_wide_string (e->value.character.string,
3267 e->value.character.length));
3268 mio_ref_list (&e->ref);
3269 break;
3270
3271 case EXPR_STRUCTURE:
3272 case EXPR_ARRAY:
3273 mio_constructor (&e->value.constructor);
3274 mio_shape (&e->shape, e->rank);
3275 break;
3276
3277 case EXPR_CONSTANT:
3278 switch (e->ts.type)
3279 {
3280 case BT_INTEGER:
3281 mio_gmp_integer (&e->value.integer);
3282 break;
3283
3284 case BT_REAL:
3285 gfc_set_model_kind (e->ts.kind);
3286 mio_gmp_real (&e->value.real);
3287 break;
3288
3289 case BT_COMPLEX:
3290 gfc_set_model_kind (e->ts.kind);
3291 mio_gmp_real (&mpc_realref (e->value.complex));
3292 mio_gmp_real (&mpc_imagref (e->value.complex));
3293 break;
3294
3295 case BT_LOGICAL:
3296 mio_integer (&e->value.logical);
3297 break;
3298
3299 case BT_CHARACTER:
3300 mio_integer (&e->value.character.length);
3301 e->value.character.string
3302 = CONST_CAST (gfc_char_t *,
3303 mio_allocated_wide_string (e->value.character.string,
3304 e->value.character.length));
3305 break;
3306
3307 default:
3308 bad_module ("Bad type in constant expression");
3309 }
3310
3311 break;
3312
3313 case EXPR_NULL:
3314 break;
3315
3316 case EXPR_COMPCALL:
3317 case EXPR_PPC:
3318 gcc_unreachable ();
3319 break;
3320 }
3321
3322 mio_rparen ();
3323 }
3324
3325
3326 /* Read and write namelists. */
3327
3328 static void
mio_namelist(gfc_symbol * sym)3329 mio_namelist (gfc_symbol *sym)
3330 {
3331 gfc_namelist *n, *m;
3332 const char *check_name;
3333
3334 mio_lparen ();
3335
3336 if (iomode == IO_OUTPUT)
3337 {
3338 for (n = sym->namelist; n; n = n->next)
3339 mio_symbol_ref (&n->sym);
3340 }
3341 else
3342 {
3343 /* This departure from the standard is flagged as an error.
3344 It does, in fact, work correctly. TODO: Allow it
3345 conditionally? */
3346 if (sym->attr.flavor == FL_NAMELIST)
3347 {
3348 check_name = find_use_name (sym->name, false);
3349 if (check_name && strcmp (check_name, sym->name) != 0)
3350 gfc_error ("Namelist %s cannot be renamed by USE "
3351 "association to %s", sym->name, check_name);
3352 }
3353
3354 m = NULL;
3355 while (peek_atom () != ATOM_RPAREN)
3356 {
3357 n = gfc_get_namelist ();
3358 mio_symbol_ref (&n->sym);
3359
3360 if (sym->namelist == NULL)
3361 sym->namelist = n;
3362 else
3363 m->next = n;
3364
3365 m = n;
3366 }
3367 sym->namelist_tail = m;
3368 }
3369
3370 mio_rparen ();
3371 }
3372
3373
3374 /* Save/restore lists of gfc_interface structures. When loading an
3375 interface, we are really appending to the existing list of
3376 interfaces. Checking for duplicate and ambiguous interfaces has to
3377 be done later when all symbols have been loaded. */
3378
3379 pointer_info *
mio_interface_rest(gfc_interface ** ip)3380 mio_interface_rest (gfc_interface **ip)
3381 {
3382 gfc_interface *tail, *p;
3383 pointer_info *pi = NULL;
3384
3385 if (iomode == IO_OUTPUT)
3386 {
3387 if (ip != NULL)
3388 for (p = *ip; p; p = p->next)
3389 mio_symbol_ref (&p->sym);
3390 }
3391 else
3392 {
3393 if (*ip == NULL)
3394 tail = NULL;
3395 else
3396 {
3397 tail = *ip;
3398 while (tail->next)
3399 tail = tail->next;
3400 }
3401
3402 for (;;)
3403 {
3404 if (peek_atom () == ATOM_RPAREN)
3405 break;
3406
3407 p = gfc_get_interface ();
3408 p->where = gfc_current_locus;
3409 pi = mio_symbol_ref (&p->sym);
3410
3411 if (tail == NULL)
3412 *ip = p;
3413 else
3414 tail->next = p;
3415
3416 tail = p;
3417 }
3418 }
3419
3420 mio_rparen ();
3421 return pi;
3422 }
3423
3424
3425 /* Save/restore a nameless operator interface. */
3426
3427 static void
mio_interface(gfc_interface ** ip)3428 mio_interface (gfc_interface **ip)
3429 {
3430 mio_lparen ();
3431 mio_interface_rest (ip);
3432 }
3433
3434
3435 /* Save/restore a named operator interface. */
3436
3437 static void
mio_symbol_interface(const char ** name,const char ** module,gfc_interface ** ip)3438 mio_symbol_interface (const char **name, const char **module,
3439 gfc_interface **ip)
3440 {
3441 mio_lparen ();
3442 mio_pool_string (name);
3443 mio_pool_string (module);
3444 mio_interface_rest (ip);
3445 }
3446
3447
3448 static void
mio_namespace_ref(gfc_namespace ** nsp)3449 mio_namespace_ref (gfc_namespace **nsp)
3450 {
3451 gfc_namespace *ns;
3452 pointer_info *p;
3453
3454 p = mio_pointer_ref (nsp);
3455
3456 if (p->type == P_UNKNOWN)
3457 p->type = P_NAMESPACE;
3458
3459 if (iomode == IO_INPUT && p->integer != 0)
3460 {
3461 ns = (gfc_namespace *) p->u.pointer;
3462 if (ns == NULL)
3463 {
3464 ns = gfc_get_namespace (NULL, 0);
3465 associate_integer_pointer (p, ns);
3466 }
3467 else
3468 ns->refs++;
3469 }
3470 }
3471
3472
3473 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3474
3475 static gfc_namespace* current_f2k_derived;
3476
3477 static void
mio_typebound_proc(gfc_typebound_proc ** proc)3478 mio_typebound_proc (gfc_typebound_proc** proc)
3479 {
3480 int flag;
3481 int overriding_flag;
3482
3483 if (iomode == IO_INPUT)
3484 {
3485 *proc = gfc_get_typebound_proc (NULL);
3486 (*proc)->where = gfc_current_locus;
3487 }
3488 gcc_assert (*proc);
3489
3490 mio_lparen ();
3491
3492 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3493
3494 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3495 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3496 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3497 overriding_flag = mio_name (overriding_flag, binding_overriding);
3498 (*proc)->deferred = ((overriding_flag & 2) != 0);
3499 (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3500 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3501
3502 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3503 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3504 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3505
3506 mio_pool_string (&((*proc)->pass_arg));
3507
3508 flag = (int) (*proc)->pass_arg_num;
3509 mio_integer (&flag);
3510 (*proc)->pass_arg_num = (unsigned) flag;
3511
3512 if ((*proc)->is_generic)
3513 {
3514 gfc_tbp_generic* g;
3515 int iop;
3516
3517 mio_lparen ();
3518
3519 if (iomode == IO_OUTPUT)
3520 for (g = (*proc)->u.generic; g; g = g->next)
3521 {
3522 iop = (int) g->is_operator;
3523 mio_integer (&iop);
3524 mio_allocated_string (g->specific_st->name);
3525 }
3526 else
3527 {
3528 (*proc)->u.generic = NULL;
3529 while (peek_atom () != ATOM_RPAREN)
3530 {
3531 gfc_symtree** sym_root;
3532
3533 g = gfc_get_tbp_generic ();
3534 g->specific = NULL;
3535
3536 mio_integer (&iop);
3537 g->is_operator = (bool) iop;
3538
3539 require_atom (ATOM_STRING);
3540 sym_root = ¤t_f2k_derived->tb_sym_root;
3541 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3542 free (atom_string);
3543
3544 g->next = (*proc)->u.generic;
3545 (*proc)->u.generic = g;
3546 }
3547 }
3548
3549 mio_rparen ();
3550 }
3551 else if (!(*proc)->ppc)
3552 mio_symtree_ref (&(*proc)->u.specific);
3553
3554 mio_rparen ();
3555 }
3556
3557 /* Walker-callback function for this purpose. */
3558 static void
mio_typebound_symtree(gfc_symtree * st)3559 mio_typebound_symtree (gfc_symtree* st)
3560 {
3561 if (iomode == IO_OUTPUT && !st->n.tb)
3562 return;
3563
3564 if (iomode == IO_OUTPUT)
3565 {
3566 mio_lparen ();
3567 mio_allocated_string (st->name);
3568 }
3569 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3570
3571 mio_typebound_proc (&st->n.tb);
3572 mio_rparen ();
3573 }
3574
3575 /* IO a full symtree (in all depth). */
3576 static void
mio_full_typebound_tree(gfc_symtree ** root)3577 mio_full_typebound_tree (gfc_symtree** root)
3578 {
3579 mio_lparen ();
3580
3581 if (iomode == IO_OUTPUT)
3582 gfc_traverse_symtree (*root, &mio_typebound_symtree);
3583 else
3584 {
3585 while (peek_atom () == ATOM_LPAREN)
3586 {
3587 gfc_symtree* st;
3588
3589 mio_lparen ();
3590
3591 require_atom (ATOM_STRING);
3592 st = gfc_get_tbp_symtree (root, atom_string);
3593 free (atom_string);
3594
3595 mio_typebound_symtree (st);
3596 }
3597 }
3598
3599 mio_rparen ();
3600 }
3601
3602 static void
mio_finalizer(gfc_finalizer ** f)3603 mio_finalizer (gfc_finalizer **f)
3604 {
3605 if (iomode == IO_OUTPUT)
3606 {
3607 gcc_assert (*f);
3608 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
3609 mio_symtree_ref (&(*f)->proc_tree);
3610 }
3611 else
3612 {
3613 *f = gfc_get_finalizer ();
3614 (*f)->where = gfc_current_locus; /* Value should not matter. */
3615 (*f)->next = NULL;
3616
3617 mio_symtree_ref (&(*f)->proc_tree);
3618 (*f)->proc_sym = NULL;
3619 }
3620 }
3621
3622 static void
mio_f2k_derived(gfc_namespace * f2k)3623 mio_f2k_derived (gfc_namespace *f2k)
3624 {
3625 current_f2k_derived = f2k;
3626
3627 /* Handle the list of finalizer procedures. */
3628 mio_lparen ();
3629 if (iomode == IO_OUTPUT)
3630 {
3631 gfc_finalizer *f;
3632 for (f = f2k->finalizers; f; f = f->next)
3633 mio_finalizer (&f);
3634 }
3635 else
3636 {
3637 f2k->finalizers = NULL;
3638 while (peek_atom () != ATOM_RPAREN)
3639 {
3640 gfc_finalizer *cur = NULL;
3641 mio_finalizer (&cur);
3642 cur->next = f2k->finalizers;
3643 f2k->finalizers = cur;
3644 }
3645 }
3646 mio_rparen ();
3647
3648 /* Handle type-bound procedures. */
3649 mio_full_typebound_tree (&f2k->tb_sym_root);
3650
3651 /* Type-bound user operators. */
3652 mio_full_typebound_tree (&f2k->tb_uop_root);
3653
3654 /* Type-bound intrinsic operators. */
3655 mio_lparen ();
3656 if (iomode == IO_OUTPUT)
3657 {
3658 int op;
3659 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3660 {
3661 gfc_intrinsic_op realop;
3662
3663 if (op == INTRINSIC_USER || !f2k->tb_op[op])
3664 continue;
3665
3666 mio_lparen ();
3667 realop = (gfc_intrinsic_op) op;
3668 mio_intrinsic_op (&realop);
3669 mio_typebound_proc (&f2k->tb_op[op]);
3670 mio_rparen ();
3671 }
3672 }
3673 else
3674 while (peek_atom () != ATOM_RPAREN)
3675 {
3676 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
3677
3678 mio_lparen ();
3679 mio_intrinsic_op (&op);
3680 mio_typebound_proc (&f2k->tb_op[op]);
3681 mio_rparen ();
3682 }
3683 mio_rparen ();
3684 }
3685
3686 static void
mio_full_f2k_derived(gfc_symbol * sym)3687 mio_full_f2k_derived (gfc_symbol *sym)
3688 {
3689 mio_lparen ();
3690
3691 if (iomode == IO_OUTPUT)
3692 {
3693 if (sym->f2k_derived)
3694 mio_f2k_derived (sym->f2k_derived);
3695 }
3696 else
3697 {
3698 if (peek_atom () != ATOM_RPAREN)
3699 {
3700 sym->f2k_derived = gfc_get_namespace (NULL, 0);
3701 mio_f2k_derived (sym->f2k_derived);
3702 }
3703 else
3704 gcc_assert (!sym->f2k_derived);
3705 }
3706
3707 mio_rparen ();
3708 }
3709
3710
3711 /* Unlike most other routines, the address of the symbol node is already
3712 fixed on input and the name/module has already been filled in.
3713 If you update the symbol format here, don't forget to update read_module
3714 as well (look for "seek to the symbol's component list"). */
3715
3716 static void
mio_symbol(gfc_symbol * sym)3717 mio_symbol (gfc_symbol *sym)
3718 {
3719 int intmod = INTMOD_NONE;
3720
3721 mio_lparen ();
3722
3723 mio_symbol_attribute (&sym->attr);
3724
3725 mio_typespec (&sym->ts);
3726 if (sym->ts.type == BT_CLASS)
3727 sym->attr.class_ok = 1;
3728
3729 if (iomode == IO_OUTPUT)
3730 mio_namespace_ref (&sym->formal_ns);
3731 else
3732 {
3733 mio_namespace_ref (&sym->formal_ns);
3734 if (sym->formal_ns)
3735 sym->formal_ns->proc_name = sym;
3736 }
3737
3738 /* Save/restore common block links. */
3739 mio_symbol_ref (&sym->common_next);
3740
3741 mio_formal_arglist (&sym->formal);
3742
3743 if (sym->attr.flavor == FL_PARAMETER)
3744 mio_expr (&sym->value);
3745
3746 mio_array_spec (&sym->as);
3747
3748 mio_symbol_ref (&sym->result);
3749
3750 if (sym->attr.cray_pointee)
3751 mio_symbol_ref (&sym->cp_pointer);
3752
3753 /* Note that components are always saved, even if they are supposed
3754 to be private. Component access is checked during searching. */
3755 mio_component_list (&sym->components, sym->attr.vtype);
3756
3757 if (sym->components != NULL)
3758 sym->component_access
3759 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3760
3761 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3762 mio_full_f2k_derived (sym);
3763
3764 mio_namelist (sym);
3765
3766 /* Add the fields that say whether this is from an intrinsic module,
3767 and if so, what symbol it is within the module. */
3768 /* mio_integer (&(sym->from_intmod)); */
3769 if (iomode == IO_OUTPUT)
3770 {
3771 intmod = sym->from_intmod;
3772 mio_integer (&intmod);
3773 }
3774 else
3775 {
3776 mio_integer (&intmod);
3777 sym->from_intmod = (intmod_id) intmod;
3778 }
3779
3780 mio_integer (&(sym->intmod_sym_id));
3781
3782 if (sym->attr.flavor == FL_DERIVED)
3783 mio_integer (&(sym->hash_value));
3784
3785 mio_rparen ();
3786 }
3787
3788
3789 /************************* Top level subroutines *************************/
3790
3791 /* Given a root symtree node and a symbol, try to find a symtree that
3792 references the symbol that is not a unique name. */
3793
3794 static gfc_symtree *
find_symtree_for_symbol(gfc_symtree * st,gfc_symbol * sym)3795 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3796 {
3797 gfc_symtree *s = NULL;
3798
3799 if (st == NULL)
3800 return s;
3801
3802 s = find_symtree_for_symbol (st->right, sym);
3803 if (s != NULL)
3804 return s;
3805 s = find_symtree_for_symbol (st->left, sym);
3806 if (s != NULL)
3807 return s;
3808
3809 if (st->n.sym == sym && !check_unique_name (st->name))
3810 return st;
3811
3812 return s;
3813 }
3814
3815
3816 /* A recursive function to look for a specific symbol by name and by
3817 module. Whilst several symtrees might point to one symbol, its
3818 is sufficient for the purposes here than one exist. Note that
3819 generic interfaces are distinguished as are symbols that have been
3820 renamed in another module. */
3821 static gfc_symtree *
find_symbol(gfc_symtree * st,const char * name,const char * module,int generic)3822 find_symbol (gfc_symtree *st, const char *name,
3823 const char *module, int generic)
3824 {
3825 int c;
3826 gfc_symtree *retval, *s;
3827
3828 if (st == NULL || st->n.sym == NULL)
3829 return NULL;
3830
3831 c = strcmp (name, st->n.sym->name);
3832 if (c == 0 && st->n.sym->module
3833 && strcmp (module, st->n.sym->module) == 0
3834 && !check_unique_name (st->name))
3835 {
3836 s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3837
3838 /* Detect symbols that are renamed by use association in another
3839 module by the absence of a symtree and null attr.use_rename,
3840 since the latter is not transmitted in the module file. */
3841 if (((!generic && !st->n.sym->attr.generic)
3842 || (generic && st->n.sym->attr.generic))
3843 && !(s == NULL && !st->n.sym->attr.use_rename))
3844 return st;
3845 }
3846
3847 retval = find_symbol (st->left, name, module, generic);
3848
3849 if (retval == NULL)
3850 retval = find_symbol (st->right, name, module, generic);
3851
3852 return retval;
3853 }
3854
3855
3856 /* Skip a list between balanced left and right parens.
3857 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
3858 have been already parsed by hand, and the remaining of the content is to be
3859 skipped here. The default value is 0 (balanced parens). */
3860
3861 static void
3862 skip_list (int nest_level = 0)
3863 {
3864 int level;
3865
3866 level = nest_level;
3867 do
3868 {
3869 switch (parse_atom ())
3870 {
3871 case ATOM_LPAREN:
3872 level++;
3873 break;
3874
3875 case ATOM_RPAREN:
3876 level--;
3877 break;
3878
3879 case ATOM_STRING:
3880 free (atom_string);
3881 break;
3882
3883 case ATOM_NAME:
3884 case ATOM_INTEGER:
3885 break;
3886 }
3887 }
3888 while (level > 0);
3889 }
3890
3891
3892 /* Load operator interfaces from the module. Interfaces are unusual
3893 in that they attach themselves to existing symbols. */
3894
3895 static void
load_operator_interfaces(void)3896 load_operator_interfaces (void)
3897 {
3898 const char *p;
3899 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3900 gfc_user_op *uop;
3901 pointer_info *pi = NULL;
3902 int n, i;
3903
3904 mio_lparen ();
3905
3906 while (peek_atom () != ATOM_RPAREN)
3907 {
3908 mio_lparen ();
3909
3910 mio_internal_string (name);
3911 mio_internal_string (module);
3912
3913 n = number_use_names (name, true);
3914 n = n ? n : 1;
3915
3916 for (i = 1; i <= n; i++)
3917 {
3918 /* Decide if we need to load this one or not. */
3919 p = find_use_name_n (name, &i, true);
3920
3921 if (p == NULL)
3922 {
3923 while (parse_atom () != ATOM_RPAREN);
3924 continue;
3925 }
3926
3927 if (i == 1)
3928 {
3929 uop = gfc_get_uop (p);
3930 pi = mio_interface_rest (&uop->op);
3931 }
3932 else
3933 {
3934 if (gfc_find_uop (p, NULL))
3935 continue;
3936 uop = gfc_get_uop (p);
3937 uop->op = gfc_get_interface ();
3938 uop->op->where = gfc_current_locus;
3939 add_fixup (pi->integer, &uop->op->sym);
3940 }
3941 }
3942 }
3943
3944 mio_rparen ();
3945 }
3946
3947
3948 /* Load interfaces from the module. Interfaces are unusual in that
3949 they attach themselves to existing symbols. */
3950
3951 static void
load_generic_interfaces(void)3952 load_generic_interfaces (void)
3953 {
3954 const char *p;
3955 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3956 gfc_symbol *sym;
3957 gfc_interface *generic = NULL, *gen = NULL;
3958 int n, i, renamed;
3959 bool ambiguous_set = false;
3960
3961 mio_lparen ();
3962
3963 while (peek_atom () != ATOM_RPAREN)
3964 {
3965 mio_lparen ();
3966
3967 mio_internal_string (name);
3968 mio_internal_string (module);
3969
3970 n = number_use_names (name, false);
3971 renamed = n ? 1 : 0;
3972 n = n ? n : 1;
3973
3974 for (i = 1; i <= n; i++)
3975 {
3976 gfc_symtree *st;
3977 /* Decide if we need to load this one or not. */
3978 p = find_use_name_n (name, &i, false);
3979
3980 st = find_symbol (gfc_current_ns->sym_root,
3981 name, module_name, 1);
3982
3983 if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3984 {
3985 /* Skip the specific names for these cases. */
3986 while (i == 1 && parse_atom () != ATOM_RPAREN);
3987
3988 continue;
3989 }
3990
3991 /* If the symbol exists already and is being USEd without being
3992 in an ONLY clause, do not load a new symtree(11.3.2). */
3993 if (!only_flag && st)
3994 sym = st->n.sym;
3995
3996 if (!sym)
3997 {
3998 if (st)
3999 {
4000 sym = st->n.sym;
4001 if (strcmp (st->name, p) != 0)
4002 {
4003 st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4004 st->n.sym = sym;
4005 sym->refs++;
4006 }
4007 }
4008
4009 /* Since we haven't found a valid generic interface, we had
4010 better make one. */
4011 if (!sym)
4012 {
4013 gfc_get_symbol (p, NULL, &sym);
4014 sym->name = gfc_get_string (name);
4015 sym->module = module_name;
4016 sym->attr.flavor = FL_PROCEDURE;
4017 sym->attr.generic = 1;
4018 sym->attr.use_assoc = 1;
4019 }
4020 }
4021 else
4022 {
4023 /* Unless sym is a generic interface, this reference
4024 is ambiguous. */
4025 if (st == NULL)
4026 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4027
4028 sym = st->n.sym;
4029
4030 if (st && !sym->attr.generic
4031 && !st->ambiguous
4032 && sym->module
4033 && strcmp(module, sym->module))
4034 {
4035 ambiguous_set = true;
4036 st->ambiguous = 1;
4037 }
4038 }
4039
4040 sym->attr.use_only = only_flag;
4041 sym->attr.use_rename = renamed;
4042
4043 if (i == 1)
4044 {
4045 mio_interface_rest (&sym->generic);
4046 generic = sym->generic;
4047 }
4048 else if (!sym->generic)
4049 {
4050 sym->generic = generic;
4051 sym->attr.generic_copy = 1;
4052 }
4053
4054 /* If a procedure that is not generic has generic interfaces
4055 that include itself, it is generic! We need to take care
4056 to retain symbols ambiguous that were already so. */
4057 if (sym->attr.use_assoc
4058 && !sym->attr.generic
4059 && sym->attr.flavor == FL_PROCEDURE)
4060 {
4061 for (gen = generic; gen; gen = gen->next)
4062 {
4063 if (gen->sym == sym)
4064 {
4065 sym->attr.generic = 1;
4066 if (ambiguous_set)
4067 st->ambiguous = 0;
4068 break;
4069 }
4070 }
4071 }
4072
4073 }
4074 }
4075
4076 mio_rparen ();
4077 }
4078
4079
4080 /* Load common blocks. */
4081
4082 static void
load_commons(void)4083 load_commons (void)
4084 {
4085 char name[GFC_MAX_SYMBOL_LEN + 1];
4086 gfc_common_head *p;
4087
4088 mio_lparen ();
4089
4090 while (peek_atom () != ATOM_RPAREN)
4091 {
4092 int flags;
4093 char* label;
4094 mio_lparen ();
4095 mio_internal_string (name);
4096
4097 p = gfc_get_common (name, 1);
4098
4099 mio_symbol_ref (&p->head);
4100 mio_integer (&flags);
4101 if (flags & 1)
4102 p->saved = 1;
4103 if (flags & 2)
4104 p->threadprivate = 1;
4105 p->use_assoc = 1;
4106
4107 /* Get whether this was a bind(c) common or not. */
4108 mio_integer (&p->is_bind_c);
4109 /* Get the binding label. */
4110 label = read_string ();
4111 if (strlen (label))
4112 p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4113 XDELETEVEC (label);
4114
4115 mio_rparen ();
4116 }
4117
4118 mio_rparen ();
4119 }
4120
4121
4122 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4123 so that unused variables are not loaded and so that the expression can
4124 be safely freed. */
4125
4126 static void
load_equiv(void)4127 load_equiv (void)
4128 {
4129 gfc_equiv *head, *tail, *end, *eq;
4130 bool unused;
4131
4132 mio_lparen ();
4133 in_load_equiv = true;
4134
4135 end = gfc_current_ns->equiv;
4136 while (end != NULL && end->next != NULL)
4137 end = end->next;
4138
4139 while (peek_atom () != ATOM_RPAREN) {
4140 mio_lparen ();
4141 head = tail = NULL;
4142
4143 while(peek_atom () != ATOM_RPAREN)
4144 {
4145 if (head == NULL)
4146 head = tail = gfc_get_equiv ();
4147 else
4148 {
4149 tail->eq = gfc_get_equiv ();
4150 tail = tail->eq;
4151 }
4152
4153 mio_pool_string (&tail->module);
4154 mio_expr (&tail->expr);
4155 }
4156
4157 /* Unused equivalence members have a unique name. In addition, it
4158 must be checked that the symbols are from the same module. */
4159 unused = true;
4160 for (eq = head; eq; eq = eq->eq)
4161 {
4162 if (eq->expr->symtree->n.sym->module
4163 && head->expr->symtree->n.sym->module
4164 && strcmp (head->expr->symtree->n.sym->module,
4165 eq->expr->symtree->n.sym->module) == 0
4166 && !check_unique_name (eq->expr->symtree->name))
4167 {
4168 unused = false;
4169 break;
4170 }
4171 }
4172
4173 if (unused)
4174 {
4175 for (eq = head; eq; eq = head)
4176 {
4177 head = eq->eq;
4178 gfc_free_expr (eq->expr);
4179 free (eq);
4180 }
4181 }
4182
4183 if (end == NULL)
4184 gfc_current_ns->equiv = head;
4185 else
4186 end->next = head;
4187
4188 if (head != NULL)
4189 end = head;
4190
4191 mio_rparen ();
4192 }
4193
4194 mio_rparen ();
4195 in_load_equiv = false;
4196 }
4197
4198
4199 /* This function loads the sym_root of f2k_derived with the extensions to
4200 the derived type. */
4201 static void
load_derived_extensions(void)4202 load_derived_extensions (void)
4203 {
4204 int symbol, j;
4205 gfc_symbol *derived;
4206 gfc_symbol *dt;
4207 gfc_symtree *st;
4208 pointer_info *info;
4209 char name[GFC_MAX_SYMBOL_LEN + 1];
4210 char module[GFC_MAX_SYMBOL_LEN + 1];
4211 const char *p;
4212
4213 mio_lparen ();
4214 while (peek_atom () != ATOM_RPAREN)
4215 {
4216 mio_lparen ();
4217 mio_integer (&symbol);
4218 info = get_integer (symbol);
4219 derived = info->u.rsym.sym;
4220
4221 /* This one is not being loaded. */
4222 if (!info || !derived)
4223 {
4224 while (peek_atom () != ATOM_RPAREN)
4225 skip_list ();
4226 continue;
4227 }
4228
4229 gcc_assert (derived->attr.flavor == FL_DERIVED);
4230 if (derived->f2k_derived == NULL)
4231 derived->f2k_derived = gfc_get_namespace (NULL, 0);
4232
4233 while (peek_atom () != ATOM_RPAREN)
4234 {
4235 mio_lparen ();
4236 mio_internal_string (name);
4237 mio_internal_string (module);
4238
4239 /* Only use one use name to find the symbol. */
4240 j = 1;
4241 p = find_use_name_n (name, &j, false);
4242 if (p)
4243 {
4244 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4245 dt = st->n.sym;
4246 st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4247 if (st == NULL)
4248 {
4249 /* Only use the real name in f2k_derived to ensure a single
4250 symtree. */
4251 st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
4252 st->n.sym = dt;
4253 st->n.sym->refs++;
4254 }
4255 }
4256 mio_rparen ();
4257 }
4258 mio_rparen ();
4259 }
4260 mio_rparen ();
4261 }
4262
4263
4264 /* Recursive function to traverse the pointer_info tree and load a
4265 needed symbol. We return nonzero if we load a symbol and stop the
4266 traversal, because the act of loading can alter the tree. */
4267
4268 static int
load_needed(pointer_info * p)4269 load_needed (pointer_info *p)
4270 {
4271 gfc_namespace *ns;
4272 pointer_info *q;
4273 gfc_symbol *sym;
4274 int rv;
4275
4276 rv = 0;
4277 if (p == NULL)
4278 return rv;
4279
4280 rv |= load_needed (p->left);
4281 rv |= load_needed (p->right);
4282
4283 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4284 return rv;
4285
4286 p->u.rsym.state = USED;
4287
4288 set_module_locus (&p->u.rsym.where);
4289
4290 sym = p->u.rsym.sym;
4291 if (sym == NULL)
4292 {
4293 q = get_integer (p->u.rsym.ns);
4294
4295 ns = (gfc_namespace *) q->u.pointer;
4296 if (ns == NULL)
4297 {
4298 /* Create an interface namespace if necessary. These are
4299 the namespaces that hold the formal parameters of module
4300 procedures. */
4301
4302 ns = gfc_get_namespace (NULL, 0);
4303 associate_integer_pointer (q, ns);
4304 }
4305
4306 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4307 doesn't go pear-shaped if the symbol is used. */
4308 if (!ns->proc_name)
4309 gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4310 1, &ns->proc_name);
4311
4312 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4313 sym->name = dt_lower_string (p->u.rsym.true_name);
4314 sym->module = gfc_get_string (p->u.rsym.module);
4315 if (p->u.rsym.binding_label)
4316 sym->binding_label = IDENTIFIER_POINTER (get_identifier
4317 (p->u.rsym.binding_label));
4318
4319 associate_integer_pointer (p, sym);
4320 }
4321
4322 mio_symbol (sym);
4323 sym->attr.use_assoc = 1;
4324
4325 /* Mark as only or rename for later diagnosis for explicitly imported
4326 but not used warnings; don't mark internal symbols such as __vtab,
4327 __def_init etc. Only mark them if they have been explicitly loaded. */
4328
4329 if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
4330 {
4331 gfc_use_rename *u;
4332
4333 /* Search the use/rename list for the variable; if the variable is
4334 found, mark it. */
4335 for (u = gfc_rename_list; u; u = u->next)
4336 {
4337 if (strcmp (u->use_name, sym->name) == 0)
4338 {
4339 sym->attr.use_only = 1;
4340 break;
4341 }
4342 }
4343 }
4344
4345 if (p->u.rsym.renamed)
4346 sym->attr.use_rename = 1;
4347
4348 return 1;
4349 }
4350
4351
4352 /* Recursive function for cleaning up things after a module has been read. */
4353
4354 static void
read_cleanup(pointer_info * p)4355 read_cleanup (pointer_info *p)
4356 {
4357 gfc_symtree *st;
4358 pointer_info *q;
4359
4360 if (p == NULL)
4361 return;
4362
4363 read_cleanup (p->left);
4364 read_cleanup (p->right);
4365
4366 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4367 {
4368 gfc_namespace *ns;
4369 /* Add hidden symbols to the symtree. */
4370 q = get_integer (p->u.rsym.ns);
4371 ns = (gfc_namespace *) q->u.pointer;
4372
4373 if (!p->u.rsym.sym->attr.vtype
4374 && !p->u.rsym.sym->attr.vtab)
4375 st = gfc_get_unique_symtree (ns);
4376 else
4377 {
4378 /* There is no reason to use 'unique_symtrees' for vtabs or
4379 vtypes - their name is fine for a symtree and reduces the
4380 namespace pollution. */
4381 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4382 if (!st)
4383 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
4384 }
4385
4386 st->n.sym = p->u.rsym.sym;
4387 st->n.sym->refs++;
4388
4389 /* Fixup any symtree references. */
4390 p->u.rsym.symtree = st;
4391 resolve_fixups (p->u.rsym.stfixup, st);
4392 p->u.rsym.stfixup = NULL;
4393 }
4394
4395 /* Free unused symbols. */
4396 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4397 gfc_free_symbol (p->u.rsym.sym);
4398 }
4399
4400
4401 /* It is not quite enough to check for ambiguity in the symbols by
4402 the loaded symbol and the new symbol not being identical. */
4403 static bool
check_for_ambiguous(gfc_symtree * st,pointer_info * info)4404 check_for_ambiguous (gfc_symtree *st, pointer_info *info)
4405 {
4406 gfc_symbol *rsym;
4407 module_locus locus;
4408 symbol_attribute attr;
4409 gfc_symbol *st_sym;
4410
4411 if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
4412 {
4413 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4414 "current program unit", st->name, module_name);
4415 return true;
4416 }
4417
4418 st_sym = st->n.sym;
4419 rsym = info->u.rsym.sym;
4420 if (st_sym == rsym)
4421 return false;
4422
4423 if (st_sym->attr.vtab || st_sym->attr.vtype)
4424 return false;
4425
4426 /* If the existing symbol is generic from a different module and
4427 the new symbol is generic there can be no ambiguity. */
4428 if (st_sym->attr.generic
4429 && st_sym->module
4430 && st_sym->module != module_name)
4431 {
4432 /* The new symbol's attributes have not yet been read. Since
4433 we need attr.generic, read it directly. */
4434 get_module_locus (&locus);
4435 set_module_locus (&info->u.rsym.where);
4436 mio_lparen ();
4437 attr.generic = 0;
4438 mio_symbol_attribute (&attr);
4439 set_module_locus (&locus);
4440 if (attr.generic)
4441 return false;
4442 }
4443
4444 return true;
4445 }
4446
4447
4448 /* Read a module file. */
4449
4450 static void
read_module(void)4451 read_module (void)
4452 {
4453 module_locus operator_interfaces, user_operators, extensions;
4454 const char *p;
4455 char name[GFC_MAX_SYMBOL_LEN + 1];
4456 int i;
4457 int ambiguous, j, nuse, symbol;
4458 pointer_info *info, *q;
4459 gfc_use_rename *u = NULL;
4460 gfc_symtree *st;
4461 gfc_symbol *sym;
4462
4463 get_module_locus (&operator_interfaces); /* Skip these for now. */
4464 skip_list ();
4465
4466 get_module_locus (&user_operators);
4467 skip_list ();
4468 skip_list ();
4469
4470 /* Skip commons, equivalences and derived type extensions for now. */
4471 skip_list ();
4472 skip_list ();
4473
4474 get_module_locus (&extensions);
4475 skip_list ();
4476
4477 mio_lparen ();
4478
4479 /* Create the fixup nodes for all the symbols. */
4480
4481 while (peek_atom () != ATOM_RPAREN)
4482 {
4483 char* bind_label;
4484 require_atom (ATOM_INTEGER);
4485 info = get_integer (atom_int);
4486
4487 info->type = P_SYMBOL;
4488 info->u.rsym.state = UNUSED;
4489
4490 info->u.rsym.true_name = read_string ();
4491 info->u.rsym.module = read_string ();
4492 bind_label = read_string ();
4493 if (strlen (bind_label))
4494 info->u.rsym.binding_label = bind_label;
4495 else
4496 XDELETEVEC (bind_label);
4497
4498 require_atom (ATOM_INTEGER);
4499 info->u.rsym.ns = atom_int;
4500
4501 get_module_locus (&info->u.rsym.where);
4502
4503 /* See if the symbol has already been loaded by a previous module.
4504 If so, we reference the existing symbol and prevent it from
4505 being loaded again. This should not happen if the symbol being
4506 read is an index for an assumed shape dummy array (ns != 1). */
4507
4508 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4509
4510 if (sym == NULL
4511 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4512 {
4513 skip_list ();
4514 continue;
4515 }
4516
4517 info->u.rsym.state = USED;
4518 info->u.rsym.sym = sym;
4519 /* The current symbol has already been loaded, so we can avoid loading
4520 it again. However, if it is a derived type, some of its components
4521 can be used in expressions in the module. To avoid the module loading
4522 failing, we need to associate the module's component pointer indexes
4523 with the existing symbol's component pointers. */
4524 if (sym->attr.flavor == FL_DERIVED)
4525 {
4526 gfc_component *c;
4527
4528 /* First seek to the symbol's component list. */
4529 mio_lparen (); /* symbol opening. */
4530 skip_list (); /* skip symbol attribute. */
4531 skip_list (); /* typespec. */
4532 require_atom (ATOM_INTEGER); /* namespace ref. */
4533 require_atom (ATOM_INTEGER); /* common ref. */
4534 skip_list (); /* formal args. */
4535 /* no value. */
4536 skip_list (); /* array_spec. */
4537 require_atom (ATOM_INTEGER); /* result. */
4538 /* not a cray pointer. */
4539
4540 mio_lparen (); /* component list opening. */
4541 for (c = sym->components; c; c = c->next)
4542 {
4543 pointer_info *p;
4544 const char *comp_name;
4545 int n;
4546
4547 mio_lparen (); /* component opening. */
4548 mio_integer (&n);
4549 p = get_integer (n);
4550 if (p->u.pointer == NULL)
4551 associate_integer_pointer (p, c);
4552 mio_pool_string (&comp_name);
4553 gcc_assert (comp_name == c->name);
4554 skip_list (1); /* component end. */
4555 }
4556 mio_rparen (); /* component list closing. */
4557
4558 skip_list (1); /* symbol end. */
4559 }
4560 else
4561 skip_list ();
4562
4563 /* Some symbols do not have a namespace (eg. formal arguments),
4564 so the automatic "unique symtree" mechanism must be suppressed
4565 by marking them as referenced. */
4566 q = get_integer (info->u.rsym.ns);
4567 if (q->u.pointer == NULL)
4568 {
4569 info->u.rsym.referenced = 1;
4570 continue;
4571 }
4572
4573 /* If possible recycle the symtree that references the symbol.
4574 If a symtree is not found and the module does not import one,
4575 a unique-name symtree is found by read_cleanup. */
4576 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4577 if (st != NULL)
4578 {
4579 info->u.rsym.symtree = st;
4580 info->u.rsym.referenced = 1;
4581 }
4582 }
4583
4584 mio_rparen ();
4585
4586 /* Parse the symtree lists. This lets us mark which symbols need to
4587 be loaded. Renaming is also done at this point by replacing the
4588 symtree name. */
4589
4590 mio_lparen ();
4591
4592 while (peek_atom () != ATOM_RPAREN)
4593 {
4594 mio_internal_string (name);
4595 mio_integer (&ambiguous);
4596 mio_integer (&symbol);
4597
4598 info = get_integer (symbol);
4599
4600 /* See how many use names there are. If none, go through the start
4601 of the loop at least once. */
4602 nuse = number_use_names (name, false);
4603 info->u.rsym.renamed = nuse ? 1 : 0;
4604
4605 if (nuse == 0)
4606 nuse = 1;
4607
4608 for (j = 1; j <= nuse; j++)
4609 {
4610 /* Get the jth local name for this symbol. */
4611 p = find_use_name_n (name, &j, false);
4612
4613 if (p == NULL && strcmp (name, module_name) == 0)
4614 p = name;
4615
4616 /* Exception: Always import vtabs & vtypes. */
4617 if (p == NULL && name[0] == '_'
4618 && (strncmp (name, "__vtab_", 5) == 0
4619 || strncmp (name, "__vtype_", 6) == 0))
4620 p = name;
4621
4622 /* Skip symtree nodes not in an ONLY clause, unless there
4623 is an existing symtree loaded from another USE statement. */
4624 if (p == NULL)
4625 {
4626 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4627 if (st != NULL
4628 && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
4629 && st->n.sym->module != NULL
4630 && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
4631 {
4632 info->u.rsym.symtree = st;
4633 info->u.rsym.sym = st->n.sym;
4634 }
4635 continue;
4636 }
4637
4638 /* If a symbol of the same name and module exists already,
4639 this symbol, which is not in an ONLY clause, must not be
4640 added to the namespace(11.3.2). Note that find_symbol
4641 only returns the first occurrence that it finds. */
4642 if (!only_flag && !info->u.rsym.renamed
4643 && strcmp (name, module_name) != 0
4644 && find_symbol (gfc_current_ns->sym_root, name,
4645 module_name, 0))
4646 continue;
4647
4648 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4649
4650 if (st != NULL)
4651 {
4652 /* Check for ambiguous symbols. */
4653 if (check_for_ambiguous (st, info))
4654 st->ambiguous = 1;
4655 else
4656 info->u.rsym.symtree = st;
4657 }
4658 else
4659 {
4660 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4661
4662 /* Create a symtree node in the current namespace for this
4663 symbol. */
4664 st = check_unique_name (p)
4665 ? gfc_get_unique_symtree (gfc_current_ns)
4666 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4667 st->ambiguous = ambiguous;
4668
4669 sym = info->u.rsym.sym;
4670
4671 /* Create a symbol node if it doesn't already exist. */
4672 if (sym == NULL)
4673 {
4674 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4675 gfc_current_ns);
4676 info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
4677 sym = info->u.rsym.sym;
4678 sym->module = gfc_get_string (info->u.rsym.module);
4679
4680 if (info->u.rsym.binding_label)
4681 sym->binding_label =
4682 IDENTIFIER_POINTER (get_identifier
4683 (info->u.rsym.binding_label));
4684 }
4685
4686 st->n.sym = sym;
4687 st->n.sym->refs++;
4688
4689 if (strcmp (name, p) != 0)
4690 sym->attr.use_rename = 1;
4691
4692 if (name[0] != '_'
4693 || (strncmp (name, "__vtab_", 5) != 0
4694 && strncmp (name, "__vtype_", 6) != 0))
4695 sym->attr.use_only = only_flag;
4696
4697 /* Store the symtree pointing to this symbol. */
4698 info->u.rsym.symtree = st;
4699
4700 if (info->u.rsym.state == UNUSED)
4701 info->u.rsym.state = NEEDED;
4702 info->u.rsym.referenced = 1;
4703 }
4704 }
4705 }
4706
4707 mio_rparen ();
4708
4709 /* Load intrinsic operator interfaces. */
4710 set_module_locus (&operator_interfaces);
4711 mio_lparen ();
4712
4713 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4714 {
4715 if (i == INTRINSIC_USER)
4716 continue;
4717
4718 if (only_flag)
4719 {
4720 u = find_use_operator ((gfc_intrinsic_op) i);
4721
4722 if (u == NULL)
4723 {
4724 skip_list ();
4725 continue;
4726 }
4727
4728 u->found = 1;
4729 }
4730
4731 mio_interface (&gfc_current_ns->op[i]);
4732 if (u && !gfc_current_ns->op[i])
4733 u->found = 0;
4734 }
4735
4736 mio_rparen ();
4737
4738 /* Load generic and user operator interfaces. These must follow the
4739 loading of symtree because otherwise symbols can be marked as
4740 ambiguous. */
4741
4742 set_module_locus (&user_operators);
4743
4744 load_operator_interfaces ();
4745 load_generic_interfaces ();
4746
4747 load_commons ();
4748 load_equiv ();
4749
4750 /* At this point, we read those symbols that are needed but haven't
4751 been loaded yet. If one symbol requires another, the other gets
4752 marked as NEEDED if its previous state was UNUSED. */
4753
4754 while (load_needed (pi_root));
4755
4756 /* Make sure all elements of the rename-list were found in the module. */
4757
4758 for (u = gfc_rename_list; u; u = u->next)
4759 {
4760 if (u->found)
4761 continue;
4762
4763 if (u->op == INTRINSIC_NONE)
4764 {
4765 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4766 u->use_name, &u->where, module_name);
4767 continue;
4768 }
4769
4770 if (u->op == INTRINSIC_USER)
4771 {
4772 gfc_error ("User operator '%s' referenced at %L not found "
4773 "in module '%s'", u->use_name, &u->where, module_name);
4774 continue;
4775 }
4776
4777 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4778 "in module '%s'", gfc_op2string (u->op), &u->where,
4779 module_name);
4780 }
4781
4782 /* Now we should be in a position to fill f2k_derived with derived type
4783 extensions, since everything has been loaded. */
4784 set_module_locus (&extensions);
4785 load_derived_extensions ();
4786
4787 /* Clean up symbol nodes that were never loaded, create references
4788 to hidden symbols. */
4789
4790 read_cleanup (pi_root);
4791 }
4792
4793
4794 /* Given an access type that is specific to an entity and the default
4795 access, return nonzero if the entity is publicly accessible. If the
4796 element is declared as PUBLIC, then it is public; if declared
4797 PRIVATE, then private, and otherwise it is public unless the default
4798 access in this context has been declared PRIVATE. */
4799
4800 static bool
check_access(gfc_access specific_access,gfc_access default_access)4801 check_access (gfc_access specific_access, gfc_access default_access)
4802 {
4803 if (specific_access == ACCESS_PUBLIC)
4804 return TRUE;
4805 if (specific_access == ACCESS_PRIVATE)
4806 return FALSE;
4807
4808 if (gfc_option.flag_module_private)
4809 return default_access == ACCESS_PUBLIC;
4810 else
4811 return default_access != ACCESS_PRIVATE;
4812 }
4813
4814
4815 bool
gfc_check_symbol_access(gfc_symbol * sym)4816 gfc_check_symbol_access (gfc_symbol *sym)
4817 {
4818 if (sym->attr.vtab || sym->attr.vtype)
4819 return true;
4820 else
4821 return check_access (sym->attr.access, sym->ns->default_access);
4822 }
4823
4824
4825 /* A structure to remember which commons we've already written. */
4826
4827 struct written_common
4828 {
4829 BBT_HEADER(written_common);
4830 const char *name, *label;
4831 };
4832
4833 static struct written_common *written_commons = NULL;
4834
4835 /* Comparison function used for balancing the binary tree. */
4836
4837 static int
compare_written_commons(void * a1,void * b1)4838 compare_written_commons (void *a1, void *b1)
4839 {
4840 const char *aname = ((struct written_common *) a1)->name;
4841 const char *alabel = ((struct written_common *) a1)->label;
4842 const char *bname = ((struct written_common *) b1)->name;
4843 const char *blabel = ((struct written_common *) b1)->label;
4844 int c = strcmp (aname, bname);
4845
4846 return (c != 0 ? c : strcmp (alabel, blabel));
4847 }
4848
4849 /* Free a list of written commons. */
4850
4851 static void
free_written_common(struct written_common * w)4852 free_written_common (struct written_common *w)
4853 {
4854 if (!w)
4855 return;
4856
4857 if (w->left)
4858 free_written_common (w->left);
4859 if (w->right)
4860 free_written_common (w->right);
4861
4862 free (w);
4863 }
4864
4865 /* Write a common block to the module -- recursive helper function. */
4866
4867 static void
write_common_0(gfc_symtree * st,bool this_module)4868 write_common_0 (gfc_symtree *st, bool this_module)
4869 {
4870 gfc_common_head *p;
4871 const char * name;
4872 int flags;
4873 const char *label;
4874 struct written_common *w;
4875 bool write_me = true;
4876
4877 if (st == NULL)
4878 return;
4879
4880 write_common_0 (st->left, this_module);
4881
4882 /* We will write out the binding label, or "" if no label given. */
4883 name = st->n.common->name;
4884 p = st->n.common;
4885 label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
4886
4887 /* Check if we've already output this common. */
4888 w = written_commons;
4889 while (w)
4890 {
4891 int c = strcmp (name, w->name);
4892 c = (c != 0 ? c : strcmp (label, w->label));
4893 if (c == 0)
4894 write_me = false;
4895
4896 w = (c < 0) ? w->left : w->right;
4897 }
4898
4899 if (this_module && p->use_assoc)
4900 write_me = false;
4901
4902 if (write_me)
4903 {
4904 /* Write the common to the module. */
4905 mio_lparen ();
4906 mio_pool_string (&name);
4907
4908 mio_symbol_ref (&p->head);
4909 flags = p->saved ? 1 : 0;
4910 if (p->threadprivate)
4911 flags |= 2;
4912 mio_integer (&flags);
4913
4914 /* Write out whether the common block is bind(c) or not. */
4915 mio_integer (&(p->is_bind_c));
4916
4917 mio_pool_string (&label);
4918 mio_rparen ();
4919
4920 /* Record that we have written this common. */
4921 w = XCNEW (struct written_common);
4922 w->name = p->name;
4923 w->label = label;
4924 gfc_insert_bbt (&written_commons, w, compare_written_commons);
4925 }
4926
4927 write_common_0 (st->right, this_module);
4928 }
4929
4930
4931 /* Write a common, by initializing the list of written commons, calling
4932 the recursive function write_common_0() and cleaning up afterwards. */
4933
4934 static void
write_common(gfc_symtree * st)4935 write_common (gfc_symtree *st)
4936 {
4937 written_commons = NULL;
4938 write_common_0 (st, true);
4939 write_common_0 (st, false);
4940 free_written_common (written_commons);
4941 written_commons = NULL;
4942 }
4943
4944
4945 /* Write the blank common block to the module. */
4946
4947 static void
write_blank_common(void)4948 write_blank_common (void)
4949 {
4950 const char * name = BLANK_COMMON_NAME;
4951 int saved;
4952 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4953 this, but it hasn't been checked. Just making it so for now. */
4954 int is_bind_c = 0;
4955
4956 if (gfc_current_ns->blank_common.head == NULL)
4957 return;
4958
4959 mio_lparen ();
4960
4961 mio_pool_string (&name);
4962
4963 mio_symbol_ref (&gfc_current_ns->blank_common.head);
4964 saved = gfc_current_ns->blank_common.saved;
4965 mio_integer (&saved);
4966
4967 /* Write out whether the common block is bind(c) or not. */
4968 mio_integer (&is_bind_c);
4969
4970 /* Write out an empty binding label. */
4971 write_atom (ATOM_STRING, "");
4972
4973 mio_rparen ();
4974 }
4975
4976
4977 /* Write equivalences to the module. */
4978
4979 static void
write_equiv(void)4980 write_equiv (void)
4981 {
4982 gfc_equiv *eq, *e;
4983 int num;
4984
4985 num = 0;
4986 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4987 {
4988 mio_lparen ();
4989
4990 for (e = eq; e; e = e->eq)
4991 {
4992 if (e->module == NULL)
4993 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4994 mio_allocated_string (e->module);
4995 mio_expr (&e->expr);
4996 }
4997
4998 num++;
4999 mio_rparen ();
5000 }
5001 }
5002
5003
5004 /* Write derived type extensions to the module. */
5005
5006 static void
write_dt_extensions(gfc_symtree * st)5007 write_dt_extensions (gfc_symtree *st)
5008 {
5009 if (!gfc_check_symbol_access (st->n.sym))
5010 return;
5011 if (!(st->n.sym->ns && st->n.sym->ns->proc_name
5012 && st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
5013 return;
5014
5015 mio_lparen ();
5016 mio_pool_string (&st->name);
5017 if (st->n.sym->module != NULL)
5018 mio_pool_string (&st->n.sym->module);
5019 else
5020 {
5021 char name[GFC_MAX_SYMBOL_LEN + 1];
5022 if (iomode == IO_OUTPUT)
5023 strcpy (name, module_name);
5024 mio_internal_string (name);
5025 if (iomode == IO_INPUT)
5026 module_name = gfc_get_string (name);
5027 }
5028 mio_rparen ();
5029 }
5030
5031 static void
write_derived_extensions(gfc_symtree * st)5032 write_derived_extensions (gfc_symtree *st)
5033 {
5034 if (!((st->n.sym->attr.flavor == FL_DERIVED)
5035 && (st->n.sym->f2k_derived != NULL)
5036 && (st->n.sym->f2k_derived->sym_root != NULL)))
5037 return;
5038
5039 mio_lparen ();
5040 mio_symbol_ref (&(st->n.sym));
5041 gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
5042 write_dt_extensions);
5043 mio_rparen ();
5044 }
5045
5046
5047 /* Write a symbol to the module. */
5048
5049 static void
write_symbol(int n,gfc_symbol * sym)5050 write_symbol (int n, gfc_symbol *sym)
5051 {
5052 const char *label;
5053
5054 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5055 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
5056
5057 mio_integer (&n);
5058
5059 if (sym->attr.flavor == FL_DERIVED)
5060 {
5061 const char *name;
5062 name = dt_upper_string (sym->name);
5063 mio_pool_string (&name);
5064 }
5065 else
5066 mio_pool_string (&sym->name);
5067
5068 mio_pool_string (&sym->module);
5069 if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5070 {
5071 label = sym->binding_label;
5072 mio_pool_string (&label);
5073 }
5074 else
5075 write_atom (ATOM_STRING, "");
5076
5077 mio_pointer_ref (&sym->ns);
5078
5079 mio_symbol (sym);
5080 write_char ('\n');
5081 }
5082
5083
5084 /* Recursive traversal function to write the initial set of symbols to
5085 the module. We check to see if the symbol should be written
5086 according to the access specification. */
5087
5088 static void
write_symbol0(gfc_symtree * st)5089 write_symbol0 (gfc_symtree *st)
5090 {
5091 gfc_symbol *sym;
5092 pointer_info *p;
5093 bool dont_write = false;
5094
5095 if (st == NULL)
5096 return;
5097
5098 write_symbol0 (st->left);
5099
5100 sym = st->n.sym;
5101 if (sym->module == NULL)
5102 sym->module = module_name;
5103
5104 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5105 && !sym->attr.subroutine && !sym->attr.function)
5106 dont_write = true;
5107
5108 if (!gfc_check_symbol_access (sym))
5109 dont_write = true;
5110
5111 if (!dont_write)
5112 {
5113 p = get_pointer (sym);
5114 if (p->type == P_UNKNOWN)
5115 p->type = P_SYMBOL;
5116
5117 if (p->u.wsym.state != WRITTEN)
5118 {
5119 write_symbol (p->integer, sym);
5120 p->u.wsym.state = WRITTEN;
5121 }
5122 }
5123
5124 write_symbol0 (st->right);
5125 }
5126
5127
5128 /* Type for the temporary tree used when writing secondary symbols. */
5129
5130 struct sorted_pointer_info
5131 {
5132 BBT_HEADER (sorted_pointer_info);
5133
5134 pointer_info *p;
5135 };
5136
5137 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5138
5139 /* Recursively traverse the temporary tree, free its contents. */
5140
5141 static void
free_sorted_pointer_info_tree(sorted_pointer_info * p)5142 free_sorted_pointer_info_tree (sorted_pointer_info *p)
5143 {
5144 if (!p)
5145 return;
5146
5147 free_sorted_pointer_info_tree (p->left);
5148 free_sorted_pointer_info_tree (p->right);
5149
5150 free (p);
5151 }
5152
5153 /* Comparison function for the temporary tree. */
5154
5155 static int
compare_sorted_pointer_info(void * _spi1,void * _spi2)5156 compare_sorted_pointer_info (void *_spi1, void *_spi2)
5157 {
5158 sorted_pointer_info *spi1, *spi2;
5159 spi1 = (sorted_pointer_info *)_spi1;
5160 spi2 = (sorted_pointer_info *)_spi2;
5161
5162 if (spi1->p->integer < spi2->p->integer)
5163 return -1;
5164 if (spi1->p->integer > spi2->p->integer)
5165 return 1;
5166 return 0;
5167 }
5168
5169
5170 /* Finds the symbols that need to be written and collects them in the
5171 sorted_pi tree so that they can be traversed in an order
5172 independent of memory addresses. */
5173
5174 static void
find_symbols_to_write(sorted_pointer_info ** tree,pointer_info * p)5175 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
5176 {
5177 if (!p)
5178 return;
5179
5180 if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
5181 {
5182 sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
5183 sp->p = p;
5184
5185 gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
5186 }
5187
5188 find_symbols_to_write (tree, p->left);
5189 find_symbols_to_write (tree, p->right);
5190 }
5191
5192
5193 /* Recursive function that traverses the tree of symbols that need to be
5194 written and writes them in order. */
5195
5196 static void
write_symbol1_recursion(sorted_pointer_info * sp)5197 write_symbol1_recursion (sorted_pointer_info *sp)
5198 {
5199 if (!sp)
5200 return;
5201
5202 write_symbol1_recursion (sp->left);
5203
5204 pointer_info *p1 = sp->p;
5205 gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
5206
5207 p1->u.wsym.state = WRITTEN;
5208 write_symbol (p1->integer, p1->u.wsym.sym);
5209 p1->u.wsym.sym->attr.public_used = 1;
5210
5211 write_symbol1_recursion (sp->right);
5212 }
5213
5214
5215 /* Write the secondary set of symbols to the module file. These are
5216 symbols that were not public yet are needed by the public symbols
5217 or another dependent symbol. The act of writing a symbol can add
5218 symbols to the pointer_info tree, so we return nonzero if a symbol
5219 was written and pass that information upwards. The caller will
5220 then call this function again until nothing was written. It uses
5221 the utility functions and a temporary tree to ensure a reproducible
5222 ordering of the symbol output and thus the module file. */
5223
5224 static int
write_symbol1(pointer_info * p)5225 write_symbol1 (pointer_info *p)
5226 {
5227 if (!p)
5228 return 0;
5229
5230 /* Put symbols that need to be written into a tree sorted on the
5231 integer field. */
5232
5233 sorted_pointer_info *spi_root = NULL;
5234 find_symbols_to_write (&spi_root, p);
5235
5236 /* No symbols to write, return. */
5237 if (!spi_root)
5238 return 0;
5239
5240 /* Otherwise, write and free the tree again. */
5241 write_symbol1_recursion (spi_root);
5242 free_sorted_pointer_info_tree (spi_root);
5243
5244 return 1;
5245 }
5246
5247
5248 /* Write operator interfaces associated with a symbol. */
5249
5250 static void
write_operator(gfc_user_op * uop)5251 write_operator (gfc_user_op *uop)
5252 {
5253 static char nullstring[] = "";
5254 const char *p = nullstring;
5255
5256 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
5257 return;
5258
5259 mio_symbol_interface (&uop->name, &p, &uop->op);
5260 }
5261
5262
5263 /* Write generic interfaces from the namespace sym_root. */
5264
5265 static void
write_generic(gfc_symtree * st)5266 write_generic (gfc_symtree *st)
5267 {
5268 gfc_symbol *sym;
5269
5270 if (st == NULL)
5271 return;
5272
5273 write_generic (st->left);
5274
5275 sym = st->n.sym;
5276 if (sym && !check_unique_name (st->name)
5277 && sym->generic && gfc_check_symbol_access (sym))
5278 {
5279 if (!sym->module)
5280 sym->module = module_name;
5281
5282 mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5283 }
5284
5285 write_generic (st->right);
5286 }
5287
5288
5289 static void
write_symtree(gfc_symtree * st)5290 write_symtree (gfc_symtree *st)
5291 {
5292 gfc_symbol *sym;
5293 pointer_info *p;
5294
5295 sym = st->n.sym;
5296
5297 /* A symbol in an interface body must not be visible in the
5298 module file. */
5299 if (sym->ns != gfc_current_ns
5300 && sym->ns->proc_name
5301 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5302 return;
5303
5304 if (!gfc_check_symbol_access (sym)
5305 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5306 && !sym->attr.subroutine && !sym->attr.function))
5307 return;
5308
5309 if (check_unique_name (st->name))
5310 return;
5311
5312 p = find_pointer (sym);
5313 if (p == NULL)
5314 gfc_internal_error ("write_symtree(): Symbol not written");
5315
5316 mio_pool_string (&st->name);
5317 mio_integer (&st->ambiguous);
5318 mio_integer (&p->integer);
5319 }
5320
5321
5322 static void
write_module(void)5323 write_module (void)
5324 {
5325 int i;
5326
5327 /* Write the operator interfaces. */
5328 mio_lparen ();
5329
5330 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5331 {
5332 if (i == INTRINSIC_USER)
5333 continue;
5334
5335 mio_interface (check_access (gfc_current_ns->operator_access[i],
5336 gfc_current_ns->default_access)
5337 ? &gfc_current_ns->op[i] : NULL);
5338 }
5339
5340 mio_rparen ();
5341 write_char ('\n');
5342 write_char ('\n');
5343
5344 mio_lparen ();
5345 gfc_traverse_user_op (gfc_current_ns, write_operator);
5346 mio_rparen ();
5347 write_char ('\n');
5348 write_char ('\n');
5349
5350 mio_lparen ();
5351 write_generic (gfc_current_ns->sym_root);
5352 mio_rparen ();
5353 write_char ('\n');
5354 write_char ('\n');
5355
5356 mio_lparen ();
5357 write_blank_common ();
5358 write_common (gfc_current_ns->common_root);
5359 mio_rparen ();
5360 write_char ('\n');
5361 write_char ('\n');
5362
5363 mio_lparen ();
5364 write_equiv ();
5365 mio_rparen ();
5366 write_char ('\n');
5367 write_char ('\n');
5368
5369 mio_lparen ();
5370 gfc_traverse_symtree (gfc_current_ns->sym_root,
5371 write_derived_extensions);
5372 mio_rparen ();
5373 write_char ('\n');
5374 write_char ('\n');
5375
5376 /* Write symbol information. First we traverse all symbols in the
5377 primary namespace, writing those that need to be written.
5378 Sometimes writing one symbol will cause another to need to be
5379 written. A list of these symbols ends up on the write stack, and
5380 we end by popping the bottom of the stack and writing the symbol
5381 until the stack is empty. */
5382
5383 mio_lparen ();
5384
5385 write_symbol0 (gfc_current_ns->sym_root);
5386 while (write_symbol1 (pi_root))
5387 /* Nothing. */;
5388
5389 mio_rparen ();
5390
5391 write_char ('\n');
5392 write_char ('\n');
5393
5394 mio_lparen ();
5395 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5396 mio_rparen ();
5397 }
5398
5399
5400 /* Read a MD5 sum from the header of a module file. If the file cannot
5401 be opened, or we have any other error, we return -1. */
5402
5403 static int
read_md5_from_module_file(const char * filename,unsigned char md5[16])5404 read_md5_from_module_file (const char * filename, unsigned char md5[16])
5405 {
5406 FILE *file;
5407 char buf[1024];
5408 int n;
5409
5410 /* Open the file. */
5411 if ((file = fopen (filename, "r")) == NULL)
5412 return -1;
5413
5414 /* Read the first line. */
5415 if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5416 {
5417 fclose (file);
5418 return -1;
5419 }
5420
5421 /* The file also needs to be overwritten if the version number changed. */
5422 n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
5423 if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
5424 {
5425 fclose (file);
5426 return -1;
5427 }
5428
5429 /* Read a second line. */
5430 if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5431 {
5432 fclose (file);
5433 return -1;
5434 }
5435
5436 /* Close the file. */
5437 fclose (file);
5438
5439 /* If the header is not what we expect, or is too short, bail out. */
5440 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
5441 return -1;
5442
5443 /* Now, we have a real MD5, read it into the array. */
5444 for (n = 0; n < 16; n++)
5445 {
5446 unsigned int x;
5447
5448 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
5449 return -1;
5450
5451 md5[n] = x;
5452 }
5453
5454 return 0;
5455 }
5456
5457
5458 /* Given module, dump it to disk. If there was an error while
5459 processing the module, dump_flag will be set to zero and we delete
5460 the module file, even if it was already there. */
5461
5462 void
gfc_dump_module(const char * name,int dump_flag)5463 gfc_dump_module (const char *name, int dump_flag)
5464 {
5465 int n;
5466 char *filename, *filename_tmp;
5467 fpos_t md5_pos;
5468 unsigned char md5_new[16], md5_old[16];
5469
5470 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5471 if (gfc_option.module_dir != NULL)
5472 {
5473 n += strlen (gfc_option.module_dir);
5474 filename = (char *) alloca (n);
5475 strcpy (filename, gfc_option.module_dir);
5476 strcat (filename, name);
5477 }
5478 else
5479 {
5480 filename = (char *) alloca (n);
5481 strcpy (filename, name);
5482 }
5483 strcat (filename, MODULE_EXTENSION);
5484
5485 /* Name of the temporary file used to write the module. */
5486 filename_tmp = (char *) alloca (n + 1);
5487 strcpy (filename_tmp, filename);
5488 strcat (filename_tmp, "0");
5489
5490 /* There was an error while processing the module. We delete the
5491 module file, even if it was already there. */
5492 if (!dump_flag)
5493 {
5494 unlink (filename);
5495 return;
5496 }
5497
5498 if (gfc_cpp_makedep ())
5499 gfc_cpp_add_target (filename);
5500
5501 /* Write the module to the temporary file. */
5502 module_fp = fopen (filename_tmp, "w");
5503 if (module_fp == NULL)
5504 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5505 filename_tmp, xstrerror (errno));
5506
5507 /* Write the header, including space reserved for the MD5 sum. */
5508 fprintf (module_fp, "GFORTRAN module version '%s' created from %s\n"
5509 "MD5:", MOD_VERSION, gfc_source_file);
5510 fgetpos (module_fp, &md5_pos);
5511 fputs ("00000000000000000000000000000000 -- "
5512 "If you edit this, you'll get what you deserve.\n\n", module_fp);
5513
5514 /* Initialize the MD5 context that will be used for output. */
5515 md5_init_ctx (&ctx);
5516
5517 /* Write the module itself. */
5518 iomode = IO_OUTPUT;
5519 module_name = gfc_get_string (name);
5520
5521 init_pi_tree ();
5522
5523 write_module ();
5524
5525 free_pi_tree (pi_root);
5526 pi_root = NULL;
5527
5528 write_char ('\n');
5529
5530 /* Write the MD5 sum to the header of the module file. */
5531 md5_finish_ctx (&ctx, md5_new);
5532 fsetpos (module_fp, &md5_pos);
5533 for (n = 0; n < 16; n++)
5534 fprintf (module_fp, "%02x", md5_new[n]);
5535
5536 if (fclose (module_fp))
5537 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5538 filename_tmp, xstrerror (errno));
5539
5540 /* Read the MD5 from the header of the old module file and compare. */
5541 if (read_md5_from_module_file (filename, md5_old) != 0
5542 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
5543 {
5544 /* Module file have changed, replace the old one. */
5545 if (unlink (filename) && errno != ENOENT)
5546 gfc_fatal_error ("Can't delete module file '%s': %s", filename,
5547 xstrerror (errno));
5548 if (rename (filename_tmp, filename))
5549 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5550 filename_tmp, filename, xstrerror (errno));
5551 }
5552 else
5553 {
5554 if (unlink (filename_tmp))
5555 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5556 filename_tmp, xstrerror (errno));
5557 }
5558 }
5559
5560
5561 static void
create_intrinsic_function(const char * name,gfc_isym_id id,const char * modname,intmod_id module)5562 create_intrinsic_function (const char *name, gfc_isym_id id,
5563 const char *modname, intmod_id module)
5564 {
5565 gfc_intrinsic_sym *isym;
5566 gfc_symtree *tmp_symtree;
5567 gfc_symbol *sym;
5568
5569 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5570 if (tmp_symtree)
5571 {
5572 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5573 return;
5574 gfc_error ("Symbol '%s' already declared", name);
5575 }
5576
5577 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5578 sym = tmp_symtree->n.sym;
5579
5580 isym = gfc_intrinsic_function_by_id (id);
5581 gcc_assert (isym);
5582
5583 sym->attr.flavor = FL_PROCEDURE;
5584 sym->attr.intrinsic = 1;
5585
5586 sym->module = gfc_get_string (modname);
5587 sym->attr.use_assoc = 1;
5588 sym->from_intmod = module;
5589 sym->intmod_sym_id = id;
5590 }
5591
5592
5593 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5594 the current namespace for all named constants, pointer types, and
5595 procedures in the module unless the only clause was used or a rename
5596 list was provided. */
5597
5598 static void
import_iso_c_binding_module(void)5599 import_iso_c_binding_module (void)
5600 {
5601 gfc_symbol *mod_sym = NULL;
5602 gfc_symtree *mod_symtree = NULL;
5603 const char *iso_c_module_name = "__iso_c_binding";
5604 gfc_use_rename *u;
5605 int i;
5606
5607 /* Look only in the current namespace. */
5608 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5609
5610 if (mod_symtree == NULL)
5611 {
5612 /* symtree doesn't already exist in current namespace. */
5613 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5614 false);
5615
5616 if (mod_symtree != NULL)
5617 mod_sym = mod_symtree->n.sym;
5618 else
5619 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5620 "create symbol for %s", iso_c_module_name);
5621
5622 mod_sym->attr.flavor = FL_MODULE;
5623 mod_sym->attr.intrinsic = 1;
5624 mod_sym->module = gfc_get_string (iso_c_module_name);
5625 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5626 }
5627
5628 /* Generate the symbols for the named constants representing
5629 the kinds for intrinsic data types. */
5630 for (i = 0; i < ISOCBINDING_NUMBER; i++)
5631 {
5632 bool found = false;
5633 for (u = gfc_rename_list; u; u = u->next)
5634 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5635 {
5636 bool not_in_std;
5637 const char *name;
5638 u->found = 1;
5639 found = true;
5640
5641 switch (i)
5642 {
5643 #define NAMED_FUNCTION(a,b,c,d) \
5644 case a: \
5645 not_in_std = (gfc_option.allow_std & d) == 0; \
5646 name = b; \
5647 break;
5648 #include "iso-c-binding.def"
5649 #undef NAMED_FUNCTION
5650 #define NAMED_INTCST(a,b,c,d) \
5651 case a: \
5652 not_in_std = (gfc_option.allow_std & d) == 0; \
5653 name = b; \
5654 break;
5655 #include "iso-c-binding.def"
5656 #undef NAMED_INTCST
5657 #define NAMED_REALCST(a,b,c,d) \
5658 case a: \
5659 not_in_std = (gfc_option.allow_std & d) == 0; \
5660 name = b; \
5661 break;
5662 #include "iso-c-binding.def"
5663 #undef NAMED_REALCST
5664 #define NAMED_CMPXCST(a,b,c,d) \
5665 case a: \
5666 not_in_std = (gfc_option.allow_std & d) == 0; \
5667 name = b; \
5668 break;
5669 #include "iso-c-binding.def"
5670 #undef NAMED_CMPXCST
5671 default:
5672 not_in_std = false;
5673 name = "";
5674 }
5675
5676 if (not_in_std)
5677 {
5678 gfc_error ("The symbol '%s', referenced at %L, is not "
5679 "in the selected standard", name, &u->where);
5680 continue;
5681 }
5682
5683 switch (i)
5684 {
5685 #define NAMED_FUNCTION(a,b,c,d) \
5686 case a: \
5687 create_intrinsic_function (u->local_name[0] ? u->local_name \
5688 : u->use_name, \
5689 (gfc_isym_id) c, \
5690 iso_c_module_name, \
5691 INTMOD_ISO_C_BINDING); \
5692 break;
5693 #include "iso-c-binding.def"
5694 #undef NAMED_FUNCTION
5695
5696 default:
5697 generate_isocbinding_symbol (iso_c_module_name,
5698 (iso_c_binding_symbol) i,
5699 u->local_name[0] ? u->local_name
5700 : u->use_name);
5701 }
5702 }
5703
5704 if (!found && !only_flag)
5705 {
5706 /* Skip, if the symbol is not in the enabled standard. */
5707 switch (i)
5708 {
5709 #define NAMED_FUNCTION(a,b,c,d) \
5710 case a: \
5711 if ((gfc_option.allow_std & d) == 0) \
5712 continue; \
5713 break;
5714 #include "iso-c-binding.def"
5715 #undef NAMED_FUNCTION
5716
5717 #define NAMED_INTCST(a,b,c,d) \
5718 case a: \
5719 if ((gfc_option.allow_std & d) == 0) \
5720 continue; \
5721 break;
5722 #include "iso-c-binding.def"
5723 #undef NAMED_INTCST
5724 #define NAMED_REALCST(a,b,c,d) \
5725 case a: \
5726 if ((gfc_option.allow_std & d) == 0) \
5727 continue; \
5728 break;
5729 #include "iso-c-binding.def"
5730 #undef NAMED_REALCST
5731 #define NAMED_CMPXCST(a,b,c,d) \
5732 case a: \
5733 if ((gfc_option.allow_std & d) == 0) \
5734 continue; \
5735 break;
5736 #include "iso-c-binding.def"
5737 #undef NAMED_CMPXCST
5738 default:
5739 ; /* Not GFC_STD_* versioned. */
5740 }
5741
5742 switch (i)
5743 {
5744 #define NAMED_FUNCTION(a,b,c,d) \
5745 case a: \
5746 create_intrinsic_function (b, (gfc_isym_id) c, \
5747 iso_c_module_name, \
5748 INTMOD_ISO_C_BINDING); \
5749 break;
5750 #include "iso-c-binding.def"
5751 #undef NAMED_FUNCTION
5752
5753 default:
5754 generate_isocbinding_symbol (iso_c_module_name,
5755 (iso_c_binding_symbol) i, NULL);
5756 }
5757 }
5758 }
5759
5760 for (u = gfc_rename_list; u; u = u->next)
5761 {
5762 if (u->found)
5763 continue;
5764
5765 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5766 "module ISO_C_BINDING", u->use_name, &u->where);
5767 }
5768 }
5769
5770
5771 /* Add an integer named constant from a given module. */
5772
5773 static void
create_int_parameter(const char * name,int value,const char * modname,intmod_id module,int id)5774 create_int_parameter (const char *name, int value, const char *modname,
5775 intmod_id module, int id)
5776 {
5777 gfc_symtree *tmp_symtree;
5778 gfc_symbol *sym;
5779
5780 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5781 if (tmp_symtree != NULL)
5782 {
5783 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5784 return;
5785 else
5786 gfc_error ("Symbol '%s' already declared", name);
5787 }
5788
5789 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5790 sym = tmp_symtree->n.sym;
5791
5792 sym->module = gfc_get_string (modname);
5793 sym->attr.flavor = FL_PARAMETER;
5794 sym->ts.type = BT_INTEGER;
5795 sym->ts.kind = gfc_default_integer_kind;
5796 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
5797 sym->attr.use_assoc = 1;
5798 sym->from_intmod = module;
5799 sym->intmod_sym_id = id;
5800 }
5801
5802
5803 /* Value is already contained by the array constructor, but not
5804 yet the shape. */
5805
5806 static void
create_int_parameter_array(const char * name,int size,gfc_expr * value,const char * modname,intmod_id module,int id)5807 create_int_parameter_array (const char *name, int size, gfc_expr *value,
5808 const char *modname, intmod_id module, int id)
5809 {
5810 gfc_symtree *tmp_symtree;
5811 gfc_symbol *sym;
5812
5813 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5814 if (tmp_symtree != NULL)
5815 {
5816 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5817 return;
5818 else
5819 gfc_error ("Symbol '%s' already declared", name);
5820 }
5821
5822 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5823 sym = tmp_symtree->n.sym;
5824
5825 sym->module = gfc_get_string (modname);
5826 sym->attr.flavor = FL_PARAMETER;
5827 sym->ts.type = BT_INTEGER;
5828 sym->ts.kind = gfc_default_integer_kind;
5829 sym->attr.use_assoc = 1;
5830 sym->from_intmod = module;
5831 sym->intmod_sym_id = id;
5832 sym->attr.dimension = 1;
5833 sym->as = gfc_get_array_spec ();
5834 sym->as->rank = 1;
5835 sym->as->type = AS_EXPLICIT;
5836 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5837 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
5838
5839 sym->value = value;
5840 sym->value->shape = gfc_get_shape (1);
5841 mpz_init_set_ui (sym->value->shape[0], size);
5842 }
5843
5844
5845 /* Add an derived type for a given module. */
5846
5847 static void
create_derived_type(const char * name,const char * modname,intmod_id module,int id)5848 create_derived_type (const char *name, const char *modname,
5849 intmod_id module, int id)
5850 {
5851 gfc_symtree *tmp_symtree;
5852 gfc_symbol *sym, *dt_sym;
5853 gfc_interface *intr, *head;
5854
5855 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5856 if (tmp_symtree != NULL)
5857 {
5858 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5859 return;
5860 else
5861 gfc_error ("Symbol '%s' already declared", name);
5862 }
5863
5864 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5865 sym = tmp_symtree->n.sym;
5866 sym->module = gfc_get_string (modname);
5867 sym->from_intmod = module;
5868 sym->intmod_sym_id = id;
5869 sym->attr.flavor = FL_PROCEDURE;
5870 sym->attr.function = 1;
5871 sym->attr.generic = 1;
5872
5873 gfc_get_sym_tree (dt_upper_string (sym->name),
5874 gfc_current_ns, &tmp_symtree, false);
5875 dt_sym = tmp_symtree->n.sym;
5876 dt_sym->name = gfc_get_string (sym->name);
5877 dt_sym->attr.flavor = FL_DERIVED;
5878 dt_sym->attr.private_comp = 1;
5879 dt_sym->attr.zero_comp = 1;
5880 dt_sym->attr.use_assoc = 1;
5881 dt_sym->module = gfc_get_string (modname);
5882 dt_sym->from_intmod = module;
5883 dt_sym->intmod_sym_id = id;
5884
5885 head = sym->generic;
5886 intr = gfc_get_interface ();
5887 intr->sym = dt_sym;
5888 intr->where = gfc_current_locus;
5889 intr->next = head;
5890 sym->generic = intr;
5891 sym->attr.if_source = IFSRC_DECL;
5892 }
5893
5894
5895 /* USE the ISO_FORTRAN_ENV intrinsic module. */
5896
5897 static void
use_iso_fortran_env_module(void)5898 use_iso_fortran_env_module (void)
5899 {
5900 static char mod[] = "iso_fortran_env";
5901 gfc_use_rename *u;
5902 gfc_symbol *mod_sym;
5903 gfc_symtree *mod_symtree;
5904 gfc_expr *expr;
5905 int i, j;
5906
5907 intmod_sym symbol[] = {
5908 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5909 #include "iso-fortran-env.def"
5910 #undef NAMED_INTCST
5911 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5912 #include "iso-fortran-env.def"
5913 #undef NAMED_KINDARRAY
5914 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
5915 #include "iso-fortran-env.def"
5916 #undef NAMED_DERIVED_TYPE
5917 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5918 #include "iso-fortran-env.def"
5919 #undef NAMED_FUNCTION
5920 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5921
5922 i = 0;
5923 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5924 #include "iso-fortran-env.def"
5925 #undef NAMED_INTCST
5926
5927 /* Generate the symbol for the module itself. */
5928 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5929 if (mod_symtree == NULL)
5930 {
5931 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5932 gcc_assert (mod_symtree);
5933 mod_sym = mod_symtree->n.sym;
5934
5935 mod_sym->attr.flavor = FL_MODULE;
5936 mod_sym->attr.intrinsic = 1;
5937 mod_sym->module = gfc_get_string (mod);
5938 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5939 }
5940 else
5941 if (!mod_symtree->n.sym->attr.intrinsic)
5942 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5943 "non-intrinsic module name used previously", mod);
5944
5945 /* Generate the symbols for the module integer named constants. */
5946
5947 for (i = 0; symbol[i].name; i++)
5948 {
5949 bool found = false;
5950 for (u = gfc_rename_list; u; u = u->next)
5951 {
5952 if (strcmp (symbol[i].name, u->use_name) == 0)
5953 {
5954 found = true;
5955 u->found = 1;
5956
5957 if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
5958 "referenced at %L, is not in the selected "
5959 "standard", symbol[i].name,
5960 &u->where) == FAILURE)
5961 continue;
5962
5963 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5964 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5965 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5966 "constant from intrinsic module "
5967 "ISO_FORTRAN_ENV at %L is incompatible with "
5968 "option %s", &u->where,
5969 gfc_option.flag_default_integer
5970 ? "-fdefault-integer-8"
5971 : "-fdefault-real-8");
5972 switch (symbol[i].id)
5973 {
5974 #define NAMED_INTCST(a,b,c,d) \
5975 case a:
5976 #include "iso-fortran-env.def"
5977 #undef NAMED_INTCST
5978 create_int_parameter (u->local_name[0] ? u->local_name
5979 : u->use_name,
5980 symbol[i].value, mod,
5981 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5982 break;
5983
5984 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5985 case a:\
5986 expr = gfc_get_array_expr (BT_INTEGER, \
5987 gfc_default_integer_kind,\
5988 NULL); \
5989 for (j = 0; KINDS[j].kind != 0; j++) \
5990 gfc_constructor_append_expr (&expr->value.constructor, \
5991 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5992 KINDS[j].kind), NULL); \
5993 create_int_parameter_array (u->local_name[0] ? u->local_name \
5994 : u->use_name, \
5995 j, expr, mod, \
5996 INTMOD_ISO_FORTRAN_ENV, \
5997 symbol[i].id); \
5998 break;
5999 #include "iso-fortran-env.def"
6000 #undef NAMED_KINDARRAY
6001
6002 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6003 case a:
6004 #include "iso-fortran-env.def"
6005 create_derived_type (u->local_name[0] ? u->local_name
6006 : u->use_name,
6007 mod, INTMOD_ISO_FORTRAN_ENV,
6008 symbol[i].id);
6009 break;
6010 #undef NAMED_DERIVED_TYPE
6011
6012 #define NAMED_FUNCTION(a,b,c,d) \
6013 case a:
6014 #include "iso-fortran-env.def"
6015 #undef NAMED_FUNCTION
6016 create_intrinsic_function (u->local_name[0] ? u->local_name
6017 : u->use_name,
6018 (gfc_isym_id) symbol[i].value, mod,
6019 INTMOD_ISO_FORTRAN_ENV);
6020 break;
6021
6022 default:
6023 gcc_unreachable ();
6024 }
6025 }
6026 }
6027
6028 if (!found && !only_flag)
6029 {
6030 if ((gfc_option.allow_std & symbol[i].standard) == 0)
6031 continue;
6032
6033 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
6034 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6035 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6036 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6037 "incompatible with option %s",
6038 gfc_option.flag_default_integer
6039 ? "-fdefault-integer-8" : "-fdefault-real-8");
6040
6041 switch (symbol[i].id)
6042 {
6043 #define NAMED_INTCST(a,b,c,d) \
6044 case a:
6045 #include "iso-fortran-env.def"
6046 #undef NAMED_INTCST
6047 create_int_parameter (symbol[i].name, symbol[i].value, mod,
6048 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6049 break;
6050
6051 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6052 case a:\
6053 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6054 NULL); \
6055 for (j = 0; KINDS[j].kind != 0; j++) \
6056 gfc_constructor_append_expr (&expr->value.constructor, \
6057 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6058 KINDS[j].kind), NULL); \
6059 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6060 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6061 break;
6062 #include "iso-fortran-env.def"
6063 #undef NAMED_KINDARRAY
6064
6065 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6066 case a:
6067 #include "iso-fortran-env.def"
6068 create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
6069 symbol[i].id);
6070 break;
6071 #undef NAMED_DERIVED_TYPE
6072
6073 #define NAMED_FUNCTION(a,b,c,d) \
6074 case a:
6075 #include "iso-fortran-env.def"
6076 #undef NAMED_FUNCTION
6077 create_intrinsic_function (symbol[i].name,
6078 (gfc_isym_id) symbol[i].value, mod,
6079 INTMOD_ISO_FORTRAN_ENV);
6080 break;
6081
6082 default:
6083 gcc_unreachable ();
6084 }
6085 }
6086 }
6087
6088 for (u = gfc_rename_list; u; u = u->next)
6089 {
6090 if (u->found)
6091 continue;
6092
6093 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6094 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
6095 }
6096 }
6097
6098
6099 /* Process a USE directive. */
6100
6101 static void
gfc_use_module(gfc_use_list * module)6102 gfc_use_module (gfc_use_list *module)
6103 {
6104 char *filename;
6105 gfc_state_data *p;
6106 int c, line, start;
6107 gfc_symtree *mod_symtree;
6108 gfc_use_list *use_stmt;
6109 locus old_locus = gfc_current_locus;
6110
6111 gfc_current_locus = module->where;
6112 module_name = module->module_name;
6113 gfc_rename_list = module->rename;
6114 only_flag = module->only_flag;
6115
6116 filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
6117 + 1);
6118 strcpy (filename, module_name);
6119 strcat (filename, MODULE_EXTENSION);
6120
6121 /* First, try to find an non-intrinsic module, unless the USE statement
6122 specified that the module is intrinsic. */
6123 module_fp = NULL;
6124 if (!module->intrinsic)
6125 module_fp = gfc_open_included_file (filename, true, true);
6126
6127 /* Then, see if it's an intrinsic one, unless the USE statement
6128 specified that the module is non-intrinsic. */
6129 if (module_fp == NULL && !module->non_intrinsic)
6130 {
6131 if (strcmp (module_name, "iso_fortran_env") == 0
6132 && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
6133 "intrinsic module at %C") != FAILURE)
6134 {
6135 use_iso_fortran_env_module ();
6136 free_rename (module->rename);
6137 module->rename = NULL;
6138 gfc_current_locus = old_locus;
6139 module->intrinsic = true;
6140 return;
6141 }
6142
6143 if (strcmp (module_name, "iso_c_binding") == 0
6144 && gfc_notify_std (GFC_STD_F2003,
6145 "ISO_C_BINDING module at %C") != FAILURE)
6146 {
6147 import_iso_c_binding_module();
6148 free_rename (module->rename);
6149 module->rename = NULL;
6150 gfc_current_locus = old_locus;
6151 module->intrinsic = true;
6152 return;
6153 }
6154
6155 module_fp = gfc_open_intrinsic_module (filename);
6156
6157 if (module_fp == NULL && module->intrinsic)
6158 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6159 module_name);
6160 }
6161
6162 if (module_fp == NULL)
6163 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6164 filename, xstrerror (errno));
6165
6166 /* Check that we haven't already USEd an intrinsic module with the
6167 same name. */
6168
6169 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
6170 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
6171 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6172 "intrinsic module name used previously", module_name);
6173
6174 iomode = IO_INPUT;
6175 module_line = 1;
6176 module_column = 1;
6177 start = 0;
6178
6179 /* Skip the first two lines of the module, after checking that this is
6180 a gfortran module file. */
6181 line = 0;
6182 while (line < 2)
6183 {
6184 c = module_char ();
6185 if (c == EOF)
6186 bad_module ("Unexpected end of module");
6187 if (start++ < 3)
6188 parse_name (c);
6189 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
6190 || (start == 2 && strcmp (atom_name, " module") != 0))
6191 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6192 " module file", filename);
6193 if (start == 3)
6194 {
6195 if (strcmp (atom_name, " version") != 0
6196 || module_char () != ' '
6197 || parse_atom () != ATOM_STRING
6198 || strcmp (atom_string, MOD_VERSION))
6199 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6200 " because it was created by a different"
6201 " version of GNU Fortran", filename);
6202
6203 free (atom_string);
6204 }
6205
6206 if (c == '\n')
6207 line++;
6208 }
6209
6210 /* Make sure we're not reading the same module that we may be building. */
6211 for (p = gfc_state_stack; p; p = p->previous)
6212 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
6213 gfc_fatal_error ("Can't USE the same module we're building!");
6214
6215 init_pi_tree ();
6216 init_true_name_tree ();
6217
6218 read_module ();
6219
6220 free_true_name (true_name_root);
6221 true_name_root = NULL;
6222
6223 free_pi_tree (pi_root);
6224 pi_root = NULL;
6225
6226 fclose (module_fp);
6227
6228 use_stmt = gfc_get_use_list ();
6229 *use_stmt = *module;
6230 use_stmt->next = gfc_current_ns->use_stmts;
6231 gfc_current_ns->use_stmts = use_stmt;
6232
6233 gfc_current_locus = old_locus;
6234 }
6235
6236
6237 /* Remove duplicated intrinsic operators from the rename list. */
6238
6239 static void
rename_list_remove_duplicate(gfc_use_rename * list)6240 rename_list_remove_duplicate (gfc_use_rename *list)
6241 {
6242 gfc_use_rename *seek, *last;
6243
6244 for (; list; list = list->next)
6245 if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
6246 {
6247 last = list;
6248 for (seek = list->next; seek; seek = last->next)
6249 {
6250 if (list->op == seek->op)
6251 {
6252 last->next = seek->next;
6253 free (seek);
6254 }
6255 else
6256 last = seek;
6257 }
6258 }
6259 }
6260
6261
6262 /* Process all USE directives. */
6263
6264 void
gfc_use_modules(void)6265 gfc_use_modules (void)
6266 {
6267 gfc_use_list *next, *seek, *last;
6268
6269 for (next = module_list; next; next = next->next)
6270 {
6271 bool non_intrinsic = next->non_intrinsic;
6272 bool intrinsic = next->intrinsic;
6273 bool neither = !non_intrinsic && !intrinsic;
6274
6275 for (seek = next->next; seek; seek = seek->next)
6276 {
6277 if (next->module_name != seek->module_name)
6278 continue;
6279
6280 if (seek->non_intrinsic)
6281 non_intrinsic = true;
6282 else if (seek->intrinsic)
6283 intrinsic = true;
6284 else
6285 neither = true;
6286 }
6287
6288 if (intrinsic && neither && !non_intrinsic)
6289 {
6290 char *filename;
6291 FILE *fp;
6292
6293 filename = XALLOCAVEC (char,
6294 strlen (next->module_name)
6295 + strlen (MODULE_EXTENSION) + 1);
6296 strcpy (filename, next->module_name);
6297 strcat (filename, MODULE_EXTENSION);
6298 fp = gfc_open_included_file (filename, true, true);
6299 if (fp != NULL)
6300 {
6301 non_intrinsic = true;
6302 fclose (fp);
6303 }
6304 }
6305
6306 last = next;
6307 for (seek = next->next; seek; seek = last->next)
6308 {
6309 if (next->module_name != seek->module_name)
6310 {
6311 last = seek;
6312 continue;
6313 }
6314
6315 if ((!next->intrinsic && !seek->intrinsic)
6316 || (next->intrinsic && seek->intrinsic)
6317 || !non_intrinsic)
6318 {
6319 if (!seek->only_flag)
6320 next->only_flag = false;
6321 if (seek->rename)
6322 {
6323 gfc_use_rename *r = seek->rename;
6324 while (r->next)
6325 r = r->next;
6326 r->next = next->rename;
6327 next->rename = seek->rename;
6328 }
6329 last->next = seek->next;
6330 free (seek);
6331 }
6332 else
6333 last = seek;
6334 }
6335 }
6336
6337 for (; module_list; module_list = next)
6338 {
6339 next = module_list->next;
6340 rename_list_remove_duplicate (module_list->rename);
6341 gfc_use_module (module_list);
6342 free (module_list);
6343 }
6344 gfc_rename_list = NULL;
6345 }
6346
6347
6348 void
gfc_free_use_stmts(gfc_use_list * use_stmts)6349 gfc_free_use_stmts (gfc_use_list *use_stmts)
6350 {
6351 gfc_use_list *next;
6352 for (; use_stmts; use_stmts = next)
6353 {
6354 gfc_use_rename *next_rename;
6355
6356 for (; use_stmts->rename; use_stmts->rename = next_rename)
6357 {
6358 next_rename = use_stmts->rename->next;
6359 free (use_stmts->rename);
6360 }
6361 next = use_stmts->next;
6362 free (use_stmts);
6363 }
6364 }
6365
6366
6367 void
gfc_module_init_2(void)6368 gfc_module_init_2 (void)
6369 {
6370 last_atom = ATOM_LPAREN;
6371 gfc_rename_list = NULL;
6372 module_list = NULL;
6373 }
6374
6375
6376 void
gfc_module_done_2(void)6377 gfc_module_done_2 (void)
6378 {
6379 free_rename (gfc_rename_list);
6380 gfc_rename_list = NULL;
6381 }
6382