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