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