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