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