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