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