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