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_OACC_ROUTINE_NOHOST,
2092 AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS,
2093 AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS,
2094 AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL,
2095 AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST,
2096 AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY
2097 };
2098
2099 static const mstring attr_bits[] =
2100 {
2101 minit ("ALLOCATABLE", AB_ALLOCATABLE),
2102 minit ("ARTIFICIAL", AB_ARTIFICIAL),
2103 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
2104 minit ("DIMENSION", AB_DIMENSION),
2105 minit ("CODIMENSION", AB_CODIMENSION),
2106 minit ("CONTIGUOUS", AB_CONTIGUOUS),
2107 minit ("EXTERNAL", AB_EXTERNAL),
2108 minit ("INTRINSIC", AB_INTRINSIC),
2109 minit ("OPTIONAL", AB_OPTIONAL),
2110 minit ("POINTER", AB_POINTER),
2111 minit ("VOLATILE", AB_VOLATILE),
2112 minit ("TARGET", AB_TARGET),
2113 minit ("THREADPRIVATE", AB_THREADPRIVATE),
2114 minit ("DUMMY", AB_DUMMY),
2115 minit ("RESULT", AB_RESULT),
2116 minit ("DATA", AB_DATA),
2117 minit ("IN_NAMELIST", AB_IN_NAMELIST),
2118 minit ("IN_COMMON", AB_IN_COMMON),
2119 minit ("FUNCTION", AB_FUNCTION),
2120 minit ("SUBROUTINE", AB_SUBROUTINE),
2121 minit ("SEQUENCE", AB_SEQUENCE),
2122 minit ("ELEMENTAL", AB_ELEMENTAL),
2123 minit ("PURE", AB_PURE),
2124 minit ("RECURSIVE", AB_RECURSIVE),
2125 minit ("GENERIC", AB_GENERIC),
2126 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
2127 minit ("CRAY_POINTER", AB_CRAY_POINTER),
2128 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
2129 minit ("IS_BIND_C", AB_IS_BIND_C),
2130 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
2131 minit ("IS_ISO_C", AB_IS_ISO_C),
2132 minit ("VALUE", AB_VALUE),
2133 minit ("ALLOC_COMP", AB_ALLOC_COMP),
2134 minit ("COARRAY_COMP", AB_COARRAY_COMP),
2135 minit ("LOCK_COMP", AB_LOCK_COMP),
2136 minit ("EVENT_COMP", AB_EVENT_COMP),
2137 minit ("POINTER_COMP", AB_POINTER_COMP),
2138 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
2139 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
2140 minit ("ZERO_COMP", AB_ZERO_COMP),
2141 minit ("PROTECTED", AB_PROTECTED),
2142 minit ("ABSTRACT", AB_ABSTRACT),
2143 minit ("IS_CLASS", AB_IS_CLASS),
2144 minit ("PROCEDURE", AB_PROCEDURE),
2145 minit ("PROC_POINTER", AB_PROC_POINTER),
2146 minit ("VTYPE", AB_VTYPE),
2147 minit ("VTAB", AB_VTAB),
2148 minit ("CLASS_POINTER", AB_CLASS_POINTER),
2149 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
2150 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
2151 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
2152 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
2153 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
2154 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
2155 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
2156 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
2157 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
2158 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
2159 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
2160 minit ("PDT_KIND", AB_PDT_KIND),
2161 minit ("PDT_LEN", AB_PDT_LEN),
2162 minit ("PDT_TYPE", AB_PDT_TYPE),
2163 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
2164 minit ("PDT_ARRAY", AB_PDT_ARRAY),
2165 minit ("PDT_STRING", AB_PDT_STRING),
2166 minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
2167 minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
2168 minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
2169 minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ),
2170 minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST),
2171 minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD),
2172 minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS),
2173 minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY),
2174 minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS),
2175 minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST),
2176 minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL),
2177 minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED),
2178 minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST),
2179 minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST),
2180 minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY),
2181 minit (NULL, -1)
2182 };
2183
2184 /* For binding attributes. */
2185 static const mstring binding_passing[] =
2186 {
2187 minit ("PASS", 0),
2188 minit ("NOPASS", 1),
2189 minit (NULL, -1)
2190 };
2191 static const mstring binding_overriding[] =
2192 {
2193 minit ("OVERRIDABLE", 0),
2194 minit ("NON_OVERRIDABLE", 1),
2195 minit ("DEFERRED", 2),
2196 minit (NULL, -1)
2197 };
2198 static const mstring binding_generic[] =
2199 {
2200 minit ("SPECIFIC", 0),
2201 minit ("GENERIC", 1),
2202 minit (NULL, -1)
2203 };
2204 static const mstring binding_ppc[] =
2205 {
2206 minit ("NO_PPC", 0),
2207 minit ("PPC", 1),
2208 minit (NULL, -1)
2209 };
2210
2211 /* Specialization of mio_name. */
2212 DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME(ar_type)2213 DECL_MIO_NAME (ar_type)
2214 DECL_MIO_NAME (array_type)
2215 DECL_MIO_NAME (bt)
2216 DECL_MIO_NAME (expr_t)
2217 DECL_MIO_NAME (gfc_access)
2218 DECL_MIO_NAME (gfc_intrinsic_op)
2219 DECL_MIO_NAME (ifsrc)
2220 DECL_MIO_NAME (save_state)
2221 DECL_MIO_NAME (procedure_type)
2222 DECL_MIO_NAME (ref_type)
2223 DECL_MIO_NAME (sym_flavor)
2224 DECL_MIO_NAME (sym_intent)
2225 DECL_MIO_NAME (inquiry_type)
2226 #undef DECL_MIO_NAME
2227
2228 /* Verify OACC_ROUTINE_LOP_NONE. */
2229
2230 static void
2231 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
2232 {
2233 if (lop != OACC_ROUTINE_LOP_NONE)
2234 bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2235 }
2236
2237 /* Symbol attributes are stored in list with the first three elements
2238 being the enumerated fields, while the remaining elements (if any)
2239 indicate the individual attribute bits. The access field is not
2240 saved-- it controls what symbols are exported when a module is
2241 written. */
2242
2243 static void
mio_symbol_attribute(symbol_attribute * attr)2244 mio_symbol_attribute (symbol_attribute *attr)
2245 {
2246 atom_type t;
2247 unsigned ext_attr,extension_level;
2248
2249 mio_lparen ();
2250
2251 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2252 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2253 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2254 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2255 attr->save = MIO_NAME (save_state) (attr->save, save_status);
2256
2257 ext_attr = attr->ext_attr;
2258 mio_integer ((int *) &ext_attr);
2259 attr->ext_attr = ext_attr;
2260
2261 extension_level = attr->extension;
2262 mio_integer ((int *) &extension_level);
2263 attr->extension = extension_level;
2264
2265 if (iomode == IO_OUTPUT)
2266 {
2267 if (attr->allocatable)
2268 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2269 if (attr->artificial)
2270 MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2271 if (attr->asynchronous)
2272 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2273 if (attr->dimension)
2274 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2275 if (attr->codimension)
2276 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2277 if (attr->contiguous)
2278 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2279 if (attr->external)
2280 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2281 if (attr->intrinsic)
2282 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2283 if (attr->optional)
2284 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2285 if (attr->pointer)
2286 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2287 if (attr->class_pointer)
2288 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2289 if (attr->is_protected)
2290 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2291 if (attr->value)
2292 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2293 if (attr->volatile_)
2294 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2295 if (attr->target)
2296 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2297 if (attr->threadprivate)
2298 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2299 if (attr->dummy)
2300 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2301 if (attr->result)
2302 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2303 /* We deliberately don't preserve the "entry" flag. */
2304
2305 if (attr->data)
2306 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2307 if (attr->in_namelist)
2308 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2309 if (attr->in_common)
2310 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2311
2312 if (attr->function)
2313 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2314 if (attr->subroutine)
2315 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2316 if (attr->generic)
2317 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2318 if (attr->abstract)
2319 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2320
2321 if (attr->sequence)
2322 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2323 if (attr->elemental)
2324 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2325 if (attr->pure)
2326 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2327 if (attr->implicit_pure)
2328 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2329 if (attr->unlimited_polymorphic)
2330 MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2331 if (attr->recursive)
2332 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2333 if (attr->always_explicit)
2334 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2335 if (attr->cray_pointer)
2336 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2337 if (attr->cray_pointee)
2338 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2339 if (attr->is_bind_c)
2340 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2341 if (attr->is_c_interop)
2342 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2343 if (attr->is_iso_c)
2344 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2345 if (attr->alloc_comp)
2346 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2347 if (attr->pointer_comp)
2348 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2349 if (attr->proc_pointer_comp)
2350 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2351 if (attr->private_comp)
2352 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2353 if (attr->coarray_comp)
2354 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2355 if (attr->lock_comp)
2356 MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2357 if (attr->event_comp)
2358 MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
2359 if (attr->zero_comp)
2360 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2361 if (attr->is_class)
2362 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2363 if (attr->procedure)
2364 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2365 if (attr->proc_pointer)
2366 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2367 if (attr->vtype)
2368 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2369 if (attr->vtab)
2370 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2371 if (attr->omp_declare_target)
2372 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2373 if (attr->array_outer_dependency)
2374 MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
2375 if (attr->module_procedure)
2376 MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
2377 if (attr->oacc_declare_create)
2378 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
2379 if (attr->oacc_declare_copyin)
2380 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
2381 if (attr->oacc_declare_deviceptr)
2382 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
2383 if (attr->oacc_declare_device_resident)
2384 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
2385 if (attr->oacc_declare_link)
2386 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
2387 if (attr->omp_declare_target_link)
2388 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
2389 if (attr->pdt_kind)
2390 MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
2391 if (attr->pdt_len)
2392 MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
2393 if (attr->pdt_type)
2394 MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
2395 if (attr->pdt_template)
2396 MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
2397 if (attr->pdt_array)
2398 MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
2399 if (attr->pdt_string)
2400 MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
2401 switch (attr->oacc_routine_lop)
2402 {
2403 case OACC_ROUTINE_LOP_NONE:
2404 /* This is the default anyway, and for maintaining compatibility with
2405 the current MOD_VERSION, we're not emitting anything in that
2406 case. */
2407 break;
2408 case OACC_ROUTINE_LOP_GANG:
2409 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
2410 break;
2411 case OACC_ROUTINE_LOP_WORKER:
2412 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
2413 break;
2414 case OACC_ROUTINE_LOP_VECTOR:
2415 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
2416 break;
2417 case OACC_ROUTINE_LOP_SEQ:
2418 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits);
2419 break;
2420 case OACC_ROUTINE_LOP_ERROR:
2421 /* ... intentionally omitted here; it's only unsed internally. */
2422 default:
2423 gcc_unreachable ();
2424 }
2425 if (attr->oacc_routine_nohost)
2426 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits);
2427
2428 if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires)
2429 {
2430 if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
2431 MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits);
2432 if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)
2433 MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits);
2434 if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
2435 MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits);
2436 if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
2437 MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits);
2438 if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2439 == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
2440 MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits);
2441 if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2442 == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
2443 MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits);
2444 if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2445 == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
2446 MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits);
2447 }
2448 switch (attr->omp_device_type)
2449 {
2450 case OMP_DEVICE_TYPE_UNSET:
2451 break;
2452 case OMP_DEVICE_TYPE_HOST:
2453 MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits);
2454 break;
2455 case OMP_DEVICE_TYPE_NOHOST:
2456 MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
2457 break;
2458 case OMP_DEVICE_TYPE_ANY:
2459 MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
2460 break;
2461 default:
2462 gcc_unreachable ();
2463 }
2464 mio_rparen ();
2465 }
2466 else
2467 {
2468 for (;;)
2469 {
2470 t = parse_atom ();
2471 if (t == ATOM_RPAREN)
2472 break;
2473 if (t != ATOM_NAME)
2474 bad_module ("Expected attribute bit name");
2475
2476 switch ((ab_attribute) find_enum (attr_bits))
2477 {
2478 case AB_ALLOCATABLE:
2479 attr->allocatable = 1;
2480 break;
2481 case AB_ARTIFICIAL:
2482 attr->artificial = 1;
2483 break;
2484 case AB_ASYNCHRONOUS:
2485 attr->asynchronous = 1;
2486 break;
2487 case AB_DIMENSION:
2488 attr->dimension = 1;
2489 break;
2490 case AB_CODIMENSION:
2491 attr->codimension = 1;
2492 break;
2493 case AB_CONTIGUOUS:
2494 attr->contiguous = 1;
2495 break;
2496 case AB_EXTERNAL:
2497 attr->external = 1;
2498 break;
2499 case AB_INTRINSIC:
2500 attr->intrinsic = 1;
2501 break;
2502 case AB_OPTIONAL:
2503 attr->optional = 1;
2504 break;
2505 case AB_POINTER:
2506 attr->pointer = 1;
2507 break;
2508 case AB_CLASS_POINTER:
2509 attr->class_pointer = 1;
2510 break;
2511 case AB_PROTECTED:
2512 attr->is_protected = 1;
2513 break;
2514 case AB_VALUE:
2515 attr->value = 1;
2516 break;
2517 case AB_VOLATILE:
2518 attr->volatile_ = 1;
2519 break;
2520 case AB_TARGET:
2521 attr->target = 1;
2522 break;
2523 case AB_THREADPRIVATE:
2524 attr->threadprivate = 1;
2525 break;
2526 case AB_DUMMY:
2527 attr->dummy = 1;
2528 break;
2529 case AB_RESULT:
2530 attr->result = 1;
2531 break;
2532 case AB_DATA:
2533 attr->data = 1;
2534 break;
2535 case AB_IN_NAMELIST:
2536 attr->in_namelist = 1;
2537 break;
2538 case AB_IN_COMMON:
2539 attr->in_common = 1;
2540 break;
2541 case AB_FUNCTION:
2542 attr->function = 1;
2543 break;
2544 case AB_SUBROUTINE:
2545 attr->subroutine = 1;
2546 break;
2547 case AB_GENERIC:
2548 attr->generic = 1;
2549 break;
2550 case AB_ABSTRACT:
2551 attr->abstract = 1;
2552 break;
2553 case AB_SEQUENCE:
2554 attr->sequence = 1;
2555 break;
2556 case AB_ELEMENTAL:
2557 attr->elemental = 1;
2558 break;
2559 case AB_PURE:
2560 attr->pure = 1;
2561 break;
2562 case AB_IMPLICIT_PURE:
2563 attr->implicit_pure = 1;
2564 break;
2565 case AB_UNLIMITED_POLY:
2566 attr->unlimited_polymorphic = 1;
2567 break;
2568 case AB_RECURSIVE:
2569 attr->recursive = 1;
2570 break;
2571 case AB_ALWAYS_EXPLICIT:
2572 attr->always_explicit = 1;
2573 break;
2574 case AB_CRAY_POINTER:
2575 attr->cray_pointer = 1;
2576 break;
2577 case AB_CRAY_POINTEE:
2578 attr->cray_pointee = 1;
2579 break;
2580 case AB_IS_BIND_C:
2581 attr->is_bind_c = 1;
2582 break;
2583 case AB_IS_C_INTEROP:
2584 attr->is_c_interop = 1;
2585 break;
2586 case AB_IS_ISO_C:
2587 attr->is_iso_c = 1;
2588 break;
2589 case AB_ALLOC_COMP:
2590 attr->alloc_comp = 1;
2591 break;
2592 case AB_COARRAY_COMP:
2593 attr->coarray_comp = 1;
2594 break;
2595 case AB_LOCK_COMP:
2596 attr->lock_comp = 1;
2597 break;
2598 case AB_EVENT_COMP:
2599 attr->event_comp = 1;
2600 break;
2601 case AB_POINTER_COMP:
2602 attr->pointer_comp = 1;
2603 break;
2604 case AB_PROC_POINTER_COMP:
2605 attr->proc_pointer_comp = 1;
2606 break;
2607 case AB_PRIVATE_COMP:
2608 attr->private_comp = 1;
2609 break;
2610 case AB_ZERO_COMP:
2611 attr->zero_comp = 1;
2612 break;
2613 case AB_IS_CLASS:
2614 attr->is_class = 1;
2615 break;
2616 case AB_PROCEDURE:
2617 attr->procedure = 1;
2618 break;
2619 case AB_PROC_POINTER:
2620 attr->proc_pointer = 1;
2621 break;
2622 case AB_VTYPE:
2623 attr->vtype = 1;
2624 break;
2625 case AB_VTAB:
2626 attr->vtab = 1;
2627 break;
2628 case AB_OMP_DECLARE_TARGET:
2629 attr->omp_declare_target = 1;
2630 break;
2631 case AB_OMP_DECLARE_TARGET_LINK:
2632 attr->omp_declare_target_link = 1;
2633 break;
2634 case AB_ARRAY_OUTER_DEPENDENCY:
2635 attr->array_outer_dependency =1;
2636 break;
2637 case AB_MODULE_PROCEDURE:
2638 attr->module_procedure =1;
2639 break;
2640 case AB_OACC_DECLARE_CREATE:
2641 attr->oacc_declare_create = 1;
2642 break;
2643 case AB_OACC_DECLARE_COPYIN:
2644 attr->oacc_declare_copyin = 1;
2645 break;
2646 case AB_OACC_DECLARE_DEVICEPTR:
2647 attr->oacc_declare_deviceptr = 1;
2648 break;
2649 case AB_OACC_DECLARE_DEVICE_RESIDENT:
2650 attr->oacc_declare_device_resident = 1;
2651 break;
2652 case AB_OACC_DECLARE_LINK:
2653 attr->oacc_declare_link = 1;
2654 break;
2655 case AB_PDT_KIND:
2656 attr->pdt_kind = 1;
2657 break;
2658 case AB_PDT_LEN:
2659 attr->pdt_len = 1;
2660 break;
2661 case AB_PDT_TYPE:
2662 attr->pdt_type = 1;
2663 break;
2664 case AB_PDT_TEMPLATE:
2665 attr->pdt_template = 1;
2666 break;
2667 case AB_PDT_ARRAY:
2668 attr->pdt_array = 1;
2669 break;
2670 case AB_PDT_STRING:
2671 attr->pdt_string = 1;
2672 break;
2673 case AB_OACC_ROUTINE_LOP_GANG:
2674 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2675 attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG;
2676 break;
2677 case AB_OACC_ROUTINE_LOP_WORKER:
2678 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2679 attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER;
2680 break;
2681 case AB_OACC_ROUTINE_LOP_VECTOR:
2682 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2683 attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR;
2684 break;
2685 case AB_OACC_ROUTINE_LOP_SEQ:
2686 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2687 attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ;
2688 break;
2689 case AB_OACC_ROUTINE_NOHOST:
2690 attr->oacc_routine_nohost = 1;
2691 break;
2692 case AB_OMP_REQ_REVERSE_OFFLOAD:
2693 gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD,
2694 "reverse_offload",
2695 &gfc_current_locus,
2696 module_name);
2697 break;
2698 case AB_OMP_REQ_UNIFIED_ADDRESS:
2699 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS,
2700 "unified_address",
2701 &gfc_current_locus,
2702 module_name);
2703 break;
2704 case AB_OMP_REQ_UNIFIED_SHARED_MEMORY:
2705 gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY,
2706 "unified_shared_memory",
2707 &gfc_current_locus,
2708 module_name);
2709 break;
2710 case AB_OMP_REQ_DYNAMIC_ALLOCATORS:
2711 gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS,
2712 "dynamic_allocators",
2713 &gfc_current_locus,
2714 module_name);
2715 break;
2716 case AB_OMP_REQ_MEM_ORDER_SEQ_CST:
2717 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST,
2718 "seq_cst", &gfc_current_locus,
2719 module_name);
2720 break;
2721 case AB_OMP_REQ_MEM_ORDER_ACQ_REL:
2722 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL,
2723 "acq_rel", &gfc_current_locus,
2724 module_name);
2725 break;
2726 case AB_OMP_REQ_MEM_ORDER_RELAXED:
2727 gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED,
2728 "relaxed", &gfc_current_locus,
2729 module_name);
2730 break;
2731 case AB_OMP_DEVICE_TYPE_HOST:
2732 attr->omp_device_type = OMP_DEVICE_TYPE_HOST;
2733 break;
2734 case AB_OMP_DEVICE_TYPE_NOHOST:
2735 attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST;
2736 break;
2737 case AB_OMP_DEVICE_TYPE_ANY:
2738 attr->omp_device_type = OMP_DEVICE_TYPE_ANY;
2739 break;
2740 }
2741 }
2742 }
2743 }
2744
2745
2746 static const mstring bt_types[] = {
2747 minit ("INTEGER", BT_INTEGER),
2748 minit ("REAL", BT_REAL),
2749 minit ("COMPLEX", BT_COMPLEX),
2750 minit ("LOGICAL", BT_LOGICAL),
2751 minit ("CHARACTER", BT_CHARACTER),
2752 minit ("UNION", BT_UNION),
2753 minit ("DERIVED", BT_DERIVED),
2754 minit ("CLASS", BT_CLASS),
2755 minit ("PROCEDURE", BT_PROCEDURE),
2756 minit ("UNKNOWN", BT_UNKNOWN),
2757 minit ("VOID", BT_VOID),
2758 minit ("ASSUMED", BT_ASSUMED),
2759 minit (NULL, -1)
2760 };
2761
2762
2763 static void
mio_charlen(gfc_charlen ** clp)2764 mio_charlen (gfc_charlen **clp)
2765 {
2766 gfc_charlen *cl;
2767
2768 mio_lparen ();
2769
2770 if (iomode == IO_OUTPUT)
2771 {
2772 cl = *clp;
2773 if (cl != NULL)
2774 mio_expr (&cl->length);
2775 }
2776 else
2777 {
2778 if (peek_atom () != ATOM_RPAREN)
2779 {
2780 cl = gfc_new_charlen (gfc_current_ns, NULL);
2781 mio_expr (&cl->length);
2782 *clp = cl;
2783 }
2784 }
2785
2786 mio_rparen ();
2787 }
2788
2789
2790 /* See if a name is a generated name. */
2791
2792 static int
check_unique_name(const char * name)2793 check_unique_name (const char *name)
2794 {
2795 return *name == '@';
2796 }
2797
2798
2799 static void
mio_typespec(gfc_typespec * ts)2800 mio_typespec (gfc_typespec *ts)
2801 {
2802 mio_lparen ();
2803
2804 ts->type = MIO_NAME (bt) (ts->type, bt_types);
2805
2806 if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
2807 mio_integer (&ts->kind);
2808 else
2809 mio_symbol_ref (&ts->u.derived);
2810
2811 mio_symbol_ref (&ts->interface);
2812
2813 /* Add info for C interop and is_iso_c. */
2814 mio_integer (&ts->is_c_interop);
2815 mio_integer (&ts->is_iso_c);
2816
2817 /* If the typespec is for an identifier either from iso_c_binding, or
2818 a constant that was initialized to an identifier from it, use the
2819 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2820 if (ts->is_iso_c)
2821 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2822 else
2823 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2824
2825 if (ts->type != BT_CHARACTER)
2826 {
2827 /* ts->u.cl is only valid for BT_CHARACTER. */
2828 mio_lparen ();
2829 mio_rparen ();
2830 }
2831 else
2832 mio_charlen (&ts->u.cl);
2833
2834 /* So as not to disturb the existing API, use an ATOM_NAME to
2835 transmit deferred characteristic for characters (F2003). */
2836 if (iomode == IO_OUTPUT)
2837 {
2838 if (ts->type == BT_CHARACTER && ts->deferred)
2839 write_atom (ATOM_NAME, "DEFERRED_CL");
2840 }
2841 else if (peek_atom () != ATOM_RPAREN)
2842 {
2843 if (parse_atom () != ATOM_NAME)
2844 bad_module ("Expected string");
2845 ts->deferred = 1;
2846 }
2847
2848 mio_rparen ();
2849 }
2850
2851
2852 static const mstring array_spec_types[] = {
2853 minit ("EXPLICIT", AS_EXPLICIT),
2854 minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2855 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2856 minit ("DEFERRED", AS_DEFERRED),
2857 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2858 minit (NULL, -1)
2859 };
2860
2861
2862 static void
mio_array_spec(gfc_array_spec ** asp)2863 mio_array_spec (gfc_array_spec **asp)
2864 {
2865 gfc_array_spec *as;
2866 int i;
2867
2868 mio_lparen ();
2869
2870 if (iomode == IO_OUTPUT)
2871 {
2872 int rank;
2873
2874 if (*asp == NULL)
2875 goto done;
2876 as = *asp;
2877
2878 /* mio_integer expects nonnegative values. */
2879 rank = as->rank > 0 ? as->rank : 0;
2880 mio_integer (&rank);
2881 }
2882 else
2883 {
2884 if (peek_atom () == ATOM_RPAREN)
2885 {
2886 *asp = NULL;
2887 goto done;
2888 }
2889
2890 *asp = as = gfc_get_array_spec ();
2891 mio_integer (&as->rank);
2892 }
2893
2894 mio_integer (&as->corank);
2895 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2896
2897 if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2898 as->rank = -1;
2899 if (iomode == IO_INPUT && as->corank)
2900 as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2901
2902 if (as->rank + as->corank > 0)
2903 for (i = 0; i < as->rank + as->corank; i++)
2904 {
2905 mio_expr (&as->lower[i]);
2906 mio_expr (&as->upper[i]);
2907 }
2908
2909 done:
2910 mio_rparen ();
2911 }
2912
2913
2914 /* Given a pointer to an array reference structure (which lives in a
2915 gfc_ref structure), find the corresponding array specification
2916 structure. Storing the pointer in the ref structure doesn't quite
2917 work when loading from a module. Generating code for an array
2918 reference also needs more information than just the array spec. */
2919
2920 static const mstring array_ref_types[] = {
2921 minit ("FULL", AR_FULL),
2922 minit ("ELEMENT", AR_ELEMENT),
2923 minit ("SECTION", AR_SECTION),
2924 minit (NULL, -1)
2925 };
2926
2927
2928 static void
mio_array_ref(gfc_array_ref * ar)2929 mio_array_ref (gfc_array_ref *ar)
2930 {
2931 int i;
2932
2933 mio_lparen ();
2934 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2935 mio_integer (&ar->dimen);
2936
2937 switch (ar->type)
2938 {
2939 case AR_FULL:
2940 break;
2941
2942 case AR_ELEMENT:
2943 for (i = 0; i < ar->dimen; i++)
2944 mio_expr (&ar->start[i]);
2945
2946 break;
2947
2948 case AR_SECTION:
2949 for (i = 0; i < ar->dimen; i++)
2950 {
2951 mio_expr (&ar->start[i]);
2952 mio_expr (&ar->end[i]);
2953 mio_expr (&ar->stride[i]);
2954 }
2955
2956 break;
2957
2958 case AR_UNKNOWN:
2959 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2960 }
2961
2962 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2963 we can't call mio_integer directly. Instead loop over each element
2964 and cast it to/from an integer. */
2965 if (iomode == IO_OUTPUT)
2966 {
2967 for (i = 0; i < ar->dimen; i++)
2968 {
2969 HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
2970 write_atom (ATOM_INTEGER, &tmp);
2971 }
2972 }
2973 else
2974 {
2975 for (i = 0; i < ar->dimen; i++)
2976 {
2977 require_atom (ATOM_INTEGER);
2978 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2979 }
2980 }
2981
2982 if (iomode == IO_INPUT)
2983 {
2984 ar->where = gfc_current_locus;
2985
2986 for (i = 0; i < ar->dimen; i++)
2987 ar->c_where[i] = gfc_current_locus;
2988 }
2989
2990 mio_rparen ();
2991 }
2992
2993
2994 /* Saves or restores a pointer. The pointer is converted back and
2995 forth from an integer. We return the pointer_info pointer so that
2996 the caller can take additional action based on the pointer type. */
2997
2998 static pointer_info *
mio_pointer_ref(void * gp)2999 mio_pointer_ref (void *gp)
3000 {
3001 pointer_info *p;
3002
3003 if (iomode == IO_OUTPUT)
3004 {
3005 p = get_pointer (*((char **) gp));
3006 HOST_WIDE_INT hwi = p->integer;
3007 write_atom (ATOM_INTEGER, &hwi);
3008 }
3009 else
3010 {
3011 require_atom (ATOM_INTEGER);
3012 p = add_fixup (atom_int, gp);
3013 }
3014
3015 return p;
3016 }
3017
3018
3019 /* Save and load references to components that occur within
3020 expressions. We have to describe these references by a number and
3021 by name. The number is necessary for forward references during
3022 reading, and the name is necessary if the symbol already exists in
3023 the namespace and is not loaded again. */
3024
3025 static void
mio_component_ref(gfc_component ** cp)3026 mio_component_ref (gfc_component **cp)
3027 {
3028 pointer_info *p;
3029
3030 p = mio_pointer_ref (cp);
3031 if (p->type == P_UNKNOWN)
3032 p->type = P_COMPONENT;
3033 }
3034
3035
3036 static void mio_namespace_ref (gfc_namespace **nsp);
3037 static void mio_formal_arglist (gfc_formal_arglist **formal);
3038 static void mio_typebound_proc (gfc_typebound_proc** proc);
3039 static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
3040
3041 static void
mio_component(gfc_component * c,int vtype)3042 mio_component (gfc_component *c, int vtype)
3043 {
3044 pointer_info *p;
3045
3046 mio_lparen ();
3047
3048 if (iomode == IO_OUTPUT)
3049 {
3050 p = get_pointer (c);
3051 mio_hwi (&p->integer);
3052 }
3053 else
3054 {
3055 HOST_WIDE_INT n;
3056 mio_hwi (&n);
3057 p = get_integer (n);
3058 associate_integer_pointer (p, c);
3059 }
3060
3061 if (p->type == P_UNKNOWN)
3062 p->type = P_COMPONENT;
3063
3064 mio_pool_string (&c->name);
3065 mio_typespec (&c->ts);
3066 mio_array_spec (&c->as);
3067
3068 /* PDT templates store the expression for the kind of a component here. */
3069 mio_expr (&c->kind_expr);
3070
3071 /* PDT types store the component specification list here. */
3072 mio_actual_arglist (&c->param_list, true);
3073
3074 mio_symbol_attribute (&c->attr);
3075 if (c->ts.type == BT_CLASS)
3076 c->attr.class_ok = 1;
3077 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
3078
3079 if (!vtype || strcmp (c->name, "_final") == 0
3080 || strcmp (c->name, "_hash") == 0)
3081 mio_expr (&c->initializer);
3082
3083 if (c->attr.proc_pointer)
3084 mio_typebound_proc (&c->tb);
3085
3086 c->loc = gfc_current_locus;
3087
3088 mio_rparen ();
3089 }
3090
3091
3092 static void
mio_component_list(gfc_component ** cp,int vtype)3093 mio_component_list (gfc_component **cp, int vtype)
3094 {
3095 gfc_component *c, *tail;
3096
3097 mio_lparen ();
3098
3099 if (iomode == IO_OUTPUT)
3100 {
3101 for (c = *cp; c; c = c->next)
3102 mio_component (c, vtype);
3103 }
3104 else
3105 {
3106 *cp = NULL;
3107 tail = NULL;
3108
3109 for (;;)
3110 {
3111 if (peek_atom () == ATOM_RPAREN)
3112 break;
3113
3114 c = gfc_get_component ();
3115 mio_component (c, vtype);
3116
3117 if (tail == NULL)
3118 *cp = c;
3119 else
3120 tail->next = c;
3121
3122 tail = c;
3123 }
3124 }
3125
3126 mio_rparen ();
3127 }
3128
3129
3130 static void
mio_actual_arg(gfc_actual_arglist * a,bool pdt)3131 mio_actual_arg (gfc_actual_arglist *a, bool pdt)
3132 {
3133 mio_lparen ();
3134 mio_pool_string (&a->name);
3135 mio_expr (&a->expr);
3136 if (pdt)
3137 mio_integer ((int *)&a->spec_type);
3138 mio_rparen ();
3139 }
3140
3141
3142 static void
mio_actual_arglist(gfc_actual_arglist ** ap,bool pdt)3143 mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
3144 {
3145 gfc_actual_arglist *a, *tail;
3146
3147 mio_lparen ();
3148
3149 if (iomode == IO_OUTPUT)
3150 {
3151 for (a = *ap; a; a = a->next)
3152 mio_actual_arg (a, pdt);
3153
3154 }
3155 else
3156 {
3157 tail = NULL;
3158
3159 for (;;)
3160 {
3161 if (peek_atom () != ATOM_LPAREN)
3162 break;
3163
3164 a = gfc_get_actual_arglist ();
3165
3166 if (tail == NULL)
3167 *ap = a;
3168 else
3169 tail->next = a;
3170
3171 tail = a;
3172 mio_actual_arg (a, pdt);
3173 }
3174 }
3175
3176 mio_rparen ();
3177 }
3178
3179
3180 /* Read and write formal argument lists. */
3181
3182 static void
mio_formal_arglist(gfc_formal_arglist ** formal)3183 mio_formal_arglist (gfc_formal_arglist **formal)
3184 {
3185 gfc_formal_arglist *f, *tail;
3186
3187 mio_lparen ();
3188
3189 if (iomode == IO_OUTPUT)
3190 {
3191 for (f = *formal; f; f = f->next)
3192 mio_symbol_ref (&f->sym);
3193 }
3194 else
3195 {
3196 *formal = tail = NULL;
3197
3198 while (peek_atom () != ATOM_RPAREN)
3199 {
3200 f = gfc_get_formal_arglist ();
3201 mio_symbol_ref (&f->sym);
3202
3203 if (*formal == NULL)
3204 *formal = f;
3205 else
3206 tail->next = f;
3207
3208 tail = f;
3209 }
3210 }
3211
3212 mio_rparen ();
3213 }
3214
3215
3216 /* Save or restore a reference to a symbol node. */
3217
3218 pointer_info *
mio_symbol_ref(gfc_symbol ** symp)3219 mio_symbol_ref (gfc_symbol **symp)
3220 {
3221 pointer_info *p;
3222
3223 p = mio_pointer_ref (symp);
3224 if (p->type == P_UNKNOWN)
3225 p->type = P_SYMBOL;
3226
3227 if (iomode == IO_OUTPUT)
3228 {
3229 if (p->u.wsym.state == UNREFERENCED)
3230 p->u.wsym.state = NEEDS_WRITE;
3231 }
3232 else
3233 {
3234 if (p->u.rsym.state == UNUSED)
3235 p->u.rsym.state = NEEDED;
3236 }
3237 return p;
3238 }
3239
3240
3241 /* Save or restore a reference to a symtree node. */
3242
3243 static void
mio_symtree_ref(gfc_symtree ** stp)3244 mio_symtree_ref (gfc_symtree **stp)
3245 {
3246 pointer_info *p;
3247 fixup_t *f;
3248
3249 if (iomode == IO_OUTPUT)
3250 mio_symbol_ref (&(*stp)->n.sym);
3251 else
3252 {
3253 require_atom (ATOM_INTEGER);
3254 p = get_integer (atom_int);
3255
3256 /* An unused equivalence member; make a symbol and a symtree
3257 for it. */
3258 if (in_load_equiv && p->u.rsym.symtree == NULL)
3259 {
3260 /* Since this is not used, it must have a unique name. */
3261 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
3262
3263 /* Make the symbol. */
3264 if (p->u.rsym.sym == NULL)
3265 {
3266 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
3267 gfc_current_ns);
3268 p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
3269 }
3270
3271 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
3272 p->u.rsym.symtree->n.sym->refs++;
3273 p->u.rsym.referenced = 1;
3274
3275 /* If the symbol is PRIVATE and in COMMON, load_commons will
3276 generate a fixup symbol, which must be associated. */
3277 if (p->fixup)
3278 resolve_fixups (p->fixup, p->u.rsym.sym);
3279 p->fixup = NULL;
3280 }
3281
3282 if (p->type == P_UNKNOWN)
3283 p->type = P_SYMBOL;
3284
3285 if (p->u.rsym.state == UNUSED)
3286 p->u.rsym.state = NEEDED;
3287
3288 if (p->u.rsym.symtree != NULL)
3289 {
3290 *stp = p->u.rsym.symtree;
3291 }
3292 else
3293 {
3294 f = XCNEW (fixup_t);
3295
3296 f->next = p->u.rsym.stfixup;
3297 p->u.rsym.stfixup = f;
3298
3299 f->pointer = (void **) stp;
3300 }
3301 }
3302 }
3303
3304
3305 static void
mio_iterator(gfc_iterator ** ip)3306 mio_iterator (gfc_iterator **ip)
3307 {
3308 gfc_iterator *iter;
3309
3310 mio_lparen ();
3311
3312 if (iomode == IO_OUTPUT)
3313 {
3314 if (*ip == NULL)
3315 goto done;
3316 }
3317 else
3318 {
3319 if (peek_atom () == ATOM_RPAREN)
3320 {
3321 *ip = NULL;
3322 goto done;
3323 }
3324
3325 *ip = gfc_get_iterator ();
3326 }
3327
3328 iter = *ip;
3329
3330 mio_expr (&iter->var);
3331 mio_expr (&iter->start);
3332 mio_expr (&iter->end);
3333 mio_expr (&iter->step);
3334
3335 done:
3336 mio_rparen ();
3337 }
3338
3339
3340 static void
mio_constructor(gfc_constructor_base * cp)3341 mio_constructor (gfc_constructor_base *cp)
3342 {
3343 gfc_constructor *c;
3344
3345 mio_lparen ();
3346
3347 if (iomode == IO_OUTPUT)
3348 {
3349 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
3350 {
3351 mio_lparen ();
3352 mio_expr (&c->expr);
3353 mio_iterator (&c->iterator);
3354 mio_rparen ();
3355 }
3356 }
3357 else
3358 {
3359 while (peek_atom () != ATOM_RPAREN)
3360 {
3361 c = gfc_constructor_append_expr (cp, NULL, NULL);
3362
3363 mio_lparen ();
3364 mio_expr (&c->expr);
3365 mio_iterator (&c->iterator);
3366 mio_rparen ();
3367 }
3368 }
3369
3370 mio_rparen ();
3371 }
3372
3373
3374 static const mstring ref_types[] = {
3375 minit ("ARRAY", REF_ARRAY),
3376 minit ("COMPONENT", REF_COMPONENT),
3377 minit ("SUBSTRING", REF_SUBSTRING),
3378 minit ("INQUIRY", REF_INQUIRY),
3379 minit (NULL, -1)
3380 };
3381
3382 static const mstring inquiry_types[] = {
3383 minit ("RE", INQUIRY_RE),
3384 minit ("IM", INQUIRY_IM),
3385 minit ("KIND", INQUIRY_KIND),
3386 minit ("LEN", INQUIRY_LEN),
3387 minit (NULL, -1)
3388 };
3389
3390
3391 static void
mio_ref(gfc_ref ** rp)3392 mio_ref (gfc_ref **rp)
3393 {
3394 gfc_ref *r;
3395
3396 mio_lparen ();
3397
3398 r = *rp;
3399 r->type = MIO_NAME (ref_type) (r->type, ref_types);
3400
3401 switch (r->type)
3402 {
3403 case REF_ARRAY:
3404 mio_array_ref (&r->u.ar);
3405 break;
3406
3407 case REF_COMPONENT:
3408 mio_symbol_ref (&r->u.c.sym);
3409 mio_component_ref (&r->u.c.component);
3410 break;
3411
3412 case REF_SUBSTRING:
3413 mio_expr (&r->u.ss.start);
3414 mio_expr (&r->u.ss.end);
3415 mio_charlen (&r->u.ss.length);
3416 break;
3417
3418 case REF_INQUIRY:
3419 r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
3420 break;
3421 }
3422
3423 mio_rparen ();
3424 }
3425
3426
3427 static void
mio_ref_list(gfc_ref ** rp)3428 mio_ref_list (gfc_ref **rp)
3429 {
3430 gfc_ref *ref, *head, *tail;
3431
3432 mio_lparen ();
3433
3434 if (iomode == IO_OUTPUT)
3435 {
3436 for (ref = *rp; ref; ref = ref->next)
3437 mio_ref (&ref);
3438 }
3439 else
3440 {
3441 head = tail = NULL;
3442
3443 while (peek_atom () != ATOM_RPAREN)
3444 {
3445 if (head == NULL)
3446 head = tail = gfc_get_ref ();
3447 else
3448 {
3449 tail->next = gfc_get_ref ();
3450 tail = tail->next;
3451 }
3452
3453 mio_ref (&tail);
3454 }
3455
3456 *rp = head;
3457 }
3458
3459 mio_rparen ();
3460 }
3461
3462
3463 /* Read and write an integer value. */
3464
3465 static void
mio_gmp_integer(mpz_t * integer)3466 mio_gmp_integer (mpz_t *integer)
3467 {
3468 char *p;
3469
3470 if (iomode == IO_INPUT)
3471 {
3472 if (parse_atom () != ATOM_STRING)
3473 bad_module ("Expected integer string");
3474
3475 mpz_init (*integer);
3476 if (mpz_set_str (*integer, atom_string, 10))
3477 bad_module ("Error converting integer");
3478
3479 free (atom_string);
3480 }
3481 else
3482 {
3483 p = mpz_get_str (NULL, 10, *integer);
3484 write_atom (ATOM_STRING, p);
3485 free (p);
3486 }
3487 }
3488
3489
3490 static void
mio_gmp_real(mpfr_t * real)3491 mio_gmp_real (mpfr_t *real)
3492 {
3493 mpfr_exp_t exponent;
3494 char *p;
3495
3496 if (iomode == IO_INPUT)
3497 {
3498 if (parse_atom () != ATOM_STRING)
3499 bad_module ("Expected real string");
3500
3501 mpfr_init (*real);
3502 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3503 free (atom_string);
3504 }
3505 else
3506 {
3507 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3508
3509 if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3510 {
3511 write_atom (ATOM_STRING, p);
3512 free (p);
3513 return;
3514 }
3515
3516 atom_string = XCNEWVEC (char, strlen (p) + 20);
3517
3518 sprintf (atom_string, "0.%s@%ld", p, exponent);
3519
3520 /* Fix negative numbers. */
3521 if (atom_string[2] == '-')
3522 {
3523 atom_string[0] = '-';
3524 atom_string[1] = '0';
3525 atom_string[2] = '.';
3526 }
3527
3528 write_atom (ATOM_STRING, atom_string);
3529
3530 free (atom_string);
3531 free (p);
3532 }
3533 }
3534
3535
3536 /* Save and restore the shape of an array constructor. */
3537
3538 static void
mio_shape(mpz_t ** pshape,int rank)3539 mio_shape (mpz_t **pshape, int rank)
3540 {
3541 mpz_t *shape;
3542 atom_type t;
3543 int n;
3544
3545 /* A NULL shape is represented by (). */
3546 mio_lparen ();
3547
3548 if (iomode == IO_OUTPUT)
3549 {
3550 shape = *pshape;
3551 if (!shape)
3552 {
3553 mio_rparen ();
3554 return;
3555 }
3556 }
3557 else
3558 {
3559 t = peek_atom ();
3560 if (t == ATOM_RPAREN)
3561 {
3562 *pshape = NULL;
3563 mio_rparen ();
3564 return;
3565 }
3566
3567 shape = gfc_get_shape (rank);
3568 *pshape = shape;
3569 }
3570
3571 for (n = 0; n < rank; n++)
3572 mio_gmp_integer (&shape[n]);
3573
3574 mio_rparen ();
3575 }
3576
3577
3578 static const mstring expr_types[] = {
3579 minit ("OP", EXPR_OP),
3580 minit ("FUNCTION", EXPR_FUNCTION),
3581 minit ("CONSTANT", EXPR_CONSTANT),
3582 minit ("VARIABLE", EXPR_VARIABLE),
3583 minit ("SUBSTRING", EXPR_SUBSTRING),
3584 minit ("STRUCTURE", EXPR_STRUCTURE),
3585 minit ("ARRAY", EXPR_ARRAY),
3586 minit ("NULL", EXPR_NULL),
3587 minit ("COMPCALL", EXPR_COMPCALL),
3588 minit (NULL, -1)
3589 };
3590
3591 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3592 generic operators, not in expressions. INTRINSIC_USER is also
3593 replaced by the correct function name by the time we see it. */
3594
3595 static const mstring intrinsics[] =
3596 {
3597 minit ("UPLUS", INTRINSIC_UPLUS),
3598 minit ("UMINUS", INTRINSIC_UMINUS),
3599 minit ("PLUS", INTRINSIC_PLUS),
3600 minit ("MINUS", INTRINSIC_MINUS),
3601 minit ("TIMES", INTRINSIC_TIMES),
3602 minit ("DIVIDE", INTRINSIC_DIVIDE),
3603 minit ("POWER", INTRINSIC_POWER),
3604 minit ("CONCAT", INTRINSIC_CONCAT),
3605 minit ("AND", INTRINSIC_AND),
3606 minit ("OR", INTRINSIC_OR),
3607 minit ("EQV", INTRINSIC_EQV),
3608 minit ("NEQV", INTRINSIC_NEQV),
3609 minit ("EQ_SIGN", INTRINSIC_EQ),
3610 minit ("EQ", INTRINSIC_EQ_OS),
3611 minit ("NE_SIGN", INTRINSIC_NE),
3612 minit ("NE", INTRINSIC_NE_OS),
3613 minit ("GT_SIGN", INTRINSIC_GT),
3614 minit ("GT", INTRINSIC_GT_OS),
3615 minit ("GE_SIGN", INTRINSIC_GE),
3616 minit ("GE", INTRINSIC_GE_OS),
3617 minit ("LT_SIGN", INTRINSIC_LT),
3618 minit ("LT", INTRINSIC_LT_OS),
3619 minit ("LE_SIGN", INTRINSIC_LE),
3620 minit ("LE", INTRINSIC_LE_OS),
3621 minit ("NOT", INTRINSIC_NOT),
3622 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3623 minit ("USER", INTRINSIC_USER),
3624 minit (NULL, -1)
3625 };
3626
3627
3628 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3629
3630 static void
fix_mio_expr(gfc_expr * e)3631 fix_mio_expr (gfc_expr *e)
3632 {
3633 gfc_symtree *ns_st = NULL;
3634 const char *fname;
3635
3636 if (iomode != IO_OUTPUT)
3637 return;
3638
3639 if (e->symtree)
3640 {
3641 /* If this is a symtree for a symbol that came from a contained module
3642 namespace, it has a unique name and we should look in the current
3643 namespace to see if the required, non-contained symbol is available
3644 yet. If so, the latter should be written. */
3645 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3646 {
3647 const char *name = e->symtree->n.sym->name;
3648 if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
3649 name = gfc_dt_upper_string (name);
3650 ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3651 }
3652
3653 /* On the other hand, if the existing symbol is the module name or the
3654 new symbol is a dummy argument, do not do the promotion. */
3655 if (ns_st && ns_st->n.sym
3656 && ns_st->n.sym->attr.flavor != FL_MODULE
3657 && !e->symtree->n.sym->attr.dummy)
3658 e->symtree = ns_st;
3659 }
3660 else if (e->expr_type == EXPR_FUNCTION
3661 && (e->value.function.name || e->value.function.isym))
3662 {
3663 gfc_symbol *sym;
3664
3665 /* In some circumstances, a function used in an initialization
3666 expression, in one use associated module, can fail to be
3667 coupled to its symtree when used in a specification
3668 expression in another module. */
3669 fname = e->value.function.esym ? e->value.function.esym->name
3670 : e->value.function.isym->name;
3671 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3672
3673 if (e->symtree)
3674 return;
3675
3676 /* This is probably a reference to a private procedure from another
3677 module. To prevent a segfault, make a generic with no specific
3678 instances. If this module is used, without the required
3679 specific coming from somewhere, the appropriate error message
3680 is issued. */
3681 gfc_get_symbol (fname, gfc_current_ns, &sym);
3682 sym->attr.flavor = FL_PROCEDURE;
3683 sym->attr.generic = 1;
3684 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3685 gfc_commit_symbol (sym);
3686 }
3687 }
3688
3689
3690 /* Read and write expressions. The form "()" is allowed to indicate a
3691 NULL expression. */
3692
3693 static void
mio_expr(gfc_expr ** ep)3694 mio_expr (gfc_expr **ep)
3695 {
3696 HOST_WIDE_INT hwi;
3697 gfc_expr *e;
3698 atom_type t;
3699 int flag;
3700
3701 mio_lparen ();
3702
3703 if (iomode == IO_OUTPUT)
3704 {
3705 if (*ep == NULL)
3706 {
3707 mio_rparen ();
3708 return;
3709 }
3710
3711 e = *ep;
3712 MIO_NAME (expr_t) (e->expr_type, expr_types);
3713 }
3714 else
3715 {
3716 t = parse_atom ();
3717 if (t == ATOM_RPAREN)
3718 {
3719 *ep = NULL;
3720 return;
3721 }
3722
3723 if (t != ATOM_NAME)
3724 bad_module ("Expected expression type");
3725
3726 e = *ep = gfc_get_expr ();
3727 e->where = gfc_current_locus;
3728 e->expr_type = (expr_t) find_enum (expr_types);
3729 }
3730
3731 mio_typespec (&e->ts);
3732 mio_integer (&e->rank);
3733
3734 fix_mio_expr (e);
3735
3736 switch (e->expr_type)
3737 {
3738 case EXPR_OP:
3739 e->value.op.op
3740 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3741
3742 switch (e->value.op.op)
3743 {
3744 case INTRINSIC_UPLUS:
3745 case INTRINSIC_UMINUS:
3746 case INTRINSIC_NOT:
3747 case INTRINSIC_PARENTHESES:
3748 mio_expr (&e->value.op.op1);
3749 break;
3750
3751 case INTRINSIC_PLUS:
3752 case INTRINSIC_MINUS:
3753 case INTRINSIC_TIMES:
3754 case INTRINSIC_DIVIDE:
3755 case INTRINSIC_POWER:
3756 case INTRINSIC_CONCAT:
3757 case INTRINSIC_AND:
3758 case INTRINSIC_OR:
3759 case INTRINSIC_EQV:
3760 case INTRINSIC_NEQV:
3761 case INTRINSIC_EQ:
3762 case INTRINSIC_EQ_OS:
3763 case INTRINSIC_NE:
3764 case INTRINSIC_NE_OS:
3765 case INTRINSIC_GT:
3766 case INTRINSIC_GT_OS:
3767 case INTRINSIC_GE:
3768 case INTRINSIC_GE_OS:
3769 case INTRINSIC_LT:
3770 case INTRINSIC_LT_OS:
3771 case INTRINSIC_LE:
3772 case INTRINSIC_LE_OS:
3773 mio_expr (&e->value.op.op1);
3774 mio_expr (&e->value.op.op2);
3775 break;
3776
3777 case INTRINSIC_USER:
3778 /* INTRINSIC_USER should not appear in resolved expressions,
3779 though for UDRs we need to stream unresolved ones. */
3780 if (iomode == IO_OUTPUT)
3781 write_atom (ATOM_STRING, e->value.op.uop->name);
3782 else
3783 {
3784 char *name = read_string ();
3785 const char *uop_name = find_use_name (name, true);
3786 if (uop_name == NULL)
3787 {
3788 size_t len = strlen (name);
3789 char *name2 = XCNEWVEC (char, len + 2);
3790 memcpy (name2, name, len);
3791 name2[len] = ' ';
3792 name2[len + 1] = '\0';
3793 free (name);
3794 uop_name = name = name2;
3795 }
3796 e->value.op.uop = gfc_get_uop (uop_name);
3797 free (name);
3798 }
3799 mio_expr (&e->value.op.op1);
3800 mio_expr (&e->value.op.op2);
3801 break;
3802
3803 default:
3804 bad_module ("Bad operator");
3805 }
3806
3807 break;
3808
3809 case EXPR_FUNCTION:
3810 mio_symtree_ref (&e->symtree);
3811 mio_actual_arglist (&e->value.function.actual, false);
3812
3813 if (iomode == IO_OUTPUT)
3814 {
3815 e->value.function.name
3816 = mio_allocated_string (e->value.function.name);
3817 if (e->value.function.esym)
3818 flag = 1;
3819 else if (e->ref)
3820 flag = 2;
3821 else if (e->value.function.isym == NULL)
3822 flag = 3;
3823 else
3824 flag = 0;
3825 mio_integer (&flag);
3826 switch (flag)
3827 {
3828 case 1:
3829 mio_symbol_ref (&e->value.function.esym);
3830 break;
3831 case 2:
3832 mio_ref_list (&e->ref);
3833 break;
3834 case 3:
3835 break;
3836 default:
3837 write_atom (ATOM_STRING, e->value.function.isym->name);
3838 }
3839 }
3840 else
3841 {
3842 require_atom (ATOM_STRING);
3843 if (atom_string[0] == '\0')
3844 e->value.function.name = NULL;
3845 else
3846 e->value.function.name = gfc_get_string ("%s", atom_string);
3847 free (atom_string);
3848
3849 mio_integer (&flag);
3850 switch (flag)
3851 {
3852 case 1:
3853 mio_symbol_ref (&e->value.function.esym);
3854 break;
3855 case 2:
3856 mio_ref_list (&e->ref);
3857 break;
3858 case 3:
3859 break;
3860 default:
3861 require_atom (ATOM_STRING);
3862 e->value.function.isym = gfc_find_function (atom_string);
3863 free (atom_string);
3864 }
3865 }
3866
3867 break;
3868
3869 case EXPR_VARIABLE:
3870 mio_symtree_ref (&e->symtree);
3871 mio_ref_list (&e->ref);
3872 break;
3873
3874 case EXPR_SUBSTRING:
3875 e->value.character.string
3876 = CONST_CAST (gfc_char_t *,
3877 mio_allocated_wide_string (e->value.character.string,
3878 e->value.character.length));
3879 mio_ref_list (&e->ref);
3880 break;
3881
3882 case EXPR_STRUCTURE:
3883 case EXPR_ARRAY:
3884 mio_constructor (&e->value.constructor);
3885 mio_shape (&e->shape, e->rank);
3886 break;
3887
3888 case EXPR_CONSTANT:
3889 switch (e->ts.type)
3890 {
3891 case BT_INTEGER:
3892 mio_gmp_integer (&e->value.integer);
3893 break;
3894
3895 case BT_REAL:
3896 gfc_set_model_kind (e->ts.kind);
3897 mio_gmp_real (&e->value.real);
3898 break;
3899
3900 case BT_COMPLEX:
3901 gfc_set_model_kind (e->ts.kind);
3902 mio_gmp_real (&mpc_realref (e->value.complex));
3903 mio_gmp_real (&mpc_imagref (e->value.complex));
3904 break;
3905
3906 case BT_LOGICAL:
3907 mio_integer (&e->value.logical);
3908 break;
3909
3910 case BT_CHARACTER:
3911 hwi = e->value.character.length;
3912 mio_hwi (&hwi);
3913 e->value.character.length = hwi;
3914 e->value.character.string
3915 = CONST_CAST (gfc_char_t *,
3916 mio_allocated_wide_string (e->value.character.string,
3917 e->value.character.length));
3918 break;
3919
3920 default:
3921 bad_module ("Bad type in constant expression");
3922 }
3923
3924 break;
3925
3926 case EXPR_NULL:
3927 break;
3928
3929 case EXPR_COMPCALL:
3930 case EXPR_PPC:
3931 case EXPR_UNKNOWN:
3932 gcc_unreachable ();
3933 break;
3934 }
3935
3936 /* PDT types store the expression specification list here. */
3937 mio_actual_arglist (&e->param_list, true);
3938
3939 mio_rparen ();
3940 }
3941
3942
3943 /* Read and write namelists. */
3944
3945 static void
mio_namelist(gfc_symbol * sym)3946 mio_namelist (gfc_symbol *sym)
3947 {
3948 gfc_namelist *n, *m;
3949
3950 mio_lparen ();
3951
3952 if (iomode == IO_OUTPUT)
3953 {
3954 for (n = sym->namelist; n; n = n->next)
3955 mio_symbol_ref (&n->sym);
3956 }
3957 else
3958 {
3959 m = NULL;
3960 while (peek_atom () != ATOM_RPAREN)
3961 {
3962 n = gfc_get_namelist ();
3963 mio_symbol_ref (&n->sym);
3964
3965 if (sym->namelist == NULL)
3966 sym->namelist = n;
3967 else
3968 m->next = n;
3969
3970 m = n;
3971 }
3972 sym->namelist_tail = m;
3973 }
3974
3975 mio_rparen ();
3976 }
3977
3978
3979 /* Save/restore lists of gfc_interface structures. When loading an
3980 interface, we are really appending to the existing list of
3981 interfaces. Checking for duplicate and ambiguous interfaces has to
3982 be done later when all symbols have been loaded. */
3983
3984 pointer_info *
mio_interface_rest(gfc_interface ** ip)3985 mio_interface_rest (gfc_interface **ip)
3986 {
3987 gfc_interface *tail, *p;
3988 pointer_info *pi = NULL;
3989
3990 if (iomode == IO_OUTPUT)
3991 {
3992 if (ip != NULL)
3993 for (p = *ip; p; p = p->next)
3994 mio_symbol_ref (&p->sym);
3995 }
3996 else
3997 {
3998 if (*ip == NULL)
3999 tail = NULL;
4000 else
4001 {
4002 tail = *ip;
4003 while (tail->next)
4004 tail = tail->next;
4005 }
4006
4007 for (;;)
4008 {
4009 if (peek_atom () == ATOM_RPAREN)
4010 break;
4011
4012 p = gfc_get_interface ();
4013 p->where = gfc_current_locus;
4014 pi = mio_symbol_ref (&p->sym);
4015
4016 if (tail == NULL)
4017 *ip = p;
4018 else
4019 tail->next = p;
4020
4021 tail = p;
4022 }
4023 }
4024
4025 mio_rparen ();
4026 return pi;
4027 }
4028
4029
4030 /* Save/restore a nameless operator interface. */
4031
4032 static void
mio_interface(gfc_interface ** ip)4033 mio_interface (gfc_interface **ip)
4034 {
4035 mio_lparen ();
4036 mio_interface_rest (ip);
4037 }
4038
4039
4040 /* Save/restore a named operator interface. */
4041
4042 static void
mio_symbol_interface(const char ** name,const char ** module,gfc_interface ** ip)4043 mio_symbol_interface (const char **name, const char **module,
4044 gfc_interface **ip)
4045 {
4046 mio_lparen ();
4047 mio_pool_string (name);
4048 mio_pool_string (module);
4049 mio_interface_rest (ip);
4050 }
4051
4052
4053 static void
mio_namespace_ref(gfc_namespace ** nsp)4054 mio_namespace_ref (gfc_namespace **nsp)
4055 {
4056 gfc_namespace *ns;
4057 pointer_info *p;
4058
4059 p = mio_pointer_ref (nsp);
4060
4061 if (p->type == P_UNKNOWN)
4062 p->type = P_NAMESPACE;
4063
4064 if (iomode == IO_INPUT && p->integer != 0)
4065 {
4066 ns = (gfc_namespace *) p->u.pointer;
4067 if (ns == NULL)
4068 {
4069 ns = gfc_get_namespace (NULL, 0);
4070 associate_integer_pointer (p, ns);
4071 }
4072 else
4073 ns->refs++;
4074 }
4075 }
4076
4077
4078 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
4079
4080 static gfc_namespace* current_f2k_derived;
4081
4082 static void
mio_typebound_proc(gfc_typebound_proc ** proc)4083 mio_typebound_proc (gfc_typebound_proc** proc)
4084 {
4085 int flag;
4086 int overriding_flag;
4087
4088 if (iomode == IO_INPUT)
4089 {
4090 *proc = gfc_get_typebound_proc (NULL);
4091 (*proc)->where = gfc_current_locus;
4092 }
4093 gcc_assert (*proc);
4094
4095 mio_lparen ();
4096
4097 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
4098
4099 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
4100 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
4101 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
4102 overriding_flag = mio_name (overriding_flag, binding_overriding);
4103 (*proc)->deferred = ((overriding_flag & 2) != 0);
4104 (*proc)->non_overridable = ((overriding_flag & 1) != 0);
4105 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
4106
4107 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
4108 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
4109 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
4110
4111 mio_pool_string (&((*proc)->pass_arg));
4112
4113 flag = (int) (*proc)->pass_arg_num;
4114 mio_integer (&flag);
4115 (*proc)->pass_arg_num = (unsigned) flag;
4116
4117 if ((*proc)->is_generic)
4118 {
4119 gfc_tbp_generic* g;
4120 int iop;
4121
4122 mio_lparen ();
4123
4124 if (iomode == IO_OUTPUT)
4125 for (g = (*proc)->u.generic; g; g = g->next)
4126 {
4127 iop = (int) g->is_operator;
4128 mio_integer (&iop);
4129 mio_allocated_string (g->specific_st->name);
4130 }
4131 else
4132 {
4133 (*proc)->u.generic = NULL;
4134 while (peek_atom () != ATOM_RPAREN)
4135 {
4136 gfc_symtree** sym_root;
4137
4138 g = gfc_get_tbp_generic ();
4139 g->specific = NULL;
4140
4141 mio_integer (&iop);
4142 g->is_operator = (bool) iop;
4143
4144 require_atom (ATOM_STRING);
4145 sym_root = ¤t_f2k_derived->tb_sym_root;
4146 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
4147 free (atom_string);
4148
4149 g->next = (*proc)->u.generic;
4150 (*proc)->u.generic = g;
4151 }
4152 }
4153
4154 mio_rparen ();
4155 }
4156 else if (!(*proc)->ppc)
4157 mio_symtree_ref (&(*proc)->u.specific);
4158
4159 mio_rparen ();
4160 }
4161
4162 /* Walker-callback function for this purpose. */
4163 static void
mio_typebound_symtree(gfc_symtree * st)4164 mio_typebound_symtree (gfc_symtree* st)
4165 {
4166 if (iomode == IO_OUTPUT && !st->n.tb)
4167 return;
4168
4169 if (iomode == IO_OUTPUT)
4170 {
4171 mio_lparen ();
4172 mio_allocated_string (st->name);
4173 }
4174 /* For IO_INPUT, the above is done in mio_f2k_derived. */
4175
4176 mio_typebound_proc (&st->n.tb);
4177 mio_rparen ();
4178 }
4179
4180 /* IO a full symtree (in all depth). */
4181 static void
mio_full_typebound_tree(gfc_symtree ** root)4182 mio_full_typebound_tree (gfc_symtree** root)
4183 {
4184 mio_lparen ();
4185
4186 if (iomode == IO_OUTPUT)
4187 gfc_traverse_symtree (*root, &mio_typebound_symtree);
4188 else
4189 {
4190 while (peek_atom () == ATOM_LPAREN)
4191 {
4192 gfc_symtree* st;
4193
4194 mio_lparen ();
4195
4196 require_atom (ATOM_STRING);
4197 st = gfc_get_tbp_symtree (root, atom_string);
4198 free (atom_string);
4199
4200 mio_typebound_symtree (st);
4201 }
4202 }
4203
4204 mio_rparen ();
4205 }
4206
4207 static void
mio_finalizer(gfc_finalizer ** f)4208 mio_finalizer (gfc_finalizer **f)
4209 {
4210 if (iomode == IO_OUTPUT)
4211 {
4212 gcc_assert (*f);
4213 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
4214 mio_symtree_ref (&(*f)->proc_tree);
4215 }
4216 else
4217 {
4218 *f = gfc_get_finalizer ();
4219 (*f)->where = gfc_current_locus; /* Value should not matter. */
4220 (*f)->next = NULL;
4221
4222 mio_symtree_ref (&(*f)->proc_tree);
4223 (*f)->proc_sym = NULL;
4224 }
4225 }
4226
4227 static void
mio_f2k_derived(gfc_namespace * f2k)4228 mio_f2k_derived (gfc_namespace *f2k)
4229 {
4230 current_f2k_derived = f2k;
4231
4232 /* Handle the list of finalizer procedures. */
4233 mio_lparen ();
4234 if (iomode == IO_OUTPUT)
4235 {
4236 gfc_finalizer *f;
4237 for (f = f2k->finalizers; f; f = f->next)
4238 mio_finalizer (&f);
4239 }
4240 else
4241 {
4242 f2k->finalizers = NULL;
4243 while (peek_atom () != ATOM_RPAREN)
4244 {
4245 gfc_finalizer *cur = NULL;
4246 mio_finalizer (&cur);
4247 cur->next = f2k->finalizers;
4248 f2k->finalizers = cur;
4249 }
4250 }
4251 mio_rparen ();
4252
4253 /* Handle type-bound procedures. */
4254 mio_full_typebound_tree (&f2k->tb_sym_root);
4255
4256 /* Type-bound user operators. */
4257 mio_full_typebound_tree (&f2k->tb_uop_root);
4258
4259 /* Type-bound intrinsic operators. */
4260 mio_lparen ();
4261 if (iomode == IO_OUTPUT)
4262 {
4263 int op;
4264 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
4265 {
4266 gfc_intrinsic_op realop;
4267
4268 if (op == INTRINSIC_USER || !f2k->tb_op[op])
4269 continue;
4270
4271 mio_lparen ();
4272 realop = (gfc_intrinsic_op) op;
4273 mio_intrinsic_op (&realop);
4274 mio_typebound_proc (&f2k->tb_op[op]);
4275 mio_rparen ();
4276 }
4277 }
4278 else
4279 while (peek_atom () != ATOM_RPAREN)
4280 {
4281 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
4282
4283 mio_lparen ();
4284 mio_intrinsic_op (&op);
4285 mio_typebound_proc (&f2k->tb_op[op]);
4286 mio_rparen ();
4287 }
4288 mio_rparen ();
4289 }
4290
4291 static void
mio_full_f2k_derived(gfc_symbol * sym)4292 mio_full_f2k_derived (gfc_symbol *sym)
4293 {
4294 mio_lparen ();
4295
4296 if (iomode == IO_OUTPUT)
4297 {
4298 if (sym->f2k_derived)
4299 mio_f2k_derived (sym->f2k_derived);
4300 }
4301 else
4302 {
4303 if (peek_atom () != ATOM_RPAREN)
4304 {
4305 gfc_namespace *ns;
4306
4307 sym->f2k_derived = gfc_get_namespace (NULL, 0);
4308
4309 /* PDT templates make use of the mechanisms for formal args
4310 and so the parameter symbols are stored in the formal
4311 namespace. Transfer the sym_root to f2k_derived and then
4312 free the formal namespace since it is uneeded. */
4313 if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
4314 {
4315 ns = sym->formal->sym->ns;
4316 sym->f2k_derived->sym_root = ns->sym_root;
4317 ns->sym_root = NULL;
4318 ns->refs++;
4319 gfc_free_namespace (ns);
4320 ns = NULL;
4321 }
4322
4323 mio_f2k_derived (sym->f2k_derived);
4324 }
4325 else
4326 gcc_assert (!sym->f2k_derived);
4327 }
4328
4329 mio_rparen ();
4330 }
4331
4332 static const mstring omp_declare_simd_clauses[] =
4333 {
4334 minit ("INBRANCH", 0),
4335 minit ("NOTINBRANCH", 1),
4336 minit ("SIMDLEN", 2),
4337 minit ("UNIFORM", 3),
4338 minit ("LINEAR", 4),
4339 minit ("ALIGNED", 5),
4340 minit ("LINEAR_REF", 33),
4341 minit ("LINEAR_VAL", 34),
4342 minit ("LINEAR_UVAL", 35),
4343 minit (NULL, -1)
4344 };
4345
4346 /* Handle !$omp declare simd. */
4347
4348 static void
mio_omp_declare_simd(gfc_namespace * ns,gfc_omp_declare_simd ** odsp)4349 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4350 {
4351 if (iomode == IO_OUTPUT)
4352 {
4353 if (*odsp == NULL)
4354 return;
4355 }
4356 else if (peek_atom () != ATOM_LPAREN)
4357 return;
4358
4359 gfc_omp_declare_simd *ods = *odsp;
4360
4361 mio_lparen ();
4362 if (iomode == IO_OUTPUT)
4363 {
4364 write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
4365 if (ods->clauses)
4366 {
4367 gfc_omp_namelist *n;
4368
4369 if (ods->clauses->inbranch)
4370 mio_name (0, omp_declare_simd_clauses);
4371 if (ods->clauses->notinbranch)
4372 mio_name (1, omp_declare_simd_clauses);
4373 if (ods->clauses->simdlen_expr)
4374 {
4375 mio_name (2, omp_declare_simd_clauses);
4376 mio_expr (&ods->clauses->simdlen_expr);
4377 }
4378 for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
4379 {
4380 mio_name (3, omp_declare_simd_clauses);
4381 mio_symbol_ref (&n->sym);
4382 }
4383 for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
4384 {
4385 if (n->u.linear_op == OMP_LINEAR_DEFAULT)
4386 mio_name (4, omp_declare_simd_clauses);
4387 else
4388 mio_name (32 + n->u.linear_op, omp_declare_simd_clauses);
4389 mio_symbol_ref (&n->sym);
4390 mio_expr (&n->expr);
4391 }
4392 for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4393 {
4394 mio_name (5, omp_declare_simd_clauses);
4395 mio_symbol_ref (&n->sym);
4396 mio_expr (&n->expr);
4397 }
4398 }
4399 }
4400 else
4401 {
4402 gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
4403
4404 require_atom (ATOM_NAME);
4405 *odsp = ods = gfc_get_omp_declare_simd ();
4406 ods->where = gfc_current_locus;
4407 ods->proc_name = ns->proc_name;
4408 if (peek_atom () == ATOM_NAME)
4409 {
4410 ods->clauses = gfc_get_omp_clauses ();
4411 ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
4412 ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
4413 ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
4414 }
4415 while (peek_atom () == ATOM_NAME)
4416 {
4417 gfc_omp_namelist *n;
4418 int t = mio_name (0, omp_declare_simd_clauses);
4419
4420 switch (t)
4421 {
4422 case 0: ods->clauses->inbranch = true; break;
4423 case 1: ods->clauses->notinbranch = true; break;
4424 case 2: mio_expr (&ods->clauses->simdlen_expr); break;
4425 case 3:
4426 case 4:
4427 case 5:
4428 *ptrs[t - 3] = n = gfc_get_omp_namelist ();
4429 finish_namelist:
4430 n->where = gfc_current_locus;
4431 ptrs[t - 3] = &n->next;
4432 mio_symbol_ref (&n->sym);
4433 if (t != 3)
4434 mio_expr (&n->expr);
4435 break;
4436 case 33:
4437 case 34:
4438 case 35:
4439 *ptrs[1] = n = gfc_get_omp_namelist ();
4440 n->u.linear_op = (enum gfc_omp_linear_op) (t - 32);
4441 t = 4;
4442 goto finish_namelist;
4443 }
4444 }
4445 }
4446
4447 mio_omp_declare_simd (ns, &ods->next);
4448
4449 mio_rparen ();
4450 }
4451
4452
4453 static const mstring omp_declare_reduction_stmt[] =
4454 {
4455 minit ("ASSIGN", 0),
4456 minit ("CALL", 1),
4457 minit (NULL, -1)
4458 };
4459
4460
4461 static void
mio_omp_udr_expr(gfc_omp_udr * udr,gfc_symbol ** sym1,gfc_symbol ** sym2,gfc_namespace * ns,bool is_initializer)4462 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
4463 gfc_namespace *ns, bool is_initializer)
4464 {
4465 if (iomode == IO_OUTPUT)
4466 {
4467 if ((*sym1)->module == NULL)
4468 {
4469 (*sym1)->module = module_name;
4470 (*sym2)->module = module_name;
4471 }
4472 mio_symbol_ref (sym1);
4473 mio_symbol_ref (sym2);
4474 if (ns->code->op == EXEC_ASSIGN)
4475 {
4476 mio_name (0, omp_declare_reduction_stmt);
4477 mio_expr (&ns->code->expr1);
4478 mio_expr (&ns->code->expr2);
4479 }
4480 else
4481 {
4482 int flag;
4483 mio_name (1, omp_declare_reduction_stmt);
4484 mio_symtree_ref (&ns->code->symtree);
4485 mio_actual_arglist (&ns->code->ext.actual, false);
4486
4487 flag = ns->code->resolved_isym != NULL;
4488 mio_integer (&flag);
4489 if (flag)
4490 write_atom (ATOM_STRING, ns->code->resolved_isym->name);
4491 else
4492 mio_symbol_ref (&ns->code->resolved_sym);
4493 }
4494 }
4495 else
4496 {
4497 pointer_info *p1 = mio_symbol_ref (sym1);
4498 pointer_info *p2 = mio_symbol_ref (sym2);
4499 gfc_symbol *sym;
4500 gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
4501 gcc_assert (p1->u.rsym.sym == NULL);
4502 /* Add hidden symbols to the symtree. */
4503 pointer_info *q = get_integer (p1->u.rsym.ns);
4504 q->u.pointer = (void *) ns;
4505 sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
4506 sym->ts = udr->ts;
4507 sym->module = gfc_get_string ("%s", p1->u.rsym.module);
4508 associate_integer_pointer (p1, sym);
4509 sym->attr.omp_udr_artificial_var = 1;
4510 gcc_assert (p2->u.rsym.sym == NULL);
4511 sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4512 sym->ts = udr->ts;
4513 sym->module = gfc_get_string ("%s", p2->u.rsym.module);
4514 associate_integer_pointer (p2, sym);
4515 sym->attr.omp_udr_artificial_var = 1;
4516 if (mio_name (0, omp_declare_reduction_stmt) == 0)
4517 {
4518 ns->code = gfc_get_code (EXEC_ASSIGN);
4519 mio_expr (&ns->code->expr1);
4520 mio_expr (&ns->code->expr2);
4521 }
4522 else
4523 {
4524 int flag;
4525 ns->code = gfc_get_code (EXEC_CALL);
4526 mio_symtree_ref (&ns->code->symtree);
4527 mio_actual_arglist (&ns->code->ext.actual, false);
4528
4529 mio_integer (&flag);
4530 if (flag)
4531 {
4532 require_atom (ATOM_STRING);
4533 ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4534 free (atom_string);
4535 }
4536 else
4537 mio_symbol_ref (&ns->code->resolved_sym);
4538 }
4539 ns->code->loc = gfc_current_locus;
4540 ns->omp_udr_ns = 1;
4541 }
4542 }
4543
4544
4545 /* Unlike most other routines, the address of the symbol node is already
4546 fixed on input and the name/module has already been filled in.
4547 If you update the symbol format here, don't forget to update read_module
4548 as well (look for "seek to the symbol's component list"). */
4549
4550 static void
mio_symbol(gfc_symbol * sym)4551 mio_symbol (gfc_symbol *sym)
4552 {
4553 int intmod = INTMOD_NONE;
4554
4555 mio_lparen ();
4556
4557 mio_symbol_attribute (&sym->attr);
4558
4559 if (sym->attr.pdt_type)
4560 sym->name = gfc_dt_upper_string (sym->name);
4561
4562 /* Note that components are always saved, even if they are supposed
4563 to be private. Component access is checked during searching. */
4564 mio_component_list (&sym->components, sym->attr.vtype);
4565 if (sym->components != NULL)
4566 sym->component_access
4567 = MIO_NAME (gfc_access) (sym->component_access, access_types);
4568
4569 mio_typespec (&sym->ts);
4570 if (sym->ts.type == BT_CLASS)
4571 sym->attr.class_ok = 1;
4572
4573 if (iomode == IO_OUTPUT)
4574 mio_namespace_ref (&sym->formal_ns);
4575 else
4576 {
4577 mio_namespace_ref (&sym->formal_ns);
4578 if (sym->formal_ns)
4579 sym->formal_ns->proc_name = sym;
4580 }
4581
4582 /* Save/restore common block links. */
4583 mio_symbol_ref (&sym->common_next);
4584
4585 mio_formal_arglist (&sym->formal);
4586
4587 if (sym->attr.flavor == FL_PARAMETER)
4588 mio_expr (&sym->value);
4589
4590 mio_array_spec (&sym->as);
4591
4592 mio_symbol_ref (&sym->result);
4593
4594 if (sym->attr.cray_pointee)
4595 mio_symbol_ref (&sym->cp_pointer);
4596
4597 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4598 mio_full_f2k_derived (sym);
4599
4600 /* PDT types store the symbol specification list here. */
4601 mio_actual_arglist (&sym->param_list, true);
4602
4603 mio_namelist (sym);
4604
4605 /* Add the fields that say whether this is from an intrinsic module,
4606 and if so, what symbol it is within the module. */
4607 /* mio_integer (&(sym->from_intmod)); */
4608 if (iomode == IO_OUTPUT)
4609 {
4610 intmod = sym->from_intmod;
4611 mio_integer (&intmod);
4612 }
4613 else
4614 {
4615 mio_integer (&intmod);
4616 if (current_intmod)
4617 sym->from_intmod = current_intmod;
4618 else
4619 sym->from_intmod = (intmod_id) intmod;
4620 }
4621
4622 mio_integer (&(sym->intmod_sym_id));
4623
4624 if (gfc_fl_struct (sym->attr.flavor))
4625 mio_integer (&(sym->hash_value));
4626
4627 if (sym->formal_ns
4628 && sym->formal_ns->proc_name == sym
4629 && sym->formal_ns->entries == NULL)
4630 mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4631
4632 mio_rparen ();
4633 }
4634
4635
4636 /************************* Top level subroutines *************************/
4637
4638 /* A recursive function to look for a specific symbol by name and by
4639 module. Whilst several symtrees might point to one symbol, its
4640 is sufficient for the purposes here than one exist. Note that
4641 generic interfaces are distinguished as are symbols that have been
4642 renamed in another module. */
4643 static gfc_symtree *
find_symbol(gfc_symtree * st,const char * name,const char * module,int generic)4644 find_symbol (gfc_symtree *st, const char *name,
4645 const char *module, int generic)
4646 {
4647 int c;
4648 gfc_symtree *retval, *s;
4649
4650 if (st == NULL || st->n.sym == NULL)
4651 return NULL;
4652
4653 c = strcmp (name, st->n.sym->name);
4654 if (c == 0 && st->n.sym->module
4655 && strcmp (module, st->n.sym->module) == 0
4656 && !check_unique_name (st->name))
4657 {
4658 s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4659
4660 /* Detect symbols that are renamed by use association in another
4661 module by the absence of a symtree and null attr.use_rename,
4662 since the latter is not transmitted in the module file. */
4663 if (((!generic && !st->n.sym->attr.generic)
4664 || (generic && st->n.sym->attr.generic))
4665 && !(s == NULL && !st->n.sym->attr.use_rename))
4666 return st;
4667 }
4668
4669 retval = find_symbol (st->left, name, module, generic);
4670
4671 if (retval == NULL)
4672 retval = find_symbol (st->right, name, module, generic);
4673
4674 return retval;
4675 }
4676
4677
4678 /* Skip a list between balanced left and right parens.
4679 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4680 have been already parsed by hand, and the remaining of the content is to be
4681 skipped here. The default value is 0 (balanced parens). */
4682
4683 static void
4684 skip_list (int nest_level = 0)
4685 {
4686 int level;
4687
4688 level = nest_level;
4689 do
4690 {
4691 switch (parse_atom ())
4692 {
4693 case ATOM_LPAREN:
4694 level++;
4695 break;
4696
4697 case ATOM_RPAREN:
4698 level--;
4699 break;
4700
4701 case ATOM_STRING:
4702 free (atom_string);
4703 break;
4704
4705 case ATOM_NAME:
4706 case ATOM_INTEGER:
4707 break;
4708 }
4709 }
4710 while (level > 0);
4711 }
4712
4713
4714 /* Load operator interfaces from the module. Interfaces are unusual
4715 in that they attach themselves to existing symbols. */
4716
4717 static void
load_operator_interfaces(void)4718 load_operator_interfaces (void)
4719 {
4720 const char *p;
4721 /* "module" must be large enough for the case of submodules in which the name
4722 has the form module.submodule */
4723 char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4724 gfc_user_op *uop;
4725 pointer_info *pi = NULL;
4726 int n, i;
4727
4728 mio_lparen ();
4729
4730 while (peek_atom () != ATOM_RPAREN)
4731 {
4732 mio_lparen ();
4733
4734 mio_internal_string (name);
4735 mio_internal_string (module);
4736
4737 n = number_use_names (name, true);
4738 n = n ? n : 1;
4739
4740 for (i = 1; i <= n; i++)
4741 {
4742 /* Decide if we need to load this one or not. */
4743 p = find_use_name_n (name, &i, true);
4744
4745 if (p == NULL)
4746 {
4747 while (parse_atom () != ATOM_RPAREN);
4748 continue;
4749 }
4750
4751 if (i == 1)
4752 {
4753 uop = gfc_get_uop (p);
4754 pi = mio_interface_rest (&uop->op);
4755 }
4756 else
4757 {
4758 if (gfc_find_uop (p, NULL))
4759 continue;
4760 uop = gfc_get_uop (p);
4761 uop->op = gfc_get_interface ();
4762 uop->op->where = gfc_current_locus;
4763 add_fixup (pi->integer, &uop->op->sym);
4764 }
4765 }
4766 }
4767
4768 mio_rparen ();
4769 }
4770
4771
4772 /* Load interfaces from the module. Interfaces are unusual in that
4773 they attach themselves to existing symbols. */
4774
4775 static void
load_generic_interfaces(void)4776 load_generic_interfaces (void)
4777 {
4778 const char *p;
4779 /* "module" must be large enough for the case of submodules in which the name
4780 has the form module.submodule */
4781 char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4782 gfc_symbol *sym;
4783 gfc_interface *generic = NULL, *gen = NULL;
4784 int n, i, renamed;
4785 bool ambiguous_set = false;
4786
4787 mio_lparen ();
4788
4789 while (peek_atom () != ATOM_RPAREN)
4790 {
4791 mio_lparen ();
4792
4793 mio_internal_string (name);
4794 mio_internal_string (module);
4795
4796 n = number_use_names (name, false);
4797 renamed = n ? 1 : 0;
4798 n = n ? n : 1;
4799
4800 for (i = 1; i <= n; i++)
4801 {
4802 gfc_symtree *st;
4803 /* Decide if we need to load this one or not. */
4804 p = find_use_name_n (name, &i, false);
4805
4806 if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4807 {
4808 /* Skip the specific names for these cases. */
4809 while (i == 1 && parse_atom () != ATOM_RPAREN);
4810
4811 continue;
4812 }
4813
4814 st = find_symbol (gfc_current_ns->sym_root,
4815 name, module_name, 1);
4816
4817 /* If the symbol exists already and is being USEd without being
4818 in an ONLY clause, do not load a new symtree(11.3.2). */
4819 if (!only_flag && st)
4820 sym = st->n.sym;
4821
4822 if (!sym)
4823 {
4824 if (st)
4825 {
4826 sym = st->n.sym;
4827 if (strcmp (st->name, p) != 0)
4828 {
4829 st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4830 st->n.sym = sym;
4831 sym->refs++;
4832 }
4833 }
4834
4835 /* Since we haven't found a valid generic interface, we had
4836 better make one. */
4837 if (!sym)
4838 {
4839 gfc_get_symbol (p, NULL, &sym);
4840 sym->name = gfc_get_string ("%s", name);
4841 sym->module = module_name;
4842 sym->attr.flavor = FL_PROCEDURE;
4843 sym->attr.generic = 1;
4844 sym->attr.use_assoc = 1;
4845 }
4846 }
4847 else
4848 {
4849 /* Unless sym is a generic interface, this reference
4850 is ambiguous. */
4851 if (st == NULL)
4852 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4853
4854 sym = st->n.sym;
4855
4856 if (st && !sym->attr.generic
4857 && !st->ambiguous
4858 && sym->module
4859 && strcmp (module, sym->module))
4860 {
4861 ambiguous_set = true;
4862 st->ambiguous = 1;
4863 }
4864 }
4865
4866 sym->attr.use_only = only_flag;
4867 sym->attr.use_rename = renamed;
4868
4869 if (i == 1)
4870 {
4871 mio_interface_rest (&sym->generic);
4872 generic = sym->generic;
4873 }
4874 else if (!sym->generic)
4875 {
4876 sym->generic = generic;
4877 sym->attr.generic_copy = 1;
4878 }
4879
4880 /* If a procedure that is not generic has generic interfaces
4881 that include itself, it is generic! We need to take care
4882 to retain symbols ambiguous that were already so. */
4883 if (sym->attr.use_assoc
4884 && !sym->attr.generic
4885 && sym->attr.flavor == FL_PROCEDURE)
4886 {
4887 for (gen = generic; gen; gen = gen->next)
4888 {
4889 if (gen->sym == sym)
4890 {
4891 sym->attr.generic = 1;
4892 if (ambiguous_set)
4893 st->ambiguous = 0;
4894 break;
4895 }
4896 }
4897 }
4898
4899 }
4900 }
4901
4902 mio_rparen ();
4903 }
4904
4905
4906 /* Load common blocks. */
4907
4908 static void
load_commons(void)4909 load_commons (void)
4910 {
4911 char name[GFC_MAX_SYMBOL_LEN + 1];
4912 gfc_common_head *p;
4913
4914 mio_lparen ();
4915
4916 while (peek_atom () != ATOM_RPAREN)
4917 {
4918 int flags = 0;
4919 char* label;
4920 mio_lparen ();
4921 mio_internal_string (name);
4922
4923 p = gfc_get_common (name, 1);
4924
4925 mio_symbol_ref (&p->head);
4926 mio_integer (&flags);
4927 if (flags & 1)
4928 p->saved = 1;
4929 if (flags & 2)
4930 p->threadprivate = 1;
4931 p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3);
4932 p->use_assoc = 1;
4933
4934 /* Get whether this was a bind(c) common or not. */
4935 mio_integer (&p->is_bind_c);
4936 /* Get the binding label. */
4937 label = read_string ();
4938 if (strlen (label))
4939 p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4940 XDELETEVEC (label);
4941
4942 mio_rparen ();
4943 }
4944
4945 mio_rparen ();
4946 }
4947
4948
4949 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4950 so that unused variables are not loaded and so that the expression can
4951 be safely freed. */
4952
4953 static void
load_equiv(void)4954 load_equiv (void)
4955 {
4956 gfc_equiv *head, *tail, *end, *eq, *equiv;
4957 bool duplicate;
4958
4959 mio_lparen ();
4960 in_load_equiv = true;
4961
4962 end = gfc_current_ns->equiv;
4963 while (end != NULL && end->next != NULL)
4964 end = end->next;
4965
4966 while (peek_atom () != ATOM_RPAREN) {
4967 mio_lparen ();
4968 head = tail = NULL;
4969
4970 while(peek_atom () != ATOM_RPAREN)
4971 {
4972 if (head == NULL)
4973 head = tail = gfc_get_equiv ();
4974 else
4975 {
4976 tail->eq = gfc_get_equiv ();
4977 tail = tail->eq;
4978 }
4979
4980 mio_pool_string (&tail->module);
4981 mio_expr (&tail->expr);
4982 }
4983
4984 /* Check for duplicate equivalences being loaded from different modules */
4985 duplicate = false;
4986 for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
4987 {
4988 if (equiv->module && head->module
4989 && strcmp (equiv->module, head->module) == 0)
4990 {
4991 duplicate = true;
4992 break;
4993 }
4994 }
4995
4996 if (duplicate)
4997 {
4998 for (eq = head; eq; eq = head)
4999 {
5000 head = eq->eq;
5001 gfc_free_expr (eq->expr);
5002 free (eq);
5003 }
5004 }
5005
5006 if (end == NULL)
5007 gfc_current_ns->equiv = head;
5008 else
5009 end->next = head;
5010
5011 if (head != NULL)
5012 end = head;
5013
5014 mio_rparen ();
5015 }
5016
5017 mio_rparen ();
5018 in_load_equiv = false;
5019 }
5020
5021
5022 /* This function loads OpenMP user defined reductions. */
5023 static void
load_omp_udrs(void)5024 load_omp_udrs (void)
5025 {
5026 mio_lparen ();
5027 while (peek_atom () != ATOM_RPAREN)
5028 {
5029 const char *name = NULL, *newname;
5030 char *altname;
5031 gfc_typespec ts;
5032 gfc_symtree *st;
5033 gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
5034
5035 mio_lparen ();
5036 mio_pool_string (&name);
5037 gfc_clear_ts (&ts);
5038 mio_typespec (&ts);
5039 if (startswith (name, "operator "))
5040 {
5041 const char *p = name + sizeof ("operator ") - 1;
5042 if (strcmp (p, "+") == 0)
5043 rop = OMP_REDUCTION_PLUS;
5044 else if (strcmp (p, "*") == 0)
5045 rop = OMP_REDUCTION_TIMES;
5046 else if (strcmp (p, "-") == 0)
5047 rop = OMP_REDUCTION_MINUS;
5048 else if (strcmp (p, ".and.") == 0)
5049 rop = OMP_REDUCTION_AND;
5050 else if (strcmp (p, ".or.") == 0)
5051 rop = OMP_REDUCTION_OR;
5052 else if (strcmp (p, ".eqv.") == 0)
5053 rop = OMP_REDUCTION_EQV;
5054 else if (strcmp (p, ".neqv.") == 0)
5055 rop = OMP_REDUCTION_NEQV;
5056 }
5057 altname = NULL;
5058 if (rop == OMP_REDUCTION_USER && name[0] == '.')
5059 {
5060 size_t len = strlen (name + 1);
5061 altname = XALLOCAVEC (char, len);
5062 gcc_assert (name[len] == '.');
5063 memcpy (altname, name + 1, len - 1);
5064 altname[len - 1] = '\0';
5065 }
5066 newname = name;
5067 if (rop == OMP_REDUCTION_USER)
5068 newname = find_use_name (altname ? altname : name, !!altname);
5069 else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
5070 newname = NULL;
5071 if (newname == NULL)
5072 {
5073 skip_list (1);
5074 continue;
5075 }
5076 if (altname && newname != altname)
5077 {
5078 size_t len = strlen (newname);
5079 altname = XALLOCAVEC (char, len + 3);
5080 altname[0] = '.';
5081 memcpy (altname + 1, newname, len);
5082 altname[len + 1] = '.';
5083 altname[len + 2] = '\0';
5084 name = gfc_get_string ("%s", altname);
5085 }
5086 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5087 gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
5088 if (udr)
5089 {
5090 require_atom (ATOM_INTEGER);
5091 pointer_info *p = get_integer (atom_int);
5092 if (strcmp (p->u.rsym.module, udr->omp_out->module))
5093 {
5094 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
5095 "module %s at %L",
5096 p->u.rsym.module, &gfc_current_locus);
5097 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
5098 "%s at %L",
5099 udr->omp_out->module, &udr->where);
5100 }
5101 skip_list (1);
5102 continue;
5103 }
5104 udr = gfc_get_omp_udr ();
5105 udr->name = name;
5106 udr->rop = rop;
5107 udr->ts = ts;
5108 udr->where = gfc_current_locus;
5109 udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5110 udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
5111 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
5112 false);
5113 if (peek_atom () != ATOM_RPAREN)
5114 {
5115 udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5116 udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
5117 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5118 udr->initializer_ns, true);
5119 }
5120 if (st)
5121 {
5122 udr->next = st->n.omp_udr;
5123 st->n.omp_udr = udr;
5124 }
5125 else
5126 {
5127 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
5128 st->n.omp_udr = udr;
5129 }
5130 mio_rparen ();
5131 }
5132 mio_rparen ();
5133 }
5134
5135
5136 /* Recursive function to traverse the pointer_info tree and load a
5137 needed symbol. We return nonzero if we load a symbol and stop the
5138 traversal, because the act of loading can alter the tree. */
5139
5140 static int
load_needed(pointer_info * p)5141 load_needed (pointer_info *p)
5142 {
5143 gfc_namespace *ns;
5144 pointer_info *q;
5145 gfc_symbol *sym;
5146 int rv;
5147
5148 rv = 0;
5149 if (p == NULL)
5150 return rv;
5151
5152 rv |= load_needed (p->left);
5153 rv |= load_needed (p->right);
5154
5155 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
5156 return rv;
5157
5158 p->u.rsym.state = USED;
5159
5160 set_module_locus (&p->u.rsym.where);
5161
5162 sym = p->u.rsym.sym;
5163 if (sym == NULL)
5164 {
5165 q = get_integer (p->u.rsym.ns);
5166
5167 ns = (gfc_namespace *) q->u.pointer;
5168 if (ns == NULL)
5169 {
5170 /* Create an interface namespace if necessary. These are
5171 the namespaces that hold the formal parameters of module
5172 procedures. */
5173
5174 ns = gfc_get_namespace (NULL, 0);
5175 associate_integer_pointer (q, ns);
5176 }
5177
5178 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5179 doesn't go pear-shaped if the symbol is used. */
5180 if (!ns->proc_name)
5181 gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
5182 1, &ns->proc_name);
5183
5184 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
5185 sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
5186 sym->module = gfc_get_string ("%s", p->u.rsym.module);
5187 if (p->u.rsym.binding_label)
5188 sym->binding_label = IDENTIFIER_POINTER (get_identifier
5189 (p->u.rsym.binding_label));
5190
5191 associate_integer_pointer (p, sym);
5192 }
5193
5194 mio_symbol (sym);
5195 sym->attr.use_assoc = 1;
5196
5197 /* Unliked derived types, a STRUCTURE may share names with other symbols.
5198 We greedily converted the symbol name to lowercase before we knew its
5199 type, so now we must fix it. */
5200 if (sym->attr.flavor == FL_STRUCT)
5201 sym->name = gfc_dt_upper_string (sym->name);
5202
5203 /* Mark as only or rename for later diagnosis for explicitly imported
5204 but not used warnings; don't mark internal symbols such as __vtab,
5205 __def_init etc. Only mark them if they have been explicitly loaded. */
5206
5207 if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
5208 {
5209 gfc_use_rename *u;
5210
5211 /* Search the use/rename list for the variable; if the variable is
5212 found, mark it. */
5213 for (u = gfc_rename_list; u; u = u->next)
5214 {
5215 if (strcmp (u->use_name, sym->name) == 0)
5216 {
5217 sym->attr.use_only = 1;
5218 break;
5219 }
5220 }
5221 }
5222
5223 if (p->u.rsym.renamed)
5224 sym->attr.use_rename = 1;
5225
5226 return 1;
5227 }
5228
5229
5230 /* Recursive function for cleaning up things after a module has been read. */
5231
5232 static void
read_cleanup(pointer_info * p)5233 read_cleanup (pointer_info *p)
5234 {
5235 gfc_symtree *st;
5236 pointer_info *q;
5237
5238 if (p == NULL)
5239 return;
5240
5241 read_cleanup (p->left);
5242 read_cleanup (p->right);
5243
5244 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
5245 {
5246 gfc_namespace *ns;
5247 /* Add hidden symbols to the symtree. */
5248 q = get_integer (p->u.rsym.ns);
5249 ns = (gfc_namespace *) q->u.pointer;
5250
5251 if (!p->u.rsym.sym->attr.vtype
5252 && !p->u.rsym.sym->attr.vtab)
5253 st = gfc_get_unique_symtree (ns);
5254 else
5255 {
5256 /* There is no reason to use 'unique_symtrees' for vtabs or
5257 vtypes - their name is fine for a symtree and reduces the
5258 namespace pollution. */
5259 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
5260 if (!st)
5261 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
5262 }
5263
5264 st->n.sym = p->u.rsym.sym;
5265 st->n.sym->refs++;
5266
5267 /* Fixup any symtree references. */
5268 p->u.rsym.symtree = st;
5269 resolve_fixups (p->u.rsym.stfixup, st);
5270 p->u.rsym.stfixup = NULL;
5271 }
5272
5273 /* Free unused symbols. */
5274 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
5275 gfc_free_symbol (p->u.rsym.sym);
5276 }
5277
5278
5279 /* It is not quite enough to check for ambiguity in the symbols by
5280 the loaded symbol and the new symbol not being identical. */
5281 static bool
check_for_ambiguous(gfc_symtree * st,pointer_info * info)5282 check_for_ambiguous (gfc_symtree *st, pointer_info *info)
5283 {
5284 gfc_symbol *rsym;
5285 module_locus locus;
5286 symbol_attribute attr;
5287 gfc_symbol *st_sym;
5288
5289 if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
5290 {
5291 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5292 "current program unit", st->name, module_name);
5293 return true;
5294 }
5295
5296 st_sym = st->n.sym;
5297 rsym = info->u.rsym.sym;
5298 if (st_sym == rsym)
5299 return false;
5300
5301 if (st_sym->attr.vtab || st_sym->attr.vtype)
5302 return false;
5303
5304 /* If the existing symbol is generic from a different module and
5305 the new symbol is generic there can be no ambiguity. */
5306 if (st_sym->attr.generic
5307 && st_sym->module
5308 && st_sym->module != module_name)
5309 {
5310 /* The new symbol's attributes have not yet been read. Since
5311 we need attr.generic, read it directly. */
5312 get_module_locus (&locus);
5313 set_module_locus (&info->u.rsym.where);
5314 mio_lparen ();
5315 attr.generic = 0;
5316 mio_symbol_attribute (&attr);
5317 set_module_locus (&locus);
5318 if (attr.generic)
5319 return false;
5320 }
5321
5322 return true;
5323 }
5324
5325
5326 /* Read a module file. */
5327
5328 static void
read_module(void)5329 read_module (void)
5330 {
5331 module_locus operator_interfaces, user_operators, omp_udrs;
5332 const char *p;
5333 char name[GFC_MAX_SYMBOL_LEN + 1];
5334 int i;
5335 /* Workaround -Wmaybe-uninitialized false positive during
5336 profiledbootstrap by initializing them. */
5337 int ambiguous = 0, j, nuse, symbol = 0;
5338 pointer_info *info, *q;
5339 gfc_use_rename *u = NULL;
5340 gfc_symtree *st;
5341 gfc_symbol *sym;
5342
5343 get_module_locus (&operator_interfaces); /* Skip these for now. */
5344 skip_list ();
5345
5346 get_module_locus (&user_operators);
5347 skip_list ();
5348 skip_list ();
5349
5350 /* Skip commons and equivalences for now. */
5351 skip_list ();
5352 skip_list ();
5353
5354 /* Skip OpenMP UDRs. */
5355 get_module_locus (&omp_udrs);
5356 skip_list ();
5357
5358 mio_lparen ();
5359
5360 /* Create the fixup nodes for all the symbols. */
5361
5362 while (peek_atom () != ATOM_RPAREN)
5363 {
5364 char* bind_label;
5365 require_atom (ATOM_INTEGER);
5366 info = get_integer (atom_int);
5367
5368 info->type = P_SYMBOL;
5369 info->u.rsym.state = UNUSED;
5370
5371 info->u.rsym.true_name = read_string ();
5372 info->u.rsym.module = read_string ();
5373 bind_label = read_string ();
5374 if (strlen (bind_label))
5375 info->u.rsym.binding_label = bind_label;
5376 else
5377 XDELETEVEC (bind_label);
5378
5379 require_atom (ATOM_INTEGER);
5380 info->u.rsym.ns = atom_int;
5381
5382 get_module_locus (&info->u.rsym.where);
5383
5384 /* See if the symbol has already been loaded by a previous module.
5385 If so, we reference the existing symbol and prevent it from
5386 being loaded again. This should not happen if the symbol being
5387 read is an index for an assumed shape dummy array (ns != 1). */
5388
5389 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
5390
5391 if (sym == NULL
5392 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
5393 {
5394 skip_list ();
5395 continue;
5396 }
5397
5398 info->u.rsym.state = USED;
5399 info->u.rsym.sym = sym;
5400 /* The current symbol has already been loaded, so we can avoid loading
5401 it again. However, if it is a derived type, some of its components
5402 can be used in expressions in the module. To avoid the module loading
5403 failing, we need to associate the module's component pointer indexes
5404 with the existing symbol's component pointers. */
5405 if (gfc_fl_struct (sym->attr.flavor))
5406 {
5407 gfc_component *c;
5408
5409 /* First seek to the symbol's component list. */
5410 mio_lparen (); /* symbol opening. */
5411 skip_list (); /* skip symbol attribute. */
5412
5413 mio_lparen (); /* component list opening. */
5414 for (c = sym->components; c; c = c->next)
5415 {
5416 pointer_info *p;
5417 const char *comp_name = NULL;
5418 int n = 0;
5419
5420 mio_lparen (); /* component opening. */
5421 mio_integer (&n);
5422 p = get_integer (n);
5423 if (p->u.pointer == NULL)
5424 associate_integer_pointer (p, c);
5425 mio_pool_string (&comp_name);
5426 if (comp_name != c->name)
5427 {
5428 gfc_fatal_error ("Mismatch in components of derived type "
5429 "%qs from %qs at %C: expecting %qs, "
5430 "but got %qs", sym->name, sym->module,
5431 c->name, comp_name);
5432 }
5433 skip_list (1); /* component end. */
5434 }
5435 mio_rparen (); /* component list closing. */
5436
5437 skip_list (1); /* symbol end. */
5438 }
5439 else
5440 skip_list ();
5441
5442 /* Some symbols do not have a namespace (eg. formal arguments),
5443 so the automatic "unique symtree" mechanism must be suppressed
5444 by marking them as referenced. */
5445 q = get_integer (info->u.rsym.ns);
5446 if (q->u.pointer == NULL)
5447 {
5448 info->u.rsym.referenced = 1;
5449 continue;
5450 }
5451 }
5452
5453 mio_rparen ();
5454
5455 /* Parse the symtree lists. This lets us mark which symbols need to
5456 be loaded. Renaming is also done at this point by replacing the
5457 symtree name. */
5458
5459 mio_lparen ();
5460
5461 while (peek_atom () != ATOM_RPAREN)
5462 {
5463 mio_internal_string (name);
5464 mio_integer (&ambiguous);
5465 mio_integer (&symbol);
5466
5467 info = get_integer (symbol);
5468
5469 /* See how many use names there are. If none, go through the start
5470 of the loop at least once. */
5471 nuse = number_use_names (name, false);
5472 info->u.rsym.renamed = nuse ? 1 : 0;
5473
5474 if (nuse == 0)
5475 nuse = 1;
5476
5477 for (j = 1; j <= nuse; j++)
5478 {
5479 /* Get the jth local name for this symbol. */
5480 p = find_use_name_n (name, &j, false);
5481
5482 if (p == NULL && strcmp (name, module_name) == 0)
5483 p = name;
5484
5485 /* Exception: Always import vtabs & vtypes. */
5486 if (p == NULL && name[0] == '_'
5487 && (startswith (name, "__vtab_")
5488 || startswith (name, "__vtype_")))
5489 p = name;
5490
5491 /* Skip symtree nodes not in an ONLY clause, unless there
5492 is an existing symtree loaded from another USE statement. */
5493 if (p == NULL)
5494 {
5495 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5496 if (st != NULL
5497 && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5498 && st->n.sym->module != NULL
5499 && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5500 {
5501 info->u.rsym.symtree = st;
5502 info->u.rsym.sym = st->n.sym;
5503 }
5504 continue;
5505 }
5506
5507 /* If a symbol of the same name and module exists already,
5508 this symbol, which is not in an ONLY clause, must not be
5509 added to the namespace(11.3.2). Note that find_symbol
5510 only returns the first occurrence that it finds. */
5511 if (!only_flag && !info->u.rsym.renamed
5512 && strcmp (name, module_name) != 0
5513 && find_symbol (gfc_current_ns->sym_root, name,
5514 module_name, 0))
5515 continue;
5516
5517 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5518
5519 if (st != NULL
5520 && !(st->n.sym && st->n.sym->attr.used_in_submodule))
5521 {
5522 /* Check for ambiguous symbols. */
5523 if (check_for_ambiguous (st, info))
5524 st->ambiguous = 1;
5525 else
5526 info->u.rsym.symtree = st;
5527 }
5528 else
5529 {
5530 if (st)
5531 {
5532 /* This symbol is host associated from a module in a
5533 submodule. Hide it with a unique symtree. */
5534 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
5535 s->n.sym = st->n.sym;
5536 st->n.sym = NULL;
5537 }
5538 else
5539 {
5540 /* Create a symtree node in the current namespace for this
5541 symbol. */
5542 st = check_unique_name (p)
5543 ? gfc_get_unique_symtree (gfc_current_ns)
5544 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5545 st->ambiguous = ambiguous;
5546 }
5547
5548 sym = info->u.rsym.sym;
5549
5550 /* Create a symbol node if it doesn't already exist. */
5551 if (sym == NULL)
5552 {
5553 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5554 gfc_current_ns);
5555 info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
5556 sym = info->u.rsym.sym;
5557 sym->module = gfc_get_string ("%s", info->u.rsym.module);
5558
5559 if (info->u.rsym.binding_label)
5560 {
5561 tree id = get_identifier (info->u.rsym.binding_label);
5562 sym->binding_label = IDENTIFIER_POINTER (id);
5563 }
5564 }
5565
5566 st->n.sym = sym;
5567 st->n.sym->refs++;
5568
5569 if (strcmp (name, p) != 0)
5570 sym->attr.use_rename = 1;
5571
5572 if (name[0] != '_'
5573 || (!startswith (name, "__vtab_")
5574 && !startswith (name, "__vtype_")))
5575 sym->attr.use_only = only_flag;
5576
5577 /* Store the symtree pointing to this symbol. */
5578 info->u.rsym.symtree = st;
5579
5580 if (info->u.rsym.state == UNUSED)
5581 info->u.rsym.state = NEEDED;
5582 info->u.rsym.referenced = 1;
5583 }
5584 }
5585 }
5586
5587 mio_rparen ();
5588
5589 /* Load intrinsic operator interfaces. */
5590 set_module_locus (&operator_interfaces);
5591 mio_lparen ();
5592
5593 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5594 {
5595 gfc_use_rename *u = NULL, *v = NULL;
5596 int j = i;
5597
5598 if (i == INTRINSIC_USER)
5599 continue;
5600
5601 if (only_flag)
5602 {
5603 u = find_use_operator ((gfc_intrinsic_op) i);
5604
5605 /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
5606 relational operators. Special handling for USE, ONLY. */
5607 switch (i)
5608 {
5609 case INTRINSIC_EQ:
5610 j = INTRINSIC_EQ_OS;
5611 break;
5612 case INTRINSIC_EQ_OS:
5613 j = INTRINSIC_EQ;
5614 break;
5615 case INTRINSIC_NE:
5616 j = INTRINSIC_NE_OS;
5617 break;
5618 case INTRINSIC_NE_OS:
5619 j = INTRINSIC_NE;
5620 break;
5621 case INTRINSIC_GT:
5622 j = INTRINSIC_GT_OS;
5623 break;
5624 case INTRINSIC_GT_OS:
5625 j = INTRINSIC_GT;
5626 break;
5627 case INTRINSIC_GE:
5628 j = INTRINSIC_GE_OS;
5629 break;
5630 case INTRINSIC_GE_OS:
5631 j = INTRINSIC_GE;
5632 break;
5633 case INTRINSIC_LT:
5634 j = INTRINSIC_LT_OS;
5635 break;
5636 case INTRINSIC_LT_OS:
5637 j = INTRINSIC_LT;
5638 break;
5639 case INTRINSIC_LE:
5640 j = INTRINSIC_LE_OS;
5641 break;
5642 case INTRINSIC_LE_OS:
5643 j = INTRINSIC_LE;
5644 break;
5645 default:
5646 break;
5647 }
5648
5649 if (j != i)
5650 v = find_use_operator ((gfc_intrinsic_op) j);
5651
5652 if (u == NULL && v == NULL)
5653 {
5654 skip_list ();
5655 continue;
5656 }
5657
5658 if (u)
5659 u->found = 1;
5660 if (v)
5661 v->found = 1;
5662 }
5663
5664 mio_interface (&gfc_current_ns->op[i]);
5665 if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j])
5666 {
5667 if (u)
5668 u->found = 0;
5669 if (v)
5670 v->found = 0;
5671 }
5672 }
5673
5674 mio_rparen ();
5675
5676 /* Load generic and user operator interfaces. These must follow the
5677 loading of symtree because otherwise symbols can be marked as
5678 ambiguous. */
5679
5680 set_module_locus (&user_operators);
5681
5682 load_operator_interfaces ();
5683 load_generic_interfaces ();
5684
5685 load_commons ();
5686 load_equiv ();
5687
5688 /* Load OpenMP user defined reductions. */
5689 set_module_locus (&omp_udrs);
5690 load_omp_udrs ();
5691
5692 /* At this point, we read those symbols that are needed but haven't
5693 been loaded yet. If one symbol requires another, the other gets
5694 marked as NEEDED if its previous state was UNUSED. */
5695
5696 while (load_needed (pi_root));
5697
5698 /* Make sure all elements of the rename-list were found in the module. */
5699
5700 for (u = gfc_rename_list; u; u = u->next)
5701 {
5702 if (u->found)
5703 continue;
5704
5705 if (u->op == INTRINSIC_NONE)
5706 {
5707 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5708 u->use_name, &u->where, module_name);
5709 continue;
5710 }
5711
5712 if (u->op == INTRINSIC_USER)
5713 {
5714 gfc_error ("User operator %qs referenced at %L not found "
5715 "in module %qs", u->use_name, &u->where, module_name);
5716 continue;
5717 }
5718
5719 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5720 "in module %qs", gfc_op2string (u->op), &u->where,
5721 module_name);
5722 }
5723
5724 /* Clean up symbol nodes that were never loaded, create references
5725 to hidden symbols. */
5726
5727 read_cleanup (pi_root);
5728 }
5729
5730
5731 /* Given an access type that is specific to an entity and the default
5732 access, return nonzero if the entity is publicly accessible. If the
5733 element is declared as PUBLIC, then it is public; if declared
5734 PRIVATE, then private, and otherwise it is public unless the default
5735 access in this context has been declared PRIVATE. */
5736
5737 static bool dump_smod = false;
5738
5739 static bool
check_access(gfc_access specific_access,gfc_access default_access)5740 check_access (gfc_access specific_access, gfc_access default_access)
5741 {
5742 if (dump_smod)
5743 return true;
5744
5745 if (specific_access == ACCESS_PUBLIC)
5746 return TRUE;
5747 if (specific_access == ACCESS_PRIVATE)
5748 return FALSE;
5749
5750 if (flag_module_private)
5751 return default_access == ACCESS_PUBLIC;
5752 else
5753 return default_access != ACCESS_PRIVATE;
5754 }
5755
5756
5757 bool
gfc_check_symbol_access(gfc_symbol * sym)5758 gfc_check_symbol_access (gfc_symbol *sym)
5759 {
5760 if (sym->attr.vtab || sym->attr.vtype)
5761 return true;
5762 else
5763 return check_access (sym->attr.access, sym->ns->default_access);
5764 }
5765
5766
5767 /* A structure to remember which commons we've already written. */
5768
5769 struct written_common
5770 {
5771 BBT_HEADER(written_common);
5772 const char *name, *label;
5773 };
5774
5775 static struct written_common *written_commons = NULL;
5776
5777 /* Comparison function used for balancing the binary tree. */
5778
5779 static int
compare_written_commons(void * a1,void * b1)5780 compare_written_commons (void *a1, void *b1)
5781 {
5782 const char *aname = ((struct written_common *) a1)->name;
5783 const char *alabel = ((struct written_common *) a1)->label;
5784 const char *bname = ((struct written_common *) b1)->name;
5785 const char *blabel = ((struct written_common *) b1)->label;
5786 int c = strcmp (aname, bname);
5787
5788 return (c != 0 ? c : strcmp (alabel, blabel));
5789 }
5790
5791 /* Free a list of written commons. */
5792
5793 static void
free_written_common(struct written_common * w)5794 free_written_common (struct written_common *w)
5795 {
5796 if (!w)
5797 return;
5798
5799 if (w->left)
5800 free_written_common (w->left);
5801 if (w->right)
5802 free_written_common (w->right);
5803
5804 free (w);
5805 }
5806
5807 /* Write a common block to the module -- recursive helper function. */
5808
5809 static void
write_common_0(gfc_symtree * st,bool this_module)5810 write_common_0 (gfc_symtree *st, bool this_module)
5811 {
5812 gfc_common_head *p;
5813 const char * name;
5814 int flags;
5815 const char *label;
5816 struct written_common *w;
5817 bool write_me = true;
5818
5819 if (st == NULL)
5820 return;
5821
5822 write_common_0 (st->left, this_module);
5823
5824 /* We will write out the binding label, or "" if no label given. */
5825 name = st->n.common->name;
5826 p = st->n.common;
5827 label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5828
5829 /* Check if we've already output this common. */
5830 w = written_commons;
5831 while (w)
5832 {
5833 int c = strcmp (name, w->name);
5834 c = (c != 0 ? c : strcmp (label, w->label));
5835 if (c == 0)
5836 write_me = false;
5837
5838 w = (c < 0) ? w->left : w->right;
5839 }
5840
5841 if (this_module && p->use_assoc)
5842 write_me = false;
5843
5844 if (write_me)
5845 {
5846 /* Write the common to the module. */
5847 mio_lparen ();
5848 mio_pool_string (&name);
5849
5850 mio_symbol_ref (&p->head);
5851 flags = p->saved ? 1 : 0;
5852 if (p->threadprivate)
5853 flags |= 2;
5854 flags |= p->omp_device_type << 2;
5855 mio_integer (&flags);
5856
5857 /* Write out whether the common block is bind(c) or not. */
5858 mio_integer (&(p->is_bind_c));
5859
5860 mio_pool_string (&label);
5861 mio_rparen ();
5862
5863 /* Record that we have written this common. */
5864 w = XCNEW (struct written_common);
5865 w->name = p->name;
5866 w->label = label;
5867 gfc_insert_bbt (&written_commons, w, compare_written_commons);
5868 }
5869
5870 write_common_0 (st->right, this_module);
5871 }
5872
5873
5874 /* Write a common, by initializing the list of written commons, calling
5875 the recursive function write_common_0() and cleaning up afterwards. */
5876
5877 static void
write_common(gfc_symtree * st)5878 write_common (gfc_symtree *st)
5879 {
5880 written_commons = NULL;
5881 write_common_0 (st, true);
5882 write_common_0 (st, false);
5883 free_written_common (written_commons);
5884 written_commons = NULL;
5885 }
5886
5887
5888 /* Write the blank common block to the module. */
5889
5890 static void
write_blank_common(void)5891 write_blank_common (void)
5892 {
5893 const char * name = BLANK_COMMON_NAME;
5894 int saved;
5895 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5896 this, but it hasn't been checked. Just making it so for now. */
5897 int is_bind_c = 0;
5898
5899 if (gfc_current_ns->blank_common.head == NULL)
5900 return;
5901
5902 mio_lparen ();
5903
5904 mio_pool_string (&name);
5905
5906 mio_symbol_ref (&gfc_current_ns->blank_common.head);
5907 saved = gfc_current_ns->blank_common.saved;
5908 mio_integer (&saved);
5909
5910 /* Write out whether the common block is bind(c) or not. */
5911 mio_integer (&is_bind_c);
5912
5913 /* Write out an empty binding label. */
5914 write_atom (ATOM_STRING, "");
5915
5916 mio_rparen ();
5917 }
5918
5919
5920 /* Write equivalences to the module. */
5921
5922 static void
write_equiv(void)5923 write_equiv (void)
5924 {
5925 gfc_equiv *eq, *e;
5926 int num;
5927
5928 num = 0;
5929 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5930 {
5931 mio_lparen ();
5932
5933 for (e = eq; e; e = e->eq)
5934 {
5935 if (e->module == NULL)
5936 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5937 mio_allocated_string (e->module);
5938 mio_expr (&e->expr);
5939 }
5940
5941 num++;
5942 mio_rparen ();
5943 }
5944 }
5945
5946
5947 /* Write a symbol to the module. */
5948
5949 static void
write_symbol(int n,gfc_symbol * sym)5950 write_symbol (int n, gfc_symbol *sym)
5951 {
5952 const char *label;
5953
5954 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5955 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
5956
5957 mio_integer (&n);
5958
5959 if (gfc_fl_struct (sym->attr.flavor))
5960 {
5961 const char *name;
5962 name = gfc_dt_upper_string (sym->name);
5963 mio_pool_string (&name);
5964 }
5965 else
5966 mio_pool_string (&sym->name);
5967
5968 mio_pool_string (&sym->module);
5969 if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5970 {
5971 label = sym->binding_label;
5972 mio_pool_string (&label);
5973 }
5974 else
5975 write_atom (ATOM_STRING, "");
5976
5977 mio_pointer_ref (&sym->ns);
5978
5979 mio_symbol (sym);
5980 write_char ('\n');
5981 }
5982
5983
5984 /* Recursive traversal function to write the initial set of symbols to
5985 the module. We check to see if the symbol should be written
5986 according to the access specification. */
5987
5988 static void
write_symbol0(gfc_symtree * st)5989 write_symbol0 (gfc_symtree *st)
5990 {
5991 gfc_symbol *sym;
5992 pointer_info *p;
5993 bool dont_write = false;
5994
5995 if (st == NULL)
5996 return;
5997
5998 write_symbol0 (st->left);
5999
6000 sym = st->n.sym;
6001 if (sym->module == NULL)
6002 sym->module = module_name;
6003
6004 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
6005 && !sym->attr.subroutine && !sym->attr.function)
6006 dont_write = true;
6007
6008 if (!gfc_check_symbol_access (sym))
6009 dont_write = true;
6010
6011 if (!dont_write)
6012 {
6013 p = get_pointer (sym);
6014 if (p->type == P_UNKNOWN)
6015 p->type = P_SYMBOL;
6016
6017 if (p->u.wsym.state != WRITTEN)
6018 {
6019 write_symbol (p->integer, sym);
6020 p->u.wsym.state = WRITTEN;
6021 }
6022 }
6023
6024 write_symbol0 (st->right);
6025 }
6026
6027
6028 static void
write_omp_udr(gfc_omp_udr * udr)6029 write_omp_udr (gfc_omp_udr *udr)
6030 {
6031 switch (udr->rop)
6032 {
6033 case OMP_REDUCTION_USER:
6034 /* Non-operators can't be used outside of the module. */
6035 if (udr->name[0] != '.')
6036 return;
6037 else
6038 {
6039 gfc_symtree *st;
6040 size_t len = strlen (udr->name + 1);
6041 char *name = XALLOCAVEC (char, len);
6042 memcpy (name, udr->name, len - 1);
6043 name[len - 1] = '\0';
6044 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
6045 /* If corresponding user operator is private, don't write
6046 the UDR. */
6047 if (st != NULL)
6048 {
6049 gfc_user_op *uop = st->n.uop;
6050 if (!check_access (uop->access, uop->ns->default_access))
6051 return;
6052 }
6053 }
6054 break;
6055 case OMP_REDUCTION_PLUS:
6056 case OMP_REDUCTION_MINUS:
6057 case OMP_REDUCTION_TIMES:
6058 case OMP_REDUCTION_AND:
6059 case OMP_REDUCTION_OR:
6060 case OMP_REDUCTION_EQV:
6061 case OMP_REDUCTION_NEQV:
6062 /* If corresponding operator is private, don't write the UDR. */
6063 if (!check_access (gfc_current_ns->operator_access[udr->rop],
6064 gfc_current_ns->default_access))
6065 return;
6066 break;
6067 default:
6068 break;
6069 }
6070 if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
6071 {
6072 /* If derived type is private, don't write the UDR. */
6073 if (!gfc_check_symbol_access (udr->ts.u.derived))
6074 return;
6075 }
6076
6077 mio_lparen ();
6078 mio_pool_string (&udr->name);
6079 mio_typespec (&udr->ts);
6080 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
6081 if (udr->initializer_ns)
6082 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
6083 udr->initializer_ns, true);
6084 mio_rparen ();
6085 }
6086
6087
6088 static void
write_omp_udrs(gfc_symtree * st)6089 write_omp_udrs (gfc_symtree *st)
6090 {
6091 if (st == NULL)
6092 return;
6093
6094 write_omp_udrs (st->left);
6095 gfc_omp_udr *udr;
6096 for (udr = st->n.omp_udr; udr; udr = udr->next)
6097 write_omp_udr (udr);
6098 write_omp_udrs (st->right);
6099 }
6100
6101
6102 /* Type for the temporary tree used when writing secondary symbols. */
6103
6104 struct sorted_pointer_info
6105 {
6106 BBT_HEADER (sorted_pointer_info);
6107
6108 pointer_info *p;
6109 };
6110
6111 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
6112
6113 /* Recursively traverse the temporary tree, free its contents. */
6114
6115 static void
free_sorted_pointer_info_tree(sorted_pointer_info * p)6116 free_sorted_pointer_info_tree (sorted_pointer_info *p)
6117 {
6118 if (!p)
6119 return;
6120
6121 free_sorted_pointer_info_tree (p->left);
6122 free_sorted_pointer_info_tree (p->right);
6123
6124 free (p);
6125 }
6126
6127 /* Comparison function for the temporary tree. */
6128
6129 static int
compare_sorted_pointer_info(void * _spi1,void * _spi2)6130 compare_sorted_pointer_info (void *_spi1, void *_spi2)
6131 {
6132 sorted_pointer_info *spi1, *spi2;
6133 spi1 = (sorted_pointer_info *)_spi1;
6134 spi2 = (sorted_pointer_info *)_spi2;
6135
6136 if (spi1->p->integer < spi2->p->integer)
6137 return -1;
6138 if (spi1->p->integer > spi2->p->integer)
6139 return 1;
6140 return 0;
6141 }
6142
6143
6144 /* Finds the symbols that need to be written and collects them in the
6145 sorted_pi tree so that they can be traversed in an order
6146 independent of memory addresses. */
6147
6148 static void
find_symbols_to_write(sorted_pointer_info ** tree,pointer_info * p)6149 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
6150 {
6151 if (!p)
6152 return;
6153
6154 if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
6155 {
6156 sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
6157 sp->p = p;
6158
6159 gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
6160 }
6161
6162 find_symbols_to_write (tree, p->left);
6163 find_symbols_to_write (tree, p->right);
6164 }
6165
6166
6167 /* Recursive function that traverses the tree of symbols that need to be
6168 written and writes them in order. */
6169
6170 static void
write_symbol1_recursion(sorted_pointer_info * sp)6171 write_symbol1_recursion (sorted_pointer_info *sp)
6172 {
6173 if (!sp)
6174 return;
6175
6176 write_symbol1_recursion (sp->left);
6177
6178 pointer_info *p1 = sp->p;
6179 gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
6180
6181 p1->u.wsym.state = WRITTEN;
6182 write_symbol (p1->integer, p1->u.wsym.sym);
6183 p1->u.wsym.sym->attr.public_used = 1;
6184
6185 write_symbol1_recursion (sp->right);
6186 }
6187
6188
6189 /* Write the secondary set of symbols to the module file. These are
6190 symbols that were not public yet are needed by the public symbols
6191 or another dependent symbol. The act of writing a symbol can add
6192 symbols to the pointer_info tree, so we return nonzero if a symbol
6193 was written and pass that information upwards. The caller will
6194 then call this function again until nothing was written. It uses
6195 the utility functions and a temporary tree to ensure a reproducible
6196 ordering of the symbol output and thus the module file. */
6197
6198 static int
write_symbol1(pointer_info * p)6199 write_symbol1 (pointer_info *p)
6200 {
6201 if (!p)
6202 return 0;
6203
6204 /* Put symbols that need to be written into a tree sorted on the
6205 integer field. */
6206
6207 sorted_pointer_info *spi_root = NULL;
6208 find_symbols_to_write (&spi_root, p);
6209
6210 /* No symbols to write, return. */
6211 if (!spi_root)
6212 return 0;
6213
6214 /* Otherwise, write and free the tree again. */
6215 write_symbol1_recursion (spi_root);
6216 free_sorted_pointer_info_tree (spi_root);
6217
6218 return 1;
6219 }
6220
6221
6222 /* Write operator interfaces associated with a symbol. */
6223
6224 static void
write_operator(gfc_user_op * uop)6225 write_operator (gfc_user_op *uop)
6226 {
6227 static char nullstring[] = "";
6228 const char *p = nullstring;
6229
6230 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
6231 return;
6232
6233 mio_symbol_interface (&uop->name, &p, &uop->op);
6234 }
6235
6236
6237 /* Write generic interfaces from the namespace sym_root. */
6238
6239 static void
write_generic(gfc_symtree * st)6240 write_generic (gfc_symtree *st)
6241 {
6242 gfc_symbol *sym;
6243
6244 if (st == NULL)
6245 return;
6246
6247 write_generic (st->left);
6248
6249 sym = st->n.sym;
6250 if (sym && !check_unique_name (st->name)
6251 && sym->generic && gfc_check_symbol_access (sym))
6252 {
6253 if (!sym->module)
6254 sym->module = module_name;
6255
6256 mio_symbol_interface (&st->name, &sym->module, &sym->generic);
6257 }
6258
6259 write_generic (st->right);
6260 }
6261
6262
6263 static void
write_symtree(gfc_symtree * st)6264 write_symtree (gfc_symtree *st)
6265 {
6266 gfc_symbol *sym;
6267 pointer_info *p;
6268
6269 sym = st->n.sym;
6270
6271 /* A symbol in an interface body must not be visible in the
6272 module file. */
6273 if (sym->ns != gfc_current_ns
6274 && sym->ns->proc_name
6275 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
6276 return;
6277
6278 if (!gfc_check_symbol_access (sym)
6279 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
6280 && !sym->attr.subroutine && !sym->attr.function))
6281 return;
6282
6283 if (check_unique_name (st->name))
6284 return;
6285
6286 /* From F2003 onwards, intrinsic procedures are no longer subject to
6287 the restriction, "that an elemental intrinsic function here be of
6288 type integer or character and each argument must be an initialization
6289 expr of type integer or character" is lifted so that intrinsic
6290 procedures can be over-ridden. This requires that the intrinsic
6291 symbol not appear in the module file, thereby preventing ambiguity
6292 when USEd. */
6293 if (strcmp (sym->module, "(intrinsic)") == 0
6294 && (gfc_option.allow_std & GFC_STD_F2003))
6295 return;
6296
6297 p = find_pointer (sym);
6298 if (p == NULL)
6299 gfc_internal_error ("write_symtree(): Symbol not written");
6300
6301 mio_pool_string (&st->name);
6302 mio_integer (&st->ambiguous);
6303 mio_hwi (&p->integer);
6304 }
6305
6306
6307 static void
write_module(void)6308 write_module (void)
6309 {
6310 int i;
6311
6312 /* Initialize the column counter. */
6313 module_column = 1;
6314
6315 /* Write the operator interfaces. */
6316 mio_lparen ();
6317
6318 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
6319 {
6320 if (i == INTRINSIC_USER)
6321 continue;
6322
6323 mio_interface (check_access (gfc_current_ns->operator_access[i],
6324 gfc_current_ns->default_access)
6325 ? &gfc_current_ns->op[i] : NULL);
6326 }
6327
6328 mio_rparen ();
6329 write_char ('\n');
6330 write_char ('\n');
6331
6332 mio_lparen ();
6333 gfc_traverse_user_op (gfc_current_ns, write_operator);
6334 mio_rparen ();
6335 write_char ('\n');
6336 write_char ('\n');
6337
6338 mio_lparen ();
6339 write_generic (gfc_current_ns->sym_root);
6340 mio_rparen ();
6341 write_char ('\n');
6342 write_char ('\n');
6343
6344 mio_lparen ();
6345 write_blank_common ();
6346 write_common (gfc_current_ns->common_root);
6347 mio_rparen ();
6348 write_char ('\n');
6349 write_char ('\n');
6350
6351 mio_lparen ();
6352 write_equiv ();
6353 mio_rparen ();
6354 write_char ('\n');
6355 write_char ('\n');
6356
6357 mio_lparen ();
6358 write_omp_udrs (gfc_current_ns->omp_udr_root);
6359 mio_rparen ();
6360 write_char ('\n');
6361 write_char ('\n');
6362
6363 /* Write symbol information. First we traverse all symbols in the
6364 primary namespace, writing those that need to be written.
6365 Sometimes writing one symbol will cause another to need to be
6366 written. A list of these symbols ends up on the write stack, and
6367 we end by popping the bottom of the stack and writing the symbol
6368 until the stack is empty. */
6369
6370 mio_lparen ();
6371
6372 write_symbol0 (gfc_current_ns->sym_root);
6373 while (write_symbol1 (pi_root))
6374 /* Nothing. */;
6375
6376 mio_rparen ();
6377
6378 write_char ('\n');
6379 write_char ('\n');
6380
6381 mio_lparen ();
6382 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
6383 mio_rparen ();
6384 }
6385
6386
6387 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6388 true on success, false on failure. */
6389
6390 static bool
read_crc32_from_module_file(const char * filename,uLong * crc)6391 read_crc32_from_module_file (const char* filename, uLong* crc)
6392 {
6393 FILE *file;
6394 char buf[4];
6395 unsigned int val;
6396
6397 /* Open the file in binary mode. */
6398 if ((file = fopen (filename, "rb")) == NULL)
6399 return false;
6400
6401 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6402 file. See RFC 1952. */
6403 if (fseek (file, -8, SEEK_END) != 0)
6404 {
6405 fclose (file);
6406 return false;
6407 }
6408
6409 /* Read the CRC32. */
6410 if (fread (buf, 1, 4, file) != 4)
6411 {
6412 fclose (file);
6413 return false;
6414 }
6415
6416 /* Close the file. */
6417 fclose (file);
6418
6419 val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
6420 + ((buf[3] & 0xFF) << 24);
6421 *crc = val;
6422
6423 /* For debugging, the CRC value printed in hexadecimal should match
6424 the CRC printed by "zcat -l -v filename".
6425 printf("CRC of file %s is %x\n", filename, val); */
6426
6427 return true;
6428 }
6429
6430
6431 /* Given module, dump it to disk. If there was an error while
6432 processing the module, dump_flag will be set to zero and we delete
6433 the module file, even if it was already there. */
6434
6435 static void
dump_module(const char * name,int dump_flag)6436 dump_module (const char *name, int dump_flag)
6437 {
6438 int n;
6439 char *filename, *filename_tmp;
6440 uLong crc, crc_old;
6441
6442 module_name = gfc_get_string ("%s", name);
6443
6444 if (dump_smod)
6445 {
6446 name = submodule_name;
6447 n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
6448 }
6449 else
6450 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6451
6452 if (gfc_option.module_dir != NULL)
6453 {
6454 n += strlen (gfc_option.module_dir);
6455 filename = (char *) alloca (n);
6456 strcpy (filename, gfc_option.module_dir);
6457 strcat (filename, name);
6458 }
6459 else
6460 {
6461 filename = (char *) alloca (n);
6462 strcpy (filename, name);
6463 }
6464
6465 if (dump_smod)
6466 strcat (filename, SUBMODULE_EXTENSION);
6467 else
6468 strcat (filename, MODULE_EXTENSION);
6469
6470 /* Name of the temporary file used to write the module. */
6471 filename_tmp = (char *) alloca (n + 1);
6472 strcpy (filename_tmp, filename);
6473 strcat (filename_tmp, "0");
6474
6475 /* There was an error while processing the module. We delete the
6476 module file, even if it was already there. */
6477 if (!dump_flag)
6478 {
6479 remove (filename);
6480 return;
6481 }
6482
6483 if (gfc_cpp_makedep ())
6484 gfc_cpp_add_target (filename);
6485
6486 /* Write the module to the temporary file. */
6487 module_fp = gzopen (filename_tmp, "w");
6488 if (module_fp == NULL)
6489 gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6490 filename_tmp, xstrerror (errno));
6491
6492 /* Use lbasename to ensure module files are reproducible regardless
6493 of the build path (see the reproducible builds project). */
6494 gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6495 MOD_VERSION, lbasename (gfc_source_file));
6496
6497 /* Write the module itself. */
6498 iomode = IO_OUTPUT;
6499
6500 init_pi_tree ();
6501
6502 write_module ();
6503
6504 free_pi_tree (pi_root);
6505 pi_root = NULL;
6506
6507 write_char ('\n');
6508
6509 if (gzclose (module_fp))
6510 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6511 filename_tmp, xstrerror (errno));
6512
6513 /* Read the CRC32 from the gzip trailers of the module files and
6514 compare. */
6515 if (!read_crc32_from_module_file (filename_tmp, &crc)
6516 || !read_crc32_from_module_file (filename, &crc_old)
6517 || crc_old != crc)
6518 {
6519 /* Module file have changed, replace the old one. */
6520 if (remove (filename) && errno != ENOENT)
6521 gfc_fatal_error ("Cannot delete module file %qs: %s", filename,
6522 xstrerror (errno));
6523 if (rename (filename_tmp, filename))
6524 gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6525 filename_tmp, filename, xstrerror (errno));
6526 }
6527 else
6528 {
6529 if (remove (filename_tmp))
6530 gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6531 filename_tmp, xstrerror (errno));
6532 }
6533 }
6534
6535
6536 /* Suppress the output of a .smod file by module, if no module
6537 procedures have been seen. */
6538 static bool no_module_procedures;
6539
6540 static void
check_for_module_procedures(gfc_symbol * sym)6541 check_for_module_procedures (gfc_symbol *sym)
6542 {
6543 if (sym && sym->attr.module_procedure)
6544 no_module_procedures = false;
6545 }
6546
6547
6548 void
gfc_dump_module(const char * name,int dump_flag)6549 gfc_dump_module (const char *name, int dump_flag)
6550 {
6551 if (gfc_state_stack->state == COMP_SUBMODULE)
6552 dump_smod = true;
6553 else
6554 dump_smod =false;
6555
6556 no_module_procedures = true;
6557 gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
6558
6559 dump_module (name, dump_flag);
6560
6561 if (no_module_procedures || dump_smod)
6562 return;
6563
6564 /* Write a submodule file from a module. The 'dump_smod' flag switches
6565 off the check for PRIVATE entities. */
6566 dump_smod = true;
6567 submodule_name = module_name;
6568 dump_module (name, dump_flag);
6569 dump_smod = false;
6570 }
6571
6572 static void
create_intrinsic_function(const char * name,int id,const char * modname,intmod_id module,bool subroutine,gfc_symbol * result_type)6573 create_intrinsic_function (const char *name, int id,
6574 const char *modname, intmod_id module,
6575 bool subroutine, gfc_symbol *result_type)
6576 {
6577 gfc_intrinsic_sym *isym;
6578 gfc_symtree *tmp_symtree;
6579 gfc_symbol *sym;
6580
6581 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6582 if (tmp_symtree)
6583 {
6584 if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
6585 && strcmp (modname, tmp_symtree->n.sym->module) == 0)
6586 return;
6587 gfc_error ("Symbol %qs at %C already declared", name);
6588 return;
6589 }
6590
6591 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6592 sym = tmp_symtree->n.sym;
6593
6594 if (subroutine)
6595 {
6596 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6597 isym = gfc_intrinsic_subroutine_by_id (isym_id);
6598 sym->attr.subroutine = 1;
6599 }
6600 else
6601 {
6602 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6603 isym = gfc_intrinsic_function_by_id (isym_id);
6604
6605 sym->attr.function = 1;
6606 if (result_type)
6607 {
6608 sym->ts.type = BT_DERIVED;
6609 sym->ts.u.derived = result_type;
6610 sym->ts.is_c_interop = 1;
6611 isym->ts.f90_type = BT_VOID;
6612 isym->ts.type = BT_DERIVED;
6613 isym->ts.f90_type = BT_VOID;
6614 isym->ts.u.derived = result_type;
6615 isym->ts.is_c_interop = 1;
6616 }
6617 }
6618 gcc_assert (isym);
6619
6620 sym->attr.flavor = FL_PROCEDURE;
6621 sym->attr.intrinsic = 1;
6622
6623 sym->module = gfc_get_string ("%s", modname);
6624 sym->attr.use_assoc = 1;
6625 sym->from_intmod = module;
6626 sym->intmod_sym_id = id;
6627 }
6628
6629
6630 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6631 the current namespace for all named constants, pointer types, and
6632 procedures in the module unless the only clause was used or a rename
6633 list was provided. */
6634
6635 static void
import_iso_c_binding_module(void)6636 import_iso_c_binding_module (void)
6637 {
6638 gfc_symbol *mod_sym = NULL, *return_type;
6639 gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6640 gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6641 const char *iso_c_module_name = "__iso_c_binding";
6642 gfc_use_rename *u;
6643 int i;
6644 bool want_c_ptr = false, want_c_funptr = false;
6645
6646 /* Look only in the current namespace. */
6647 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6648
6649 if (mod_symtree == NULL)
6650 {
6651 /* symtree doesn't already exist in current namespace. */
6652 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6653 false);
6654
6655 if (mod_symtree != NULL)
6656 mod_sym = mod_symtree->n.sym;
6657 else
6658 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6659 "create symbol for %s", iso_c_module_name);
6660
6661 mod_sym->attr.flavor = FL_MODULE;
6662 mod_sym->attr.intrinsic = 1;
6663 mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
6664 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6665 }
6666
6667 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6668 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6669 need C_(FUN)PTR. */
6670 for (u = gfc_rename_list; u; u = u->next)
6671 {
6672 if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6673 u->use_name) == 0)
6674 want_c_ptr = true;
6675 else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6676 u->use_name) == 0)
6677 want_c_ptr = true;
6678 else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6679 u->use_name) == 0)
6680 want_c_funptr = true;
6681 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6682 u->use_name) == 0)
6683 want_c_funptr = true;
6684 else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6685 u->use_name) == 0)
6686 {
6687 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6688 (iso_c_binding_symbol)
6689 ISOCBINDING_PTR,
6690 u->local_name[0] ? u->local_name
6691 : u->use_name,
6692 NULL, false);
6693 }
6694 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6695 u->use_name) == 0)
6696 {
6697 c_funptr
6698 = generate_isocbinding_symbol (iso_c_module_name,
6699 (iso_c_binding_symbol)
6700 ISOCBINDING_FUNPTR,
6701 u->local_name[0] ? u->local_name
6702 : u->use_name,
6703 NULL, false);
6704 }
6705 }
6706
6707 if ((want_c_ptr || !only_flag) && !c_ptr)
6708 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6709 (iso_c_binding_symbol)
6710 ISOCBINDING_PTR,
6711 NULL, NULL, only_flag);
6712 if ((want_c_funptr || !only_flag) && !c_funptr)
6713 c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6714 (iso_c_binding_symbol)
6715 ISOCBINDING_FUNPTR,
6716 NULL, NULL, only_flag);
6717
6718 /* Generate the symbols for the named constants representing
6719 the kinds for intrinsic data types. */
6720 for (i = 0; i < ISOCBINDING_NUMBER; i++)
6721 {
6722 bool found = false;
6723 for (u = gfc_rename_list; u; u = u->next)
6724 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6725 {
6726 bool not_in_std;
6727 const char *name;
6728 u->found = 1;
6729 found = true;
6730
6731 switch (i)
6732 {
6733 #define NAMED_FUNCTION(a,b,c,d) \
6734 case a: \
6735 not_in_std = (gfc_option.allow_std & d) == 0; \
6736 name = b; \
6737 break;
6738 #define NAMED_SUBROUTINE(a,b,c,d) \
6739 case a: \
6740 not_in_std = (gfc_option.allow_std & d) == 0; \
6741 name = b; \
6742 break;
6743 #define NAMED_INTCST(a,b,c,d) \
6744 case a: \
6745 not_in_std = (gfc_option.allow_std & d) == 0; \
6746 name = b; \
6747 break;
6748 #define NAMED_REALCST(a,b,c,d) \
6749 case a: \
6750 not_in_std = (gfc_option.allow_std & d) == 0; \
6751 name = b; \
6752 break;
6753 #define NAMED_CMPXCST(a,b,c,d) \
6754 case a: \
6755 not_in_std = (gfc_option.allow_std & d) == 0; \
6756 name = b; \
6757 break;
6758 #include "iso-c-binding.def"
6759 default:
6760 not_in_std = false;
6761 name = "";
6762 }
6763
6764 if (not_in_std)
6765 {
6766 gfc_error ("The symbol %qs, referenced at %L, is not "
6767 "in the selected standard", name, &u->where);
6768 continue;
6769 }
6770
6771 switch (i)
6772 {
6773 #define NAMED_FUNCTION(a,b,c,d) \
6774 case a: \
6775 if (a == ISOCBINDING_LOC) \
6776 return_type = c_ptr->n.sym; \
6777 else if (a == ISOCBINDING_FUNLOC) \
6778 return_type = c_funptr->n.sym; \
6779 else \
6780 return_type = NULL; \
6781 create_intrinsic_function (u->local_name[0] \
6782 ? u->local_name : u->use_name, \
6783 a, iso_c_module_name, \
6784 INTMOD_ISO_C_BINDING, false, \
6785 return_type); \
6786 break;
6787 #define NAMED_SUBROUTINE(a,b,c,d) \
6788 case a: \
6789 create_intrinsic_function (u->local_name[0] ? u->local_name \
6790 : u->use_name, \
6791 a, iso_c_module_name, \
6792 INTMOD_ISO_C_BINDING, true, NULL); \
6793 break;
6794 #include "iso-c-binding.def"
6795
6796 case ISOCBINDING_PTR:
6797 case ISOCBINDING_FUNPTR:
6798 /* Already handled above. */
6799 break;
6800 default:
6801 if (i == ISOCBINDING_NULL_PTR)
6802 tmp_symtree = c_ptr;
6803 else if (i == ISOCBINDING_NULL_FUNPTR)
6804 tmp_symtree = c_funptr;
6805 else
6806 tmp_symtree = NULL;
6807 generate_isocbinding_symbol (iso_c_module_name,
6808 (iso_c_binding_symbol) i,
6809 u->local_name[0]
6810 ? u->local_name : u->use_name,
6811 tmp_symtree, false);
6812 }
6813 }
6814
6815 if (!found && !only_flag)
6816 {
6817 /* Skip, if the symbol is not in the enabled standard. */
6818 switch (i)
6819 {
6820 #define NAMED_FUNCTION(a,b,c,d) \
6821 case a: \
6822 if ((gfc_option.allow_std & d) == 0) \
6823 continue; \
6824 break;
6825 #define NAMED_SUBROUTINE(a,b,c,d) \
6826 case a: \
6827 if ((gfc_option.allow_std & d) == 0) \
6828 continue; \
6829 break;
6830 #define NAMED_INTCST(a,b,c,d) \
6831 case a: \
6832 if ((gfc_option.allow_std & d) == 0) \
6833 continue; \
6834 break;
6835 #define NAMED_REALCST(a,b,c,d) \
6836 case a: \
6837 if ((gfc_option.allow_std & d) == 0) \
6838 continue; \
6839 break;
6840 #define NAMED_CMPXCST(a,b,c,d) \
6841 case a: \
6842 if ((gfc_option.allow_std & d) == 0) \
6843 continue; \
6844 break;
6845 #include "iso-c-binding.def"
6846 default:
6847 ; /* Not GFC_STD_* versioned. */
6848 }
6849
6850 switch (i)
6851 {
6852 #define NAMED_FUNCTION(a,b,c,d) \
6853 case a: \
6854 if (a == ISOCBINDING_LOC) \
6855 return_type = c_ptr->n.sym; \
6856 else if (a == ISOCBINDING_FUNLOC) \
6857 return_type = c_funptr->n.sym; \
6858 else \
6859 return_type = NULL; \
6860 create_intrinsic_function (b, a, iso_c_module_name, \
6861 INTMOD_ISO_C_BINDING, false, \
6862 return_type); \
6863 break;
6864 #define NAMED_SUBROUTINE(a,b,c,d) \
6865 case a: \
6866 create_intrinsic_function (b, a, iso_c_module_name, \
6867 INTMOD_ISO_C_BINDING, true, NULL); \
6868 break;
6869 #include "iso-c-binding.def"
6870
6871 case ISOCBINDING_PTR:
6872 case ISOCBINDING_FUNPTR:
6873 /* Already handled above. */
6874 break;
6875 default:
6876 if (i == ISOCBINDING_NULL_PTR)
6877 tmp_symtree = c_ptr;
6878 else if (i == ISOCBINDING_NULL_FUNPTR)
6879 tmp_symtree = c_funptr;
6880 else
6881 tmp_symtree = NULL;
6882 generate_isocbinding_symbol (iso_c_module_name,
6883 (iso_c_binding_symbol) i, NULL,
6884 tmp_symtree, false);
6885 }
6886 }
6887 }
6888
6889 for (u = gfc_rename_list; u; u = u->next)
6890 {
6891 if (u->found)
6892 continue;
6893
6894 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6895 "module ISO_C_BINDING", u->use_name, &u->where);
6896 }
6897 }
6898
6899
6900 /* Add an integer named constant from a given module. */
6901
6902 static void
create_int_parameter(const char * name,int value,const char * modname,intmod_id module,int id)6903 create_int_parameter (const char *name, int value, const char *modname,
6904 intmod_id module, int id)
6905 {
6906 gfc_symtree *tmp_symtree;
6907 gfc_symbol *sym;
6908
6909 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6910 if (tmp_symtree != NULL)
6911 {
6912 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6913 return;
6914 else
6915 gfc_error ("Symbol %qs already declared", name);
6916 }
6917
6918 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6919 sym = tmp_symtree->n.sym;
6920
6921 sym->module = gfc_get_string ("%s", modname);
6922 sym->attr.flavor = FL_PARAMETER;
6923 sym->ts.type = BT_INTEGER;
6924 sym->ts.kind = gfc_default_integer_kind;
6925 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6926 sym->attr.use_assoc = 1;
6927 sym->from_intmod = module;
6928 sym->intmod_sym_id = id;
6929 }
6930
6931
6932 /* Value is already contained by the array constructor, but not
6933 yet the shape. */
6934
6935 static void
create_int_parameter_array(const char * name,int size,gfc_expr * value,const char * modname,intmod_id module,int id)6936 create_int_parameter_array (const char *name, int size, gfc_expr *value,
6937 const char *modname, intmod_id module, int id)
6938 {
6939 gfc_symtree *tmp_symtree;
6940 gfc_symbol *sym;
6941
6942 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6943 if (tmp_symtree != NULL)
6944 {
6945 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6946 return;
6947 else
6948 gfc_error ("Symbol %qs already declared", name);
6949 }
6950
6951 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6952 sym = tmp_symtree->n.sym;
6953
6954 sym->module = gfc_get_string ("%s", modname);
6955 sym->attr.flavor = FL_PARAMETER;
6956 sym->ts.type = BT_INTEGER;
6957 sym->ts.kind = gfc_default_integer_kind;
6958 sym->attr.use_assoc = 1;
6959 sym->from_intmod = module;
6960 sym->intmod_sym_id = id;
6961 sym->attr.dimension = 1;
6962 sym->as = gfc_get_array_spec ();
6963 sym->as->rank = 1;
6964 sym->as->type = AS_EXPLICIT;
6965 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6966 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6967
6968 sym->value = value;
6969 sym->value->shape = gfc_get_shape (1);
6970 mpz_init_set_ui (sym->value->shape[0], size);
6971 }
6972
6973
6974 /* Add an derived type for a given module. */
6975
6976 static void
create_derived_type(const char * name,const char * modname,intmod_id module,int id)6977 create_derived_type (const char *name, const char *modname,
6978 intmod_id module, int id)
6979 {
6980 gfc_symtree *tmp_symtree;
6981 gfc_symbol *sym, *dt_sym;
6982 gfc_interface *intr, *head;
6983
6984 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6985 if (tmp_symtree != NULL)
6986 {
6987 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6988 return;
6989 else
6990 gfc_error ("Symbol %qs already declared", name);
6991 }
6992
6993 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6994 sym = tmp_symtree->n.sym;
6995 sym->module = gfc_get_string ("%s", modname);
6996 sym->from_intmod = module;
6997 sym->intmod_sym_id = id;
6998 sym->attr.flavor = FL_PROCEDURE;
6999 sym->attr.function = 1;
7000 sym->attr.generic = 1;
7001
7002 gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
7003 gfc_current_ns, &tmp_symtree, false);
7004 dt_sym = tmp_symtree->n.sym;
7005 dt_sym->name = gfc_get_string ("%s", sym->name);
7006 dt_sym->attr.flavor = FL_DERIVED;
7007 dt_sym->attr.private_comp = 1;
7008 dt_sym->attr.zero_comp = 1;
7009 dt_sym->attr.use_assoc = 1;
7010 dt_sym->module = gfc_get_string ("%s", modname);
7011 dt_sym->from_intmod = module;
7012 dt_sym->intmod_sym_id = id;
7013
7014 head = sym->generic;
7015 intr = gfc_get_interface ();
7016 intr->sym = dt_sym;
7017 intr->where = gfc_current_locus;
7018 intr->next = head;
7019 sym->generic = intr;
7020 sym->attr.if_source = IFSRC_DECL;
7021 }
7022
7023
7024 /* Read the contents of the module file into a temporary buffer. */
7025
7026 static void
read_module_to_tmpbuf()7027 read_module_to_tmpbuf ()
7028 {
7029 /* We don't know the uncompressed size, so enlarge the buffer as
7030 needed. */
7031 int cursz = 4096;
7032 int rsize = cursz;
7033 int len = 0;
7034
7035 module_content = XNEWVEC (char, cursz);
7036
7037 while (1)
7038 {
7039 int nread = gzread (module_fp, module_content + len, rsize);
7040 len += nread;
7041 if (nread < rsize)
7042 break;
7043 cursz *= 2;
7044 module_content = XRESIZEVEC (char, module_content, cursz);
7045 rsize = cursz - len;
7046 }
7047
7048 module_content = XRESIZEVEC (char, module_content, len + 1);
7049 module_content[len] = '\0';
7050
7051 module_pos = 0;
7052 }
7053
7054
7055 /* USE the ISO_FORTRAN_ENV intrinsic module. */
7056
7057 static void
use_iso_fortran_env_module(void)7058 use_iso_fortran_env_module (void)
7059 {
7060 static char mod[] = "iso_fortran_env";
7061 gfc_use_rename *u;
7062 gfc_symbol *mod_sym;
7063 gfc_symtree *mod_symtree;
7064 gfc_expr *expr;
7065 int i, j;
7066
7067 intmod_sym symbol[] = {
7068 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
7069 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
7070 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
7071 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
7072 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
7073 #include "iso-fortran-env.def"
7074 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
7075
7076 i = 0;
7077 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
7078 #include "iso-fortran-env.def"
7079
7080 /* Generate the symbol for the module itself. */
7081 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
7082 if (mod_symtree == NULL)
7083 {
7084 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
7085 gcc_assert (mod_symtree);
7086 mod_sym = mod_symtree->n.sym;
7087
7088 mod_sym->attr.flavor = FL_MODULE;
7089 mod_sym->attr.intrinsic = 1;
7090 mod_sym->module = gfc_get_string ("%s", mod);
7091 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
7092 }
7093 else
7094 if (!mod_symtree->n.sym->attr.intrinsic)
7095 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
7096 "non-intrinsic module name used previously", mod);
7097
7098 /* Generate the symbols for the module integer named constants. */
7099
7100 for (i = 0; symbol[i].name; i++)
7101 {
7102 bool found = false;
7103 for (u = gfc_rename_list; u; u = u->next)
7104 {
7105 if (strcmp (symbol[i].name, u->use_name) == 0)
7106 {
7107 found = true;
7108 u->found = 1;
7109
7110 if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
7111 "referenced at %L, is not in the selected "
7112 "standard", symbol[i].name, &u->where))
7113 continue;
7114
7115 if ((flag_default_integer || flag_default_real_8)
7116 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
7117 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
7118 "constant from intrinsic module "
7119 "ISO_FORTRAN_ENV at %L is incompatible with "
7120 "option %qs", &u->where,
7121 flag_default_integer
7122 ? "-fdefault-integer-8"
7123 : "-fdefault-real-8");
7124 switch (symbol[i].id)
7125 {
7126 #define NAMED_INTCST(a,b,c,d) \
7127 case a:
7128 #include "iso-fortran-env.def"
7129 create_int_parameter (u->local_name[0] ? u->local_name
7130 : u->use_name,
7131 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, \
7138 gfc_default_integer_kind,\
7139 NULL); \
7140 for (j = 0; KINDS[j].kind != 0; j++) \
7141 gfc_constructor_append_expr (&expr->value.constructor, \
7142 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7143 KINDS[j].kind), NULL); \
7144 create_int_parameter_array (u->local_name[0] ? u->local_name \
7145 : u->use_name, \
7146 j, expr, mod, \
7147 INTMOD_ISO_FORTRAN_ENV, \
7148 symbol[i].id); \
7149 break;
7150 #include "iso-fortran-env.def"
7151
7152 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7153 case a:
7154 #include "iso-fortran-env.def"
7155 create_derived_type (u->local_name[0] ? u->local_name
7156 : u->use_name,
7157 mod, INTMOD_ISO_FORTRAN_ENV,
7158 symbol[i].id);
7159 break;
7160
7161 #define NAMED_FUNCTION(a,b,c,d) \
7162 case a:
7163 #include "iso-fortran-env.def"
7164 create_intrinsic_function (u->local_name[0] ? u->local_name
7165 : u->use_name,
7166 symbol[i].id, mod,
7167 INTMOD_ISO_FORTRAN_ENV, false,
7168 NULL);
7169 break;
7170
7171 default:
7172 gcc_unreachable ();
7173 }
7174 }
7175 }
7176
7177 if (!found && !only_flag)
7178 {
7179 if ((gfc_option.allow_std & symbol[i].standard) == 0)
7180 continue;
7181
7182 if ((flag_default_integer || flag_default_real_8)
7183 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
7184 gfc_warning_now (0,
7185 "Use of the NUMERIC_STORAGE_SIZE named constant "
7186 "from intrinsic module ISO_FORTRAN_ENV at %C is "
7187 "incompatible with option %s",
7188 flag_default_integer
7189 ? "-fdefault-integer-8" : "-fdefault-real-8");
7190
7191 switch (symbol[i].id)
7192 {
7193 #define NAMED_INTCST(a,b,c,d) \
7194 case a:
7195 #include "iso-fortran-env.def"
7196 create_int_parameter (symbol[i].name, symbol[i].value, mod,
7197 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
7198 break;
7199
7200 #define NAMED_KINDARRAY(a,b,KINDS,d) \
7201 case a:\
7202 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
7203 NULL); \
7204 for (j = 0; KINDS[j].kind != 0; j++) \
7205 gfc_constructor_append_expr (&expr->value.constructor, \
7206 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7207 KINDS[j].kind), NULL); \
7208 create_int_parameter_array (symbol[i].name, j, expr, mod, \
7209 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7210 break;
7211 #include "iso-fortran-env.def"
7212
7213 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7214 case a:
7215 #include "iso-fortran-env.def"
7216 create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
7217 symbol[i].id);
7218 break;
7219
7220 #define NAMED_FUNCTION(a,b,c,d) \
7221 case a:
7222 #include "iso-fortran-env.def"
7223 create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
7224 INTMOD_ISO_FORTRAN_ENV, false,
7225 NULL);
7226 break;
7227
7228 default:
7229 gcc_unreachable ();
7230 }
7231 }
7232 }
7233
7234 for (u = gfc_rename_list; u; u = u->next)
7235 {
7236 if (u->found)
7237 continue;
7238
7239 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7240 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
7241 }
7242 }
7243
7244
7245 /* Process a USE directive. */
7246
7247 static void
gfc_use_module(gfc_use_list * module)7248 gfc_use_module (gfc_use_list *module)
7249 {
7250 char *filename;
7251 gfc_state_data *p;
7252 int c, line, start;
7253 gfc_symtree *mod_symtree;
7254 gfc_use_list *use_stmt;
7255 locus old_locus = gfc_current_locus;
7256
7257 gfc_current_locus = module->where;
7258 module_name = module->module_name;
7259 gfc_rename_list = module->rename;
7260 only_flag = module->only_flag;
7261 current_intmod = INTMOD_NONE;
7262
7263 if (!only_flag)
7264 gfc_warning_now (OPT_Wuse_without_only,
7265 "USE statement at %C has no ONLY qualifier");
7266
7267 if (gfc_state_stack->state == COMP_MODULE
7268 || module->submodule_name == NULL)
7269 {
7270 filename = XALLOCAVEC (char, strlen (module_name)
7271 + strlen (MODULE_EXTENSION) + 1);
7272 strcpy (filename, module_name);
7273 strcat (filename, MODULE_EXTENSION);
7274 }
7275 else
7276 {
7277 filename = XALLOCAVEC (char, strlen (module->submodule_name)
7278 + strlen (SUBMODULE_EXTENSION) + 1);
7279 strcpy (filename, module->submodule_name);
7280 strcat (filename, SUBMODULE_EXTENSION);
7281 }
7282
7283 /* First, try to find an non-intrinsic module, unless the USE statement
7284 specified that the module is intrinsic. */
7285 module_fp = NULL;
7286 if (!module->intrinsic)
7287 module_fp = gzopen_included_file (filename, true, true);
7288
7289 /* Then, see if it's an intrinsic one, unless the USE statement
7290 specified that the module is non-intrinsic. */
7291 if (module_fp == NULL && !module->non_intrinsic)
7292 {
7293 if (strcmp (module_name, "iso_fortran_env") == 0
7294 && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
7295 "intrinsic module at %C"))
7296 {
7297 use_iso_fortran_env_module ();
7298 free_rename (module->rename);
7299 module->rename = NULL;
7300 gfc_current_locus = old_locus;
7301 module->intrinsic = true;
7302 return;
7303 }
7304
7305 if (strcmp (module_name, "iso_c_binding") == 0
7306 && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
7307 {
7308 import_iso_c_binding_module();
7309 free_rename (module->rename);
7310 module->rename = NULL;
7311 gfc_current_locus = old_locus;
7312 module->intrinsic = true;
7313 return;
7314 }
7315
7316 module_fp = gzopen_intrinsic_module (filename);
7317
7318 if (module_fp == NULL && module->intrinsic)
7319 gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7320 module_name);
7321
7322 /* Check for the IEEE modules, so we can mark their symbols
7323 accordingly when we read them. */
7324 if (strcmp (module_name, "ieee_features") == 0
7325 && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
7326 {
7327 current_intmod = INTMOD_IEEE_FEATURES;
7328 }
7329 else if (strcmp (module_name, "ieee_exceptions") == 0
7330 && gfc_notify_std (GFC_STD_F2003,
7331 "IEEE_EXCEPTIONS module at %C"))
7332 {
7333 current_intmod = INTMOD_IEEE_EXCEPTIONS;
7334 }
7335 else if (strcmp (module_name, "ieee_arithmetic") == 0
7336 && gfc_notify_std (GFC_STD_F2003,
7337 "IEEE_ARITHMETIC module at %C"))
7338 {
7339 current_intmod = INTMOD_IEEE_ARITHMETIC;
7340 }
7341 }
7342
7343 if (module_fp == NULL)
7344 {
7345 if (gfc_state_stack->state != COMP_SUBMODULE
7346 && module->submodule_name == NULL)
7347 gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7348 filename, xstrerror (errno));
7349 else
7350 gfc_fatal_error ("Module file %qs has not been generated, either "
7351 "because the module does not contain a MODULE "
7352 "PROCEDURE or there is an error in the module.",
7353 filename);
7354 }
7355
7356 /* Check that we haven't already USEd an intrinsic module with the
7357 same name. */
7358
7359 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
7360 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
7361 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7362 "intrinsic module name used previously", module_name);
7363
7364 iomode = IO_INPUT;
7365 module_line = 1;
7366 module_column = 1;
7367 start = 0;
7368
7369 read_module_to_tmpbuf ();
7370 gzclose (module_fp);
7371
7372 /* Skip the first line of the module, after checking that this is
7373 a gfortran module file. */
7374 line = 0;
7375 while (line < 1)
7376 {
7377 c = module_char ();
7378 if (c == EOF)
7379 bad_module ("Unexpected end of module");
7380 if (start++ < 3)
7381 parse_name (c);
7382 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
7383 || (start == 2 && strcmp (atom_name, " module") != 0))
7384 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7385 " module file", module_fullpath);
7386 if (start == 3)
7387 {
7388 if (strcmp (atom_name, " version") != 0
7389 || module_char () != ' '
7390 || parse_atom () != ATOM_STRING
7391 || strcmp (atom_string, MOD_VERSION))
7392 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7393 " because it was created by a different"
7394 " version of GNU Fortran", module_fullpath);
7395
7396 free (atom_string);
7397 }
7398
7399 if (c == '\n')
7400 line++;
7401 }
7402
7403 /* Make sure we're not reading the same module that we may be building. */
7404 for (p = gfc_state_stack; p; p = p->previous)
7405 if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
7406 && strcmp (p->sym->name, module_name) == 0)
7407 {
7408 if (p->state == COMP_SUBMODULE)
7409 gfc_fatal_error ("Cannot USE a submodule that is currently built");
7410 else
7411 gfc_fatal_error ("Cannot USE a module that is currently built");
7412 }
7413
7414 init_pi_tree ();
7415 init_true_name_tree ();
7416
7417 read_module ();
7418
7419 free_true_name (true_name_root);
7420 true_name_root = NULL;
7421
7422 free_pi_tree (pi_root);
7423 pi_root = NULL;
7424
7425 XDELETEVEC (module_content);
7426 module_content = NULL;
7427
7428 use_stmt = gfc_get_use_list ();
7429 *use_stmt = *module;
7430 use_stmt->next = gfc_current_ns->use_stmts;
7431 gfc_current_ns->use_stmts = use_stmt;
7432
7433 gfc_current_locus = old_locus;
7434 }
7435
7436
7437 /* Remove duplicated intrinsic operators from the rename list. */
7438
7439 static void
rename_list_remove_duplicate(gfc_use_rename * list)7440 rename_list_remove_duplicate (gfc_use_rename *list)
7441 {
7442 gfc_use_rename *seek, *last;
7443
7444 for (; list; list = list->next)
7445 if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
7446 {
7447 last = list;
7448 for (seek = list->next; seek; seek = last->next)
7449 {
7450 if (list->op == seek->op)
7451 {
7452 last->next = seek->next;
7453 free (seek);
7454 }
7455 else
7456 last = seek;
7457 }
7458 }
7459 }
7460
7461
7462 /* Process all USE directives. */
7463
7464 void
gfc_use_modules(void)7465 gfc_use_modules (void)
7466 {
7467 gfc_use_list *next, *seek, *last;
7468
7469 for (next = module_list; next; next = next->next)
7470 {
7471 bool non_intrinsic = next->non_intrinsic;
7472 bool intrinsic = next->intrinsic;
7473 bool neither = !non_intrinsic && !intrinsic;
7474
7475 for (seek = next->next; seek; seek = seek->next)
7476 {
7477 if (next->module_name != seek->module_name)
7478 continue;
7479
7480 if (seek->non_intrinsic)
7481 non_intrinsic = true;
7482 else if (seek->intrinsic)
7483 intrinsic = true;
7484 else
7485 neither = true;
7486 }
7487
7488 if (intrinsic && neither && !non_intrinsic)
7489 {
7490 char *filename;
7491 FILE *fp;
7492
7493 filename = XALLOCAVEC (char,
7494 strlen (next->module_name)
7495 + strlen (MODULE_EXTENSION) + 1);
7496 strcpy (filename, next->module_name);
7497 strcat (filename, MODULE_EXTENSION);
7498 fp = gfc_open_included_file (filename, true, true);
7499 if (fp != NULL)
7500 {
7501 non_intrinsic = true;
7502 fclose (fp);
7503 }
7504 }
7505
7506 last = next;
7507 for (seek = next->next; seek; seek = last->next)
7508 {
7509 if (next->module_name != seek->module_name)
7510 {
7511 last = seek;
7512 continue;
7513 }
7514
7515 if ((!next->intrinsic && !seek->intrinsic)
7516 || (next->intrinsic && seek->intrinsic)
7517 || !non_intrinsic)
7518 {
7519 if (!seek->only_flag)
7520 next->only_flag = false;
7521 if (seek->rename)
7522 {
7523 gfc_use_rename *r = seek->rename;
7524 while (r->next)
7525 r = r->next;
7526 r->next = next->rename;
7527 next->rename = seek->rename;
7528 }
7529 last->next = seek->next;
7530 free (seek);
7531 }
7532 else
7533 last = seek;
7534 }
7535 }
7536
7537 for (; module_list; module_list = next)
7538 {
7539 next = module_list->next;
7540 rename_list_remove_duplicate (module_list->rename);
7541 gfc_use_module (module_list);
7542 free (module_list);
7543 }
7544 gfc_rename_list = NULL;
7545 }
7546
7547
7548 void
gfc_free_use_stmts(gfc_use_list * use_stmts)7549 gfc_free_use_stmts (gfc_use_list *use_stmts)
7550 {
7551 gfc_use_list *next;
7552 for (; use_stmts; use_stmts = next)
7553 {
7554 gfc_use_rename *next_rename;
7555
7556 for (; use_stmts->rename; use_stmts->rename = next_rename)
7557 {
7558 next_rename = use_stmts->rename->next;
7559 free (use_stmts->rename);
7560 }
7561 next = use_stmts->next;
7562 free (use_stmts);
7563 }
7564 }
7565
7566
7567 void
gfc_module_init_2(void)7568 gfc_module_init_2 (void)
7569 {
7570 last_atom = ATOM_LPAREN;
7571 gfc_rename_list = NULL;
7572 module_list = NULL;
7573 }
7574
7575
7576 void
gfc_module_done_2(void)7577 gfc_module_done_2 (void)
7578 {
7579 free_rename (gfc_rename_list);
7580 gfc_rename_list = NULL;
7581 }
7582