?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* de.po: Update.
[official-gcc.git] / gcc / fortran / trans-decl.c
blob41b36a5949525b2b5503dec36964fe8428b90aee
1 /* Backend function setup
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 /* trans-decl.c -- Handling of backend function and variable decls, etc */
22
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "target.h"
27 #include "function.h"
28 #include "tree.h"
29 #include "gfortran.h"
30 #include "gimple-expr.h" /* For create_tmp_var_raw. */
31 #include "trans.h"
32 #include "stringpool.h"
33 #include "cgraph.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
36 #include "varasm.h"
37 #include "attribs.h"
38 #include "tree-dump.h"
39 #include "toplev.h" /* For announce_function. */
40 #include "debug.h"
41 #include "constructor.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
47 #include "gomp-constants.h"
48 #include "gimplify.h"
49
50 #define MAX_LABEL_VALUE 99999
51
52
53 /* Holds the result of the function if no result variable specified. */
54
55 static GTY(()) tree current_fake_result_decl;
56 static GTY(()) tree parent_fake_result_decl;
57
58
59 /* Holds the variable DECLs for the current function. */
60
61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls;
63
64 static hash_set<tree> *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
66
67 /* Holds the variable DECLs that are locals. */
68
69 static GTY(()) tree saved_local_decls;
70
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
73
74 static gfc_namespace *module_namespace;
75
76 /* The currently processed procedure symbol. */
77 static gfc_symbol* current_procedure_symbol = NULL;
78
79 /* The currently processed module. */
80 static struct module_htab_entry *cur_module;
81
82 /* With -fcoarray=lib: For generating the registering call
83 of static coarrays. */
84 static bool has_coarray_vars;
85 static stmtblock_t caf_init_block;
86
87
88 /* List of static constructor functions. */
89
90 tree gfc_static_ctors;
91
92
93 /* Whether we've seen a symbol from an IEEE module in the namespace. */
94 static int seen_ieee_symbol;
95
96 /* Function declarations for builtin library functions. */
97
98 tree gfor_fndecl_pause_numeric;
99 tree gfor_fndecl_pause_string;
100 tree gfor_fndecl_stop_numeric;
101 tree gfor_fndecl_stop_string;
102 tree gfor_fndecl_error_stop_numeric;
103 tree gfor_fndecl_error_stop_string;
104 tree gfor_fndecl_runtime_error;
105 tree gfor_fndecl_runtime_error_at;
106 tree gfor_fndecl_runtime_warning_at;
107 tree gfor_fndecl_os_error;
108 tree gfor_fndecl_generate_error;
109 tree gfor_fndecl_set_args;
110 tree gfor_fndecl_set_fpe;
111 tree gfor_fndecl_set_options;
112 tree gfor_fndecl_set_convert;
113 tree gfor_fndecl_set_record_marker;
114 tree gfor_fndecl_set_max_subrecord_length;
115 tree gfor_fndecl_ctime;
116 tree gfor_fndecl_fdate;
117 tree gfor_fndecl_ttynam;
118 tree gfor_fndecl_in_pack;
119 tree gfor_fndecl_in_unpack;
120 tree gfor_fndecl_associated;
121 tree gfor_fndecl_system_clock4;
122 tree gfor_fndecl_system_clock8;
123 tree gfor_fndecl_ieee_procedure_entry;
124 tree gfor_fndecl_ieee_procedure_exit;
125
126
127 /* Coarray run-time library function decls. */
128 tree gfor_fndecl_caf_init;
129 tree gfor_fndecl_caf_finalize;
130 tree gfor_fndecl_caf_this_image;
131 tree gfor_fndecl_caf_num_images;
132 tree gfor_fndecl_caf_register;
133 tree gfor_fndecl_caf_deregister;
134 tree gfor_fndecl_caf_get;
135 tree gfor_fndecl_caf_send;
136 tree gfor_fndecl_caf_sendget;
137 tree gfor_fndecl_caf_get_by_ref;
138 tree gfor_fndecl_caf_send_by_ref;
139 tree gfor_fndecl_caf_sendget_by_ref;
140 tree gfor_fndecl_caf_sync_all;
141 tree gfor_fndecl_caf_sync_memory;
142 tree gfor_fndecl_caf_sync_images;
143 tree gfor_fndecl_caf_stop_str;
144 tree gfor_fndecl_caf_stop_numeric;
145 tree gfor_fndecl_caf_error_stop;
146 tree gfor_fndecl_caf_error_stop_str;
147 tree gfor_fndecl_caf_atomic_def;
148 tree gfor_fndecl_caf_atomic_ref;
149 tree gfor_fndecl_caf_atomic_cas;
150 tree gfor_fndecl_caf_atomic_op;
151 tree gfor_fndecl_caf_lock;
152 tree gfor_fndecl_caf_unlock;
153 tree gfor_fndecl_caf_event_post;
154 tree gfor_fndecl_caf_event_wait;
155 tree gfor_fndecl_caf_event_query;
156 tree gfor_fndecl_co_broadcast;
157 tree gfor_fndecl_co_max;
158 tree gfor_fndecl_co_min;
159 tree gfor_fndecl_co_reduce;
160 tree gfor_fndecl_co_sum;
161 tree gfor_fndecl_caf_is_present;
162
163
164 /* Math functions. Many other math functions are handled in
165 trans-intrinsic.c. */
166
167 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
168 tree gfor_fndecl_math_ishftc4;
169 tree gfor_fndecl_math_ishftc8;
170 tree gfor_fndecl_math_ishftc16;
171
172
173 /* String functions. */
174
175 tree gfor_fndecl_compare_string;
176 tree gfor_fndecl_concat_string;
177 tree gfor_fndecl_string_len_trim;
178 tree gfor_fndecl_string_index;
179 tree gfor_fndecl_string_scan;
180 tree gfor_fndecl_string_verify;
181 tree gfor_fndecl_string_trim;
182 tree gfor_fndecl_string_minmax;
183 tree gfor_fndecl_adjustl;
184 tree gfor_fndecl_adjustr;
185 tree gfor_fndecl_select_string;
186 tree gfor_fndecl_compare_string_char4;
187 tree gfor_fndecl_concat_string_char4;
188 tree gfor_fndecl_string_len_trim_char4;
189 tree gfor_fndecl_string_index_char4;
190 tree gfor_fndecl_string_scan_char4;
191 tree gfor_fndecl_string_verify_char4;
192 tree gfor_fndecl_string_trim_char4;
193 tree gfor_fndecl_string_minmax_char4;
194 tree gfor_fndecl_adjustl_char4;
195 tree gfor_fndecl_adjustr_char4;
196 tree gfor_fndecl_select_string_char4;
197
198
199 /* Conversion between character kinds. */
200 tree gfor_fndecl_convert_char1_to_char4;
201 tree gfor_fndecl_convert_char4_to_char1;
202
203
204 /* Other misc. runtime library functions. */
205 tree gfor_fndecl_size0;
206 tree gfor_fndecl_size1;
207 tree gfor_fndecl_iargc;
208
209 /* Intrinsic functions implemented in Fortran. */
210 tree gfor_fndecl_sc_kind;
211 tree gfor_fndecl_si_kind;
212 tree gfor_fndecl_sr_kind;
213
214 /* BLAS gemm functions. */
215 tree gfor_fndecl_sgemm;
216 tree gfor_fndecl_dgemm;
217 tree gfor_fndecl_cgemm;
218 tree gfor_fndecl_zgemm;
219
220
221 static void
222 gfc_add_decl_to_parent_function (tree decl)
223 {
224 gcc_assert (decl);
225 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
226 DECL_NONLOCAL (decl) = 1;
227 DECL_CHAIN (decl) = saved_parent_function_decls;
228 saved_parent_function_decls = decl;
229 }
230
231 void
232 gfc_add_decl_to_function (tree decl)
233 {
234 gcc_assert (decl);
235 TREE_USED (decl) = 1;
236 DECL_CONTEXT (decl) = current_function_decl;
237 DECL_CHAIN (decl) = saved_function_decls;
238 saved_function_decls = decl;
239 }
240
241 static void
242 add_decl_as_local (tree decl)
243 {
244 gcc_assert (decl);
245 TREE_USED (decl) = 1;
246 DECL_CONTEXT (decl) = current_function_decl;
247 DECL_CHAIN (decl) = saved_local_decls;
248 saved_local_decls = decl;
249 }
250
251
252 /* Build a backend label declaration. Set TREE_USED for named labels.
253 The context of the label is always the current_function_decl. All
254 labels are marked artificial. */
255
256 tree
257 gfc_build_label_decl (tree label_id)
258 {
259 /* 2^32 temporaries should be enough. */
260 static unsigned int tmp_num = 1;
261 tree label_decl;
262 char *label_name;
263
264 if (label_id == NULL_TREE)
265 {
266 /* Build an internal label name. */
267 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
268 label_id = get_identifier (label_name);
269 }
270 else
271 label_name = NULL;
272
273 /* Build the LABEL_DECL node. Labels have no type. */
274 label_decl = build_decl (input_location,
275 LABEL_DECL, label_id, void_type_node);
276 DECL_CONTEXT (label_decl) = current_function_decl;
277 SET_DECL_MODE (label_decl, VOIDmode);
278
279 /* We always define the label as used, even if the original source
280 file never references the label. We don't want all kinds of
281 spurious warnings for old-style Fortran code with too many
282 labels. */
283 TREE_USED (label_decl) = 1;
284
285 DECL_ARTIFICIAL (label_decl) = 1;
286 return label_decl;
287 }
288
289
290 /* Set the backend source location of a decl. */
291
292 void
293 gfc_set_decl_location (tree decl, locus * loc)
294 {
295 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
296 }
297
298
299 /* Return the backend label declaration for a given label structure,
300 or create it if it doesn't exist yet. */
301
302 tree
303 gfc_get_label_decl (gfc_st_label * lp)
304 {
305 if (lp->backend_decl)
306 return lp->backend_decl;
307 else
308 {
309 char label_name[GFC_MAX_SYMBOL_LEN + 1];
310 tree label_decl;
311
312 /* Validate the label declaration from the front end. */
313 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
314
315 /* Build a mangled name for the label. */
316 sprintf (label_name, "__label_%.6d", lp->value);
317
318 /* Build the LABEL_DECL node. */
319 label_decl = gfc_build_label_decl (get_identifier (label_name));
320
321 /* Tell the debugger where the label came from. */
322 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
323 gfc_set_decl_location (label_decl, &lp->where);
324 else
325 DECL_ARTIFICIAL (label_decl) = 1;
326
327 /* Store the label in the label list and return the LABEL_DECL. */
328 lp->backend_decl = label_decl;
329 return label_decl;
330 }
331 }
332
333
334 /* Convert a gfc_symbol to an identifier of the same name. */
335
336 static tree
337 gfc_sym_identifier (gfc_symbol * sym)
338 {
339 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
340 return (get_identifier ("MAIN__"));
341 else
342 return (get_identifier (sym->name));
343 }
344
345
346 /* Construct mangled name from symbol name. */
347
348 static tree
349 gfc_sym_mangled_identifier (gfc_symbol * sym)
350 {
351 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
352
353 /* Prevent the mangling of identifiers that have an assigned
354 binding label (mainly those that are bind(c)). */
355 if (sym->attr.is_bind_c == 1 && sym->binding_label)
356 return get_identifier (sym->binding_label);
357
358 if (!sym->fn_result_spec)
359 {
360 if (sym->module == NULL)
361 return gfc_sym_identifier (sym);
362 else
363 {
364 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
365 return get_identifier (name);
366 }
367 }
368 else
369 {
370 /* This is an entity that is actually local to a module procedure
371 that appears in the result specification expression. Since
372 sym->module will be a zero length string, we use ns->proc_name
373 instead. */
374 if (sym->ns->proc_name && sym->ns->proc_name->module)
375 {
376 snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s",
377 sym->ns->proc_name->module,
378 sym->ns->proc_name->name,
379 sym->name);
380 return get_identifier (name);
381 }
382 else
383 {
384 snprintf (name, sizeof name, "__%s_PROC_%s",
385 sym->ns->proc_name->name, sym->name);
386 return get_identifier (name);
387 }
388 }
389 }
390
391
392 /* Construct mangled function name from symbol name. */
393
394 static tree
395 gfc_sym_mangled_function_id (gfc_symbol * sym)
396 {
397 int has_underscore;
398 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
399
400 /* It may be possible to simply use the binding label if it's
401 provided, and remove the other checks. Then we could use it
402 for other things if we wished. */
403 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
404 sym->binding_label)
405 /* use the binding label rather than the mangled name */
406 return get_identifier (sym->binding_label);
407
408 if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
409 || (sym->module != NULL && (sym->attr.external
410 || sym->attr.if_source == IFSRC_IFBODY)))
411 && !sym->attr.module_procedure)
412 {
413 /* Main program is mangled into MAIN__. */
414 if (sym->attr.is_main_program)
415 return get_identifier ("MAIN__");
416
417 /* Intrinsic procedures are never mangled. */
418 if (sym->attr.proc == PROC_INTRINSIC)
419 return get_identifier (sym->name);
420
421 if (flag_underscoring)
422 {
423 has_underscore = strchr (sym->name, '_') != 0;
424 if (flag_second_underscore && has_underscore)
425 snprintf (name, sizeof name, "%s__", sym->name);
426 else
427 snprintf (name, sizeof name, "%s_", sym->name);
428 return get_identifier (name);
429 }
430 else
431 return get_identifier (sym->name);
432 }
433 else
434 {
435 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
436 return get_identifier (name);
437 }
438 }
439
440
441 void
442 gfc_set_decl_assembler_name (tree decl, tree name)
443 {
444 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
445 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
446 }
447
448
449 /* Returns true if a variable of specified size should go on the stack. */
450
451 int
452 gfc_can_put_var_on_stack (tree size)
453 {
454 unsigned HOST_WIDE_INT low;
455
456 if (!INTEGER_CST_P (size))
457 return 0;
458
459 if (flag_max_stack_var_size < 0)
460 return 1;
461
462 if (!tree_fits_uhwi_p (size))
463 return 0;
464
465 low = TREE_INT_CST_LOW (size);
466 if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size)
467 return 0;
468
469 /* TODO: Set a per-function stack size limit. */
470
471 return 1;
472 }
473
474
475 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
476 an expression involving its corresponding pointer. There are
477 2 cases; one for variable size arrays, and one for everything else,
478 because variable-sized arrays require one fewer level of
479 indirection. */
480
481 static void
482 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
483 {
484 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
485 tree value;
486
487 /* Parameters need to be dereferenced. */
488 if (sym->cp_pointer->attr.dummy)
489 ptr_decl = build_fold_indirect_ref_loc (input_location,
490 ptr_decl);
491
492 /* Check to see if we're dealing with a variable-sized array. */
493 if (sym->attr.dimension
494 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
495 {
496 /* These decls will be dereferenced later, so we don't dereference
497 them here. */
498 value = convert (TREE_TYPE (decl), ptr_decl);
499 }
500 else
501 {
502 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
503 ptr_decl);
504 value = build_fold_indirect_ref_loc (input_location,
505 ptr_decl);
506 }
507
508 SET_DECL_VALUE_EXPR (decl, value);
509 DECL_HAS_VALUE_EXPR_P (decl) = 1;
510 GFC_DECL_CRAY_POINTEE (decl) = 1;
511 }
512
513
514 /* Finish processing of a declaration without an initial value. */
515
516 static void
517 gfc_finish_decl (tree decl)
518 {
519 gcc_assert (TREE_CODE (decl) == PARM_DECL
520 || DECL_INITIAL (decl) == NULL_TREE);
521
522 if (!VAR_P (decl))
523 return;
524
525 if (DECL_SIZE (decl) == NULL_TREE
526 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
527 layout_decl (decl, 0);
528
529 /* A few consistency checks. */
530 /* A static variable with an incomplete type is an error if it is
531 initialized. Also if it is not file scope. Otherwise, let it
532 through, but if it is not `extern' then it may cause an error
533 message later. */
534 /* An automatic variable with an incomplete type is an error. */
535
536 /* We should know the storage size. */
537 gcc_assert (DECL_SIZE (decl) != NULL_TREE
538 || (TREE_STATIC (decl)
539 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
540 : DECL_EXTERNAL (decl)));
541
542 /* The storage size should be constant. */
543 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
544 || !DECL_SIZE (decl)
545 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
546 }
547
548
549 /* Handle setting of GFC_DECL_SCALAR* on DECL. */
550
551 void
552 gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
553 {
554 if (!attr->dimension && !attr->codimension)
555 {
556 /* Handle scalar allocatable variables. */
557 if (attr->allocatable)
558 {
559 gfc_allocate_lang_decl (decl);
560 GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
561 }
562 /* Handle scalar pointer variables. */
563 if (attr->pointer)
564 {
565 gfc_allocate_lang_decl (decl);
566 GFC_DECL_SCALAR_POINTER (decl) = 1;
567 }
568 }
569 }
570
571
572 /* Apply symbol attributes to a variable, and add it to the function scope. */
573
574 static void
575 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
576 {
577 tree new_type;
578
579 /* Set DECL_VALUE_EXPR for Cray Pointees. */
580 if (sym->attr.cray_pointee)
581 gfc_finish_cray_pointee (decl, sym);
582
583 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
584 This is the equivalent of the TARGET variables.
585 We also need to set this if the variable is passed by reference in a
586 CALL statement. */
587 if (sym->attr.target)
588 TREE_ADDRESSABLE (decl) = 1;
589
590 /* If it wasn't used we wouldn't be getting it. */
591 TREE_USED (decl) = 1;
592
593 if (sym->attr.flavor == FL_PARAMETER
594 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
595 TREE_READONLY (decl) = 1;
596
597 /* Chain this decl to the pending declarations. Don't do pushdecl()
598 because this would add them to the current scope rather than the
599 function scope. */
600 if (current_function_decl != NULL_TREE)
601 {
602 if (sym->ns->proc_name->backend_decl == current_function_decl
603 || sym->result == sym)
604 gfc_add_decl_to_function (decl);
605 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
606 /* This is a BLOCK construct. */
607 add_decl_as_local (decl);
608 else
609 gfc_add_decl_to_parent_function (decl);
610 }
611
612 if (sym->attr.cray_pointee)
613 return;
614
615 if(sym->attr.is_bind_c == 1 && sym->binding_label)
616 {
617 /* We need to put variables that are bind(c) into the common
618 segment of the object file, because this is what C would do.
619 gfortran would typically put them in either the BSS or
620 initialized data segments, and only mark them as common if
621 they were part of common blocks. However, if they are not put
622 into common space, then C cannot initialize global Fortran
623 variables that it interoperates with and the draft says that
624 either Fortran or C should be able to initialize it (but not
625 both, of course.) (J3/04-007, section 15.3). */
626 TREE_PUBLIC(decl) = 1;
627 DECL_COMMON(decl) = 1;
628 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
629 {
630 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
631 DECL_VISIBILITY_SPECIFIED (decl) = true;
632 }
633 }
634
635 /* If a variable is USE associated, it's always external. */
636 if (sym->attr.use_assoc || sym->attr.used_in_submodule)
637 {
638 DECL_EXTERNAL (decl) = 1;
639 TREE_PUBLIC (decl) = 1;
640 }
641 else if (sym->fn_result_spec && !sym->ns->proc_name->module)
642 {
643
644 if (sym->ns->proc_name->attr.if_source != IFSRC_DECL)
645 DECL_EXTERNAL (decl) = 1;
646 else
647 TREE_STATIC (decl) = 1;
648
649 TREE_PUBLIC (decl) = 1;
650 }
651 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
652 {
653 /* TODO: Don't set sym->module for result or dummy variables. */
654 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
655
656 TREE_PUBLIC (decl) = 1;
657 TREE_STATIC (decl) = 1;
658 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
659 {
660 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
661 DECL_VISIBILITY_SPECIFIED (decl) = true;
662 }
663 }
664
665 /* Derived types are a bit peculiar because of the possibility of
666 a default initializer; this must be applied each time the variable
667 comes into scope it therefore need not be static. These variables
668 are SAVE_NONE but have an initializer. Otherwise explicitly
669 initialized variables are SAVE_IMPLICIT and explicitly saved are
670 SAVE_EXPLICIT. */
671 if (!sym->attr.use_assoc
672 && (sym->attr.save != SAVE_NONE || sym->attr.data
673 || (sym->value && sym->ns->proc_name->attr.is_main_program)
674 || (flag_coarray == GFC_FCOARRAY_LIB
675 && sym->attr.codimension && !sym->attr.allocatable)))
676 TREE_STATIC (decl) = 1;
677
678 /* If derived-type variables with DTIO procedures are not made static
679 some bits of code referencing them get optimized away.
680 TODO Understand why this is so and fix it. */
681 if (!sym->attr.use_assoc
682 && ((sym->ts.type == BT_DERIVED
683 && sym->ts.u.derived->attr.has_dtio_procs)
684 || (sym->ts.type == BT_CLASS
685 && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
686 TREE_STATIC (decl) = 1;
687
688 if (sym->attr.volatile_)
689 {
690 TREE_THIS_VOLATILE (decl) = 1;
691 TREE_SIDE_EFFECTS (decl) = 1;
692 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
693 TREE_TYPE (decl) = new_type;
694 }
695
696 /* Keep variables larger than max-stack-var-size off stack. */
697 if (!sym->ns->proc_name->attr.recursive && !sym->attr.automatic
698 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
699 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
700 /* Put variable length auto array pointers always into stack. */
701 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
702 || sym->attr.dimension == 0
703 || sym->as->type != AS_EXPLICIT
704 || sym->attr.pointer
705 || sym->attr.allocatable)
706 && !DECL_ARTIFICIAL (decl))
707 {
708 TREE_STATIC (decl) = 1;
709
710 /* Because the size of this variable isn't known until now, we may have
711 greedily added an initializer to this variable (in build_init_assign)
712 even though the max-stack-var-size indicates the variable should be
713 static. Therefore we rip out the automatic initializer here and
714 replace it with a static one. */
715 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
716 gfc_code *prev = NULL;
717 gfc_code *code = sym->ns->code;
718 while (code && code->op == EXEC_INIT_ASSIGN)
719 {
720 /* Look for an initializer meant for this symbol. */
721 if (code->expr1->symtree == st)
722 {
723 if (prev)
724 prev->next = code->next;
725 else
726 sym->ns->code = code->next;
727
728 break;
729 }
730
731 prev = code;
732 code = code->next;
733 }
734 if (code && code->op == EXEC_INIT_ASSIGN)
735 {
736 /* Keep the init expression for a static initializer. */
737 sym->value = code->expr2;
738 /* Cleanup the defunct code object, without freeing the init expr. */
739 code->expr2 = NULL;
740 gfc_free_statement (code);
741 free (code);
742 }
743 }
744
745 /* Handle threadprivate variables. */
746 if (sym->attr.threadprivate
747 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
748 set_decl_tls_model (decl, decl_default_tls_model (decl));
749
750 gfc_finish_decl_attrs (decl, &sym->attr);
751 }
752
753
754 /* Allocate the lang-specific part of a decl. */
755
756 void
757 gfc_allocate_lang_decl (tree decl)
758 {
759 if (DECL_LANG_SPECIFIC (decl) == NULL)
760 DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
761 }
762
763 /* Remember a symbol to generate initialization/cleanup code at function
764 entry/exit. */
765
766 static void
767 gfc_defer_symbol_init (gfc_symbol * sym)
768 {
769 gfc_symbol *p;
770 gfc_symbol *last;
771 gfc_symbol *head;
772
773 /* Don't add a symbol twice. */
774 if (sym->tlink)
775 return;
776
777 last = head = sym->ns->proc_name;
778 p = last->tlink;
779
780 /* Make sure that setup code for dummy variables which are used in the
781 setup of other variables is generated first. */
782 if (sym->attr.dummy)
783 {
784 /* Find the first dummy arg seen after us, or the first non-dummy arg.
785 This is a circular list, so don't go past the head. */
786 while (p != head
787 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
788 {
789 last = p;
790 p = p->tlink;
791 }
792 }
793 /* Insert in between last and p. */
794 last->tlink = sym;
795 sym->tlink = p;
796 }
797
798
799 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
800 backend_decl for a module symbol, if it all ready exists. If the
801 module gsymbol does not exist, it is created. If the symbol does
802 not exist, it is added to the gsymbol namespace. Returns true if
803 an existing backend_decl is found. */
804
805 bool
806 gfc_get_module_backend_decl (gfc_symbol *sym)
807 {
808 gfc_gsymbol *gsym;
809 gfc_symbol *s;
810 gfc_symtree *st;
811
812 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
813
814 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
815 {
816 st = NULL;
817 s = NULL;
818
819 /* Check for a symbol with the same name. */
820 if (gsym)
821 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
822
823 if (!s)
824 {
825 if (!gsym)
826 {
827 gsym = gfc_get_gsymbol (sym->module);
828 gsym->type = GSYM_MODULE;
829 gsym->ns = gfc_get_namespace (NULL, 0);
830 }
831
832 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
833 st->n.sym = sym;
834 sym->refs++;
835 }
836 else if (gfc_fl_struct (sym->attr.flavor))
837 {
838 if (s && s->attr.flavor == FL_PROCEDURE)
839 {
840 gfc_interface *intr;
841 gcc_assert (s->attr.generic);
842 for (intr = s->generic; intr; intr = intr->next)
843 if (gfc_fl_struct (intr->sym->attr.flavor))
844 {
845 s = intr->sym;
846 break;
847 }
848 }
849
850 /* Normally we can assume that s is a derived-type symbol since it
851 shares a name with the derived-type sym. However if sym is a
852 STRUCTURE, it may in fact share a name with any other basic type
853 variable. If s is in fact of derived type then we can continue
854 looking for a duplicate type declaration. */
855 if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED)
856 {
857 s = s->ts.u.derived;
858 }
859
860 if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
861 {
862 if (s->attr.flavor == FL_UNION)
863 s->backend_decl = gfc_get_union_type (s);
864 else
865 s->backend_decl = gfc_get_derived_type (s);
866 }
867 gfc_copy_dt_decls_ifequal (s, sym, true);
868 return true;
869 }
870 else if (s->backend_decl)
871 {
872 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
873 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
874 true);
875 else if (sym->ts.type == BT_CHARACTER)
876 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
877 sym->backend_decl = s->backend_decl;
878 return true;
879 }
880 }
881 return false;
882 }
883
884
885 /* Create an array index type variable with function scope. */
886
887 static tree
888 create_index_var (const char * pfx, int nest)
889 {
890 tree decl;
891
892 decl = gfc_create_var_np (gfc_array_index_type, pfx);
893 if (nest)
894 gfc_add_decl_to_parent_function (decl);
895 else
896 gfc_add_decl_to_function (decl);
897 return decl;
898 }
899
900
901 /* Create variables to hold all the non-constant bits of info for a
902 descriptorless array. Remember these in the lang-specific part of the
903 type. */
904
905 static void
906 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
907 {
908 tree type;
909 int dim;
910 int nest;
911 gfc_namespace* procns;
912 symbol_attribute *array_attr;
913 gfc_array_spec *as;
914 bool is_classarray = IS_CLASS_ARRAY (sym);
915
916 type = TREE_TYPE (decl);
917 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
918 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
919
920 /* We just use the descriptor, if there is one. */
921 if (GFC_DESCRIPTOR_TYPE_P (type))
922 return;
923
924 gcc_assert (GFC_ARRAY_TYPE_P (type));
925 procns = gfc_find_proc_namespace (sym->ns);
926 nest = (procns->proc_name->backend_decl != current_function_decl)
927 && !sym->attr.contained;
928
929 if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
930 && as->type != AS_ASSUMED_SHAPE
931 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
932 {
933 tree token;
934 tree token_type = build_qualified_type (pvoid_type_node,
935 TYPE_QUAL_RESTRICT);
936
937 if (sym->module && (sym->attr.use_assoc
938 || sym->ns->proc_name->attr.flavor == FL_MODULE))
939 {
940 tree token_name
941 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
942 IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym))));
943 token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name,
944 token_type);
945 if (sym->attr.use_assoc)
946 DECL_EXTERNAL (token) = 1;
947 else
948 TREE_STATIC (token) = 1;
949
950 TREE_PUBLIC (token) = 1;
951
952 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
953 {
954 DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
955 DECL_VISIBILITY_SPECIFIED (token) = true;
956 }
957 }
958 else
959 {
960 token = gfc_create_var_np (token_type, "caf_token");
961 TREE_STATIC (token) = 1;
962 }
963
964 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
965 DECL_ARTIFICIAL (token) = 1;
966 DECL_NONALIASED (token) = 1;
967
968 if (sym->module && !sym->attr.use_assoc)
969 {
970 pushdecl (token);
971 DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl;
972 gfc_module_add_decl (cur_module, token);
973 }
974 else if (sym->attr.host_assoc
975 && TREE_CODE (DECL_CONTEXT (current_function_decl))
976 != TRANSLATION_UNIT_DECL)
977 gfc_add_decl_to_parent_function (token);
978 else
979 gfc_add_decl_to_function (token);
980 }
981
982 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
983 {
984 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
985 {
986 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
987 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
988 }
989 /* Don't try to use the unknown bound for assumed shape arrays. */
990 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
991 && (as->type != AS_ASSUMED_SIZE
992 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
993 {
994 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
995 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
996 }
997
998 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
999 {
1000 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
1001 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
1002 }
1003 }
1004 for (dim = GFC_TYPE_ARRAY_RANK (type);
1005 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
1006 {
1007 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
1008 {
1009 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
1010 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
1011 }
1012 /* Don't try to use the unknown ubound for the last coarray dimension. */
1013 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
1014 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
1015 {
1016 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
1017 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
1018 }
1019 }
1020 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
1021 {
1022 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
1023 "offset");
1024 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
1025
1026 if (nest)
1027 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
1028 else
1029 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
1030 }
1031
1032 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
1033 && as->type != AS_ASSUMED_SIZE)
1034 {
1035 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
1036 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
1037 }
1038
1039 if (POINTER_TYPE_P (type))
1040 {
1041 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
1042 gcc_assert (TYPE_LANG_SPECIFIC (type)
1043 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
1044 type = TREE_TYPE (type);
1045 }
1046
1047 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
1048 {
1049 tree size, range;
1050
1051 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1052 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
1053 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1054 size);
1055 TYPE_DOMAIN (type) = range;
1056 layout_type (type);
1057 }
1058
1059 if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
1060 && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
1061 && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
1062 {
1063 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
1064
1065 for (dim = 0; dim < as->rank - 1; dim++)
1066 {
1067 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1068 gtype = TREE_TYPE (gtype);
1069 }
1070 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
1071 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
1072 TYPE_NAME (type) = NULL_TREE;
1073 }
1074
1075 if (TYPE_NAME (type) == NULL_TREE)
1076 {
1077 tree gtype = TREE_TYPE (type), rtype, type_decl;
1078
1079 for (dim = as->rank - 1; dim >= 0; dim--)
1080 {
1081 tree lbound, ubound;
1082 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
1083 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
1084 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
1085 gtype = build_array_type (gtype, rtype);
1086 /* Ensure the bound variables aren't optimized out at -O0.
1087 For -O1 and above they often will be optimized out, but
1088 can be tracked by VTA. Also set DECL_NAMELESS, so that
1089 the artificial lbound.N or ubound.N DECL_NAME doesn't
1090 end up in debug info. */
1091 if (lbound
1092 && VAR_P (lbound)
1093 && DECL_ARTIFICIAL (lbound)
1094 && DECL_IGNORED_P (lbound))
1095 {
1096 if (DECL_NAME (lbound)
1097 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
1098 "lbound") != 0)
1099 DECL_NAMELESS (lbound) = 1;
1100 DECL_IGNORED_P (lbound) = 0;
1101 }
1102 if (ubound
1103 && VAR_P (ubound)
1104 && DECL_ARTIFICIAL (ubound)
1105 && DECL_IGNORED_P (ubound))
1106 {
1107 if (DECL_NAME (ubound)
1108 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
1109 "ubound") != 0)
1110 DECL_NAMELESS (ubound) = 1;
1111 DECL_IGNORED_P (ubound) = 0;
1112 }
1113 }
1114 TYPE_NAME (type) = type_decl = build_decl (input_location,
1115 TYPE_DECL, NULL, gtype);
1116 DECL_ORIGINAL_TYPE (type_decl) = gtype;
1117 }
1118 }
1119
1120
1121 /* For some dummy arguments we don't use the actual argument directly.
1122 Instead we create a local decl and use that. This allows us to perform
1123 initialization, and construct full type information. */
1124
1125 static tree
1126 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
1127 {
1128 tree decl;
1129 tree type;
1130 gfc_array_spec *as;
1131 symbol_attribute *array_attr;
1132 char *name;
1133 gfc_packed packed;
1134 int n;
1135 bool known_size;
1136 bool is_classarray = IS_CLASS_ARRAY (sym);
1137
1138 /* Use the array as and attr. */
1139 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
1140 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
1141
1142 /* The dummy is returned for pointer, allocatable or assumed rank arrays.
1143 For class arrays the information if sym is an allocatable or pointer
1144 object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1145 too many reasons to be of use here). */
1146 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
1147 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
1148 || array_attr->allocatable
1149 || (as && as->type == AS_ASSUMED_RANK))
1150 return dummy;
1151
1152 /* Add to list of variables if not a fake result variable.
1153 These symbols are set on the symbol only, not on the class component. */
1154 if (sym->attr.result || sym->attr.dummy)
1155 gfc_defer_symbol_init (sym);
1156
1157 /* For a class array the array descriptor is in the _data component, while
1158 for a regular array the TREE_TYPE of the dummy is a pointer to the
1159 descriptor. */
1160 type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
1161 : TREE_TYPE (dummy));
1162 /* type now is the array descriptor w/o any indirection. */
1163 gcc_assert (TREE_CODE (dummy) == PARM_DECL
1164 && POINTER_TYPE_P (TREE_TYPE (dummy)));
1165
1166 /* Do we know the element size? */
1167 known_size = sym->ts.type != BT_CHARACTER
1168 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
1169
1170 if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
1171 {
1172 /* For descriptorless arrays with known element size the actual
1173 argument is sufficient. */
1174 gfc_build_qualified_array (dummy, sym);
1175 return dummy;
1176 }
1177
1178 if (GFC_DESCRIPTOR_TYPE_P (type))
1179 {
1180 /* Create a descriptorless array pointer. */
1181 packed = PACKED_NO;
1182
1183 /* Even when -frepack-arrays is used, symbols with TARGET attribute
1184 are not repacked. */
1185 if (!flag_repack_arrays || sym->attr.target)
1186 {
1187 if (as->type == AS_ASSUMED_SIZE)
1188 packed = PACKED_FULL;
1189 }
1190 else
1191 {
1192 if (as->type == AS_EXPLICIT)
1193 {
1194 packed = PACKED_FULL;
1195 for (n = 0; n < as->rank; n++)
1196 {
1197 if (!(as->upper[n]
1198 && as->lower[n]
1199 && as->upper[n]->expr_type == EXPR_CONSTANT
1200 && as->lower[n]->expr_type == EXPR_CONSTANT))
1201 {
1202 packed = PACKED_PARTIAL;
1203 break;
1204 }
1205 }
1206 }
1207 else
1208 packed = PACKED_PARTIAL;
1209 }
1210
1211 /* For classarrays the element type is required, but
1212 gfc_typenode_for_spec () returns the array descriptor. */
1213 type = is_classarray ? gfc_get_element_type (type)
1214 : gfc_typenode_for_spec (&sym->ts);
1215 type = gfc_get_nodesc_array_type (type, as, packed,
1216 !sym->attr.target);
1217 }
1218 else
1219 {
1220 /* We now have an expression for the element size, so create a fully
1221 qualified type. Reset sym->backend decl or this will just return the
1222 old type. */
1223 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1224 sym->backend_decl = NULL_TREE;
1225 type = gfc_sym_type (sym);
1226 packed = PACKED_FULL;
1227 }
1228
1229 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1230 decl = build_decl (input_location,
1231 VAR_DECL, get_identifier (name), type);
1232
1233 DECL_ARTIFICIAL (decl) = 1;
1234 DECL_NAMELESS (decl) = 1;
1235 TREE_PUBLIC (decl) = 0;
1236 TREE_STATIC (decl) = 0;
1237 DECL_EXTERNAL (decl) = 0;
1238
1239 /* Avoid uninitialized warnings for optional dummy arguments. */
1240 if (sym->attr.optional)
1241 TREE_NO_WARNING (decl) = 1;
1242
1243 /* We should never get deferred shape arrays here. We used to because of
1244 frontend bugs. */
1245 gcc_assert (as->type != AS_DEFERRED);
1246
1247 if (packed == PACKED_PARTIAL)
1248 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1249 else if (packed == PACKED_FULL)
1250 GFC_DECL_PACKED_ARRAY (decl) = 1;
1251
1252 gfc_build_qualified_array (decl, sym);
1253
1254 if (DECL_LANG_SPECIFIC (dummy))
1255 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1256 else
1257 gfc_allocate_lang_decl (decl);
1258
1259 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1260
1261 if (sym->ns->proc_name->backend_decl == current_function_decl
1262 || sym->attr.contained)
1263 gfc_add_decl_to_function (decl);
1264 else
1265 gfc_add_decl_to_parent_function (decl);
1266
1267 return decl;
1268 }
1269
1270 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1271 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1272 pointing to the artificial variable for debug info purposes. */
1273
1274 static void
1275 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1276 {
1277 tree decl, dummy;
1278
1279 if (! nonlocal_dummy_decl_pset)
1280 nonlocal_dummy_decl_pset = new hash_set<tree>;
1281
1282 if (nonlocal_dummy_decl_pset->add (sym->backend_decl))
1283 return;
1284
1285 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1286 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1287 TREE_TYPE (sym->backend_decl));
1288 DECL_ARTIFICIAL (decl) = 0;
1289 TREE_USED (decl) = 1;
1290 TREE_PUBLIC (decl) = 0;
1291 TREE_STATIC (decl) = 0;
1292 DECL_EXTERNAL (decl) = 0;
1293 if (DECL_BY_REFERENCE (dummy))
1294 DECL_BY_REFERENCE (decl) = 1;
1295 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1296 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1297 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1298 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1299 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1300 nonlocal_dummy_decls = decl;
1301 }
1302
1303 /* Return a constant or a variable to use as a string length. Does not
1304 add the decl to the current scope. */
1305
1306 static tree
1307 gfc_create_string_length (gfc_symbol * sym)
1308 {
1309 gcc_assert (sym->ts.u.cl);
1310 gfc_conv_const_charlen (sym->ts.u.cl);
1311
1312 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1313 {
1314 tree length;
1315 const char *name;
1316
1317 /* The string length variable shall be in static memory if it is either
1318 explicitly SAVED, a module variable or with -fno-automatic. Only
1319 relevant is "len=:" - otherwise, it is either a constant length or
1320 it is an automatic variable. */
1321 bool static_length = sym->attr.save
1322 || sym->ns->proc_name->attr.flavor == FL_MODULE
1323 || (flag_max_stack_var_size == 0
1324 && sym->ts.deferred && !sym->attr.dummy
1325 && !sym->attr.result && !sym->attr.function);
1326
1327 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1328 variables as some systems do not support the "." in the assembler name.
1329 For nonstatic variables, the "." does not appear in assembler. */
1330 if (static_length)
1331 {
1332 if (sym->module)
1333 name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
1334 sym->name);
1335 else
1336 name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
1337 }
1338 else if (sym->module)
1339 name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
1340 else
1341 name = gfc_get_string (".%s", sym->name);
1342
1343 length = build_decl (input_location,
1344 VAR_DECL, get_identifier (name),
1345 gfc_charlen_type_node);
1346 DECL_ARTIFICIAL (length) = 1;
1347 TREE_USED (length) = 1;
1348 if (sym->ns->proc_name->tlink != NULL)
1349 gfc_defer_symbol_init (sym);
1350
1351 sym->ts.u.cl->backend_decl = length;
1352
1353 if (static_length)
1354 TREE_STATIC (length) = 1;
1355
1356 if (sym->ns->proc_name->attr.flavor == FL_MODULE
1357 && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
1358 TREE_PUBLIC (length) = 1;
1359 }
1360
1361 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1362 return sym->ts.u.cl->backend_decl;
1363 }
1364
1365 /* If a variable is assigned a label, we add another two auxiliary
1366 variables. */
1367
1368 static void
1369 gfc_add_assign_aux_vars (gfc_symbol * sym)
1370 {
1371 tree addr;
1372 tree length;
1373 tree decl;
1374
1375 gcc_assert (sym->backend_decl);
1376
1377 decl = sym->backend_decl;
1378 gfc_allocate_lang_decl (decl);
1379 GFC_DECL_ASSIGN (decl) = 1;
1380 length = build_decl (input_location,
1381 VAR_DECL, create_tmp_var_name (sym->name),
1382 gfc_charlen_type_node);
1383 addr = build_decl (input_location,
1384 VAR_DECL, create_tmp_var_name (sym->name),
1385 pvoid_type_node);
1386 gfc_finish_var_decl (length, sym);
1387 gfc_finish_var_decl (addr, sym);
1388 /* STRING_LENGTH is also used as flag. Less than -1 means that
1389 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1390 target label's address. Otherwise, value is the length of a format string
1391 and ASSIGN_ADDR is its address. */
1392 if (TREE_STATIC (length))
1393 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1394 else
1395 gfc_defer_symbol_init (sym);
1396
1397 GFC_DECL_STRING_LEN (decl) = length;
1398 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1399 }
1400
1401
1402 static tree
1403 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1404 {
1405 unsigned id;
1406 tree attr;
1407
1408 for (id = 0; id < EXT_ATTR_NUM; id++)
1409 if (sym_attr.ext_attr & (1 << id))
1410 {
1411 attr = build_tree_list (
1412 get_identifier (ext_attr_list[id].middle_end_name),
1413 NULL_TREE);
1414 list = chainon (list, attr);
1415 }
1416
1417 if (sym_attr.omp_declare_target_link)
1418 list = tree_cons (get_identifier ("omp declare target link"),
1419 NULL_TREE, list);
1420 else if (sym_attr.omp_declare_target)
1421 list = tree_cons (get_identifier ("omp declare target"),
1422 NULL_TREE, list);
1423
1424 if (sym_attr.oacc_function)
1425 {
1426 tree dims = NULL_TREE;
1427 int ix;
1428 int level = sym_attr.oacc_function - 1;
1429
1430 for (ix = GOMP_DIM_MAX; ix--;)
1431 dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
1432 integer_zero_node, dims);
1433
1434 list = tree_cons (get_identifier ("oacc function"),
1435 dims, list);
1436 }
1437
1438 return list;
1439 }
1440
1441
1442 static void build_function_decl (gfc_symbol * sym, bool global);
1443
1444
1445 /* Return the decl for a gfc_symbol, create it if it doesn't already
1446 exist. */
1447
1448 tree
1449 gfc_get_symbol_decl (gfc_symbol * sym)
1450 {
1451 tree decl;
1452 tree length = NULL_TREE;
1453 tree attributes;
1454 int byref;
1455 bool intrinsic_array_parameter = false;
1456 bool fun_or_res;
1457
1458 gcc_assert (sym->attr.referenced
1459 || sym->attr.flavor == FL_PROCEDURE
1460 || sym->attr.use_assoc
1461 || sym->attr.used_in_submodule
1462 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1463 || (sym->module && sym->attr.if_source != IFSRC_DECL
1464 && sym->backend_decl));
1465
1466 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1467 byref = gfc_return_by_reference (sym->ns->proc_name);
1468 else
1469 byref = 0;
1470
1471 /* Make sure that the vtab for the declared type is completed. */
1472 if (sym->ts.type == BT_CLASS)
1473 {
1474 gfc_component *c = CLASS_DATA (sym);
1475 if (!c->ts.u.derived->backend_decl)
1476 {
1477 gfc_find_derived_vtab (c->ts.u.derived);
1478 gfc_get_derived_type (sym->ts.u.derived);
1479 }
1480 }
1481
1482 /* All deferred character length procedures need to retain the backend
1483 decl, which is a pointer to the character length in the caller's
1484 namespace and to declare a local character length. */
1485 if (!byref && sym->attr.function
1486 && sym->ts.type == BT_CHARACTER
1487 && sym->ts.deferred
1488 && sym->ts.u.cl->passed_length == NULL
1489 && sym->ts.u.cl->backend_decl
1490 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1491 {
1492 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1493 gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
1494 sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1495 }
1496
1497 fun_or_res = byref && (sym->attr.result
1498 || (sym->attr.function && sym->ts.deferred));
1499 if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
1500 {
1501 /* Return via extra parameter. */
1502 if (sym->attr.result && byref
1503 && !sym->backend_decl)
1504 {
1505 sym->backend_decl =
1506 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1507 /* For entry master function skip over the __entry
1508 argument. */
1509 if (sym->ns->proc_name->attr.entry_master)
1510 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1511 }
1512
1513 /* Dummy variables should already have been created. */
1514 gcc_assert (sym->backend_decl);
1515
1516 /* Create a character length variable. */
1517 if (sym->ts.type == BT_CHARACTER)
1518 {
1519 /* For a deferred dummy, make a new string length variable. */
1520 if (sym->ts.deferred
1521 &&
1522 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1523 sym->ts.u.cl->backend_decl = NULL_TREE;
1524
1525 if (sym->ts.deferred && byref)
1526 {
1527 /* The string length of a deferred char array is stored in the
1528 parameter at sym->ts.u.cl->backend_decl as a reference and
1529 marked as a result. Exempt this variable from generating a
1530 temporary for it. */
1531 if (sym->attr.result)
1532 {
1533 /* We need to insert a indirect ref for param decls. */
1534 if (sym->ts.u.cl->backend_decl
1535 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1536 {
1537 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1538 sym->ts.u.cl->backend_decl =
1539 build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1540 }
1541 }
1542 /* For all other parameters make sure, that they are copied so
1543 that the value and any modifications are local to the routine
1544 by generating a temporary variable. */
1545 else if (sym->attr.function
1546 && sym->ts.u.cl->passed_length == NULL
1547 && sym->ts.u.cl->backend_decl)
1548 {
1549 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1550 if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
1551 sym->ts.u.cl->backend_decl
1552 = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
1553 else
1554 sym->ts.u.cl->backend_decl = NULL_TREE;
1555 }
1556 }
1557
1558 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1559 length = gfc_create_string_length (sym);
1560 else
1561 length = sym->ts.u.cl->backend_decl;
1562 if (VAR_P (length) && DECL_FILE_SCOPE_P (length))
1563 {
1564 /* Add the string length to the same context as the symbol. */
1565 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1566 gfc_add_decl_to_function (length);
1567 else
1568 gfc_add_decl_to_parent_function (length);
1569
1570 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1571 DECL_CONTEXT (length));
1572
1573 gfc_defer_symbol_init (sym);
1574 }
1575 }
1576
1577 /* Use a copy of the descriptor for dummy arrays. */
1578 if ((sym->attr.dimension || sym->attr.codimension)
1579 && !TREE_USED (sym->backend_decl))
1580 {
1581 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1582 /* Prevent the dummy from being detected as unused if it is copied. */
1583 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1584 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1585 sym->backend_decl = decl;
1586 }
1587
1588 /* Returning the descriptor for dummy class arrays is hazardous, because
1589 some caller is expecting an expression to apply the component refs to.
1590 Therefore the descriptor is only created and stored in
1591 sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1592 responsible to extract it from there, when the descriptor is
1593 desired. */
1594 if (IS_CLASS_ARRAY (sym)
1595 && (!DECL_LANG_SPECIFIC (sym->backend_decl)
1596 || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
1597 {
1598 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1599 /* Prevent the dummy from being detected as unused if it is copied. */
1600 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1601 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1602 sym->backend_decl = decl;
1603 }
1604
1605 TREE_USED (sym->backend_decl) = 1;
1606 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1607 {
1608 gfc_add_assign_aux_vars (sym);
1609 }
1610
1611 if ((sym->attr.dimension || IS_CLASS_ARRAY (sym))
1612 && DECL_LANG_SPECIFIC (sym->backend_decl)
1613 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1614 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1615 gfc_nonlocal_dummy_array_decl (sym);
1616
1617 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1618 GFC_DECL_CLASS(sym->backend_decl) = 1;
1619
1620 return sym->backend_decl;
1621 }
1622
1623 if (sym->backend_decl)
1624 return sym->backend_decl;
1625
1626 /* Special case for array-valued named constants from intrinsic
1627 procedures; those are inlined. */
1628 if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER
1629 && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
1630 || sym->from_intmod == INTMOD_ISO_C_BINDING))
1631 intrinsic_array_parameter = true;
1632
1633 /* If use associated compilation, use the module
1634 declaration. */
1635 if ((sym->attr.flavor == FL_VARIABLE
1636 || sym->attr.flavor == FL_PARAMETER)
1637 && (sym->attr.use_assoc || sym->attr.used_in_submodule)
1638 && !intrinsic_array_parameter
1639 && sym->module
1640 && gfc_get_module_backend_decl (sym))
1641 {
1642 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1643 GFC_DECL_CLASS(sym->backend_decl) = 1;
1644 return sym->backend_decl;
1645 }
1646
1647 if (sym->attr.flavor == FL_PROCEDURE)
1648 {
1649 /* Catch functions. Only used for actual parameters,
1650 procedure pointers and procptr initialization targets. */
1651 if (sym->attr.use_assoc || sym->attr.intrinsic
1652 || sym->attr.if_source != IFSRC_DECL)
1653 {
1654 decl = gfc_get_extern_function_decl (sym);
1655 gfc_set_decl_location (decl, &sym->declared_at);
1656 }
1657 else
1658 {
1659 if (!sym->backend_decl)
1660 build_function_decl (sym, false);
1661 decl = sym->backend_decl;
1662 }
1663 return decl;
1664 }
1665
1666 if (sym->attr.intrinsic)
1667 gfc_internal_error ("intrinsic variable which isn't a procedure");
1668
1669 /* Create string length decl first so that they can be used in the
1670 type declaration. For associate names, the target character
1671 length is used. Set 'length' to a constant so that if the
1672 string length is a variable, it is not finished a second time. */
1673 if (sym->ts.type == BT_CHARACTER)
1674 {
1675 if (sym->attr.associate_var
1676 && sym->ts.u.cl->backend_decl
1677 && VAR_P (sym->ts.u.cl->backend_decl))
1678 length = gfc_index_zero_node;
1679 else
1680 length = gfc_create_string_length (sym);
1681 }
1682
1683 /* Create the decl for the variable. */
1684 decl = build_decl (sym->declared_at.lb->location,
1685 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1686
1687 /* Add attributes to variables. Functions are handled elsewhere. */
1688 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1689 decl_attributes (&decl, attributes, 0);
1690
1691 /* Symbols from modules should have their assembler names mangled.
1692 This is done here rather than in gfc_finish_var_decl because it
1693 is different for string length variables. */
1694 if (sym->module || sym->fn_result_spec)
1695 {
1696 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1697 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1698 DECL_IGNORED_P (decl) = 1;
1699 }
1700
1701 if (sym->attr.select_type_temporary)
1702 {
1703 DECL_ARTIFICIAL (decl) = 1;
1704 DECL_IGNORED_P (decl) = 1;
1705 }
1706
1707 if (sym->attr.dimension || sym->attr.codimension)
1708 {
1709 /* Create variables to hold the non-constant bits of array info. */
1710 gfc_build_qualified_array (decl, sym);
1711
1712 if (sym->attr.contiguous
1713 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1714 GFC_DECL_PACKED_ARRAY (decl) = 1;
1715 }
1716
1717 /* Remember this variable for allocation/cleanup. */
1718 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1719 || (sym->ts.type == BT_CLASS &&
1720 (CLASS_DATA (sym)->attr.dimension
1721 || CLASS_DATA (sym)->attr.allocatable))
1722 || (sym->ts.type == BT_DERIVED
1723 && (sym->ts.u.derived->attr.alloc_comp
1724 || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
1725 && !sym->ns->proc_name->attr.is_main_program
1726 && gfc_is_finalizable (sym->ts.u.derived, NULL))))
1727 /* This applies a derived type default initializer. */
1728 || (sym->ts.type == BT_DERIVED
1729 && sym->attr.save == SAVE_NONE
1730 && !sym->attr.data
1731 && !sym->attr.allocatable
1732 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1733 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1734 gfc_defer_symbol_init (sym);
1735
1736 /* Associate names can use the hidden string length variable
1737 of their associated target. */
1738 if (sym->ts.type == BT_CHARACTER
1739 && TREE_CODE (length) != INTEGER_CST)
1740 {
1741 gfc_finish_var_decl (length, sym);
1742 gcc_assert (!sym->value);
1743 }
1744
1745 gfc_finish_var_decl (decl, sym);
1746
1747 if (sym->ts.type == BT_CHARACTER)
1748 /* Character variables need special handling. */
1749 gfc_allocate_lang_decl (decl);
1750 else if (sym->attr.subref_array_pointer)
1751 /* We need the span for these beasts. */
1752 gfc_allocate_lang_decl (decl);
1753
1754 if (sym->attr.subref_array_pointer)
1755 {
1756 tree span;
1757 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1758 span = build_decl (input_location,
1759 VAR_DECL, create_tmp_var_name ("span"),
1760 gfc_array_index_type);
1761 gfc_finish_var_decl (span, sym);
1762 TREE_STATIC (span) = TREE_STATIC (decl);
1763 DECL_ARTIFICIAL (span) = 1;
1764
1765 GFC_DECL_SPAN (decl) = span;
1766 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1767 }
1768
1769 if (sym->ts.type == BT_CLASS)
1770 GFC_DECL_CLASS(decl) = 1;
1771
1772 sym->backend_decl = decl;
1773
1774 if (sym->attr.assign)
1775 gfc_add_assign_aux_vars (sym);
1776
1777 if (intrinsic_array_parameter)
1778 {
1779 TREE_STATIC (decl) = 1;
1780 DECL_EXTERNAL (decl) = 0;
1781 }
1782
1783 if (TREE_STATIC (decl)
1784 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1785 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1786 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
1787 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1788 && (flag_coarray != GFC_FCOARRAY_LIB
1789 || !sym->attr.codimension || sym->attr.allocatable))
1790 {
1791 /* Add static initializer. For procedures, it is only needed if
1792 SAVE is specified otherwise they need to be reinitialized
1793 every time the procedure is entered. The TREE_STATIC is
1794 in this case due to -fmax-stack-var-size=. */
1795
1796 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1797 TREE_TYPE (decl), sym->attr.dimension
1798 || (sym->attr.codimension
1799 && sym->attr.allocatable),
1800 sym->attr.pointer || sym->attr.allocatable
1801 || sym->ts.type == BT_CLASS,
1802 sym->attr.proc_pointer);
1803 }
1804
1805 if (!TREE_STATIC (decl)
1806 && POINTER_TYPE_P (TREE_TYPE (decl))
1807 && !sym->attr.pointer
1808 && !sym->attr.allocatable
1809 && !sym->attr.proc_pointer
1810 && !sym->attr.select_type_temporary)
1811 DECL_BY_REFERENCE (decl) = 1;
1812
1813 if (sym->attr.associate_var)
1814 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
1815
1816 if (sym->attr.vtab
1817 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1818 TREE_READONLY (decl) = 1;
1819
1820 return decl;
1821 }
1822
1823
1824 /* Substitute a temporary variable in place of the real one. */
1825
1826 void
1827 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1828 {
1829 save->attr = sym->attr;
1830 save->decl = sym->backend_decl;
1831
1832 gfc_clear_attr (&sym->attr);
1833 sym->attr.referenced = 1;
1834 sym->attr.flavor = FL_VARIABLE;
1835
1836 sym->backend_decl = decl;
1837 }
1838
1839
1840 /* Restore the original variable. */
1841
1842 void
1843 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1844 {
1845 sym->attr = save->attr;
1846 sym->backend_decl = save->decl;
1847 }
1848
1849
1850 /* Declare a procedure pointer. */
1851
1852 static tree
1853 get_proc_pointer_decl (gfc_symbol *sym)
1854 {
1855 tree decl;
1856 tree attributes;
1857
1858 decl = sym->backend_decl;
1859 if (decl)
1860 return decl;
1861
1862 decl = build_decl (input_location,
1863 VAR_DECL, get_identifier (sym->name),
1864 build_pointer_type (gfc_get_function_type (sym)));
1865
1866 if (sym->module)
1867 {
1868 /* Apply name mangling. */
1869 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1870 if (sym->attr.use_assoc)
1871 DECL_IGNORED_P (decl) = 1;
1872 }
1873
1874 if ((sym->ns->proc_name
1875 && sym->ns->proc_name->backend_decl == current_function_decl)
1876 || sym->attr.contained)
1877 gfc_add_decl_to_function (decl);
1878 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1879 gfc_add_decl_to_parent_function (decl);
1880
1881 sym->backend_decl = decl;
1882
1883 /* If a variable is USE associated, it's always external. */
1884 if (sym->attr.use_assoc)
1885 {
1886 DECL_EXTERNAL (decl) = 1;
1887 TREE_PUBLIC (decl) = 1;
1888 }
1889 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1890 {
1891 /* This is the declaration of a module variable. */
1892 TREE_PUBLIC (decl) = 1;
1893 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
1894 {
1895 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
1896 DECL_VISIBILITY_SPECIFIED (decl) = true;
1897 }
1898 TREE_STATIC (decl) = 1;
1899 }
1900
1901 if (!sym->attr.use_assoc
1902 && (sym->attr.save != SAVE_NONE || sym->attr.data
1903 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1904 TREE_STATIC (decl) = 1;
1905
1906 if (TREE_STATIC (decl) && sym->value)
1907 {
1908 /* Add static initializer. */
1909 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1910 TREE_TYPE (decl),
1911 sym->attr.dimension,
1912 false, true);
1913 }
1914
1915 /* Handle threadprivate procedure pointers. */
1916 if (sym->attr.threadprivate
1917 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1918 set_decl_tls_model (decl, decl_default_tls_model (decl));
1919
1920 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1921 decl_attributes (&decl, attributes, 0);
1922
1923 return decl;
1924 }
1925
1926
1927 /* Get a basic decl for an external function. */
1928
1929 tree
1930 gfc_get_extern_function_decl (gfc_symbol * sym)
1931 {
1932 tree type;
1933 tree fndecl;
1934 tree attributes;
1935 gfc_expr e;
1936 gfc_intrinsic_sym *isym;
1937 gfc_expr argexpr;
1938 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1939 tree name;
1940 tree mangled_name;
1941 gfc_gsymbol *gsym;
1942
1943 if (sym->backend_decl)
1944 return sym->backend_decl;
1945
1946 /* We should never be creating external decls for alternate entry points.
1947 The procedure may be an alternate entry point, but we don't want/need
1948 to know that. */
1949 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1950
1951 if (sym->attr.proc_pointer)
1952 return get_proc_pointer_decl (sym);
1953
1954 /* See if this is an external procedure from the same file. If so,
1955 return the backend_decl. */
1956 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
1957 ? sym->binding_label : sym->name);
1958
1959 if (gsym && !gsym->defined)
1960 gsym = NULL;
1961
1962 /* This can happen because of C binding. */
1963 if (gsym && gsym->ns && gsym->ns->proc_name
1964 && gsym->ns->proc_name->attr.flavor == FL_MODULE)
1965 goto module_sym;
1966
1967 if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1968 && !sym->backend_decl
1969 && gsym && gsym->ns
1970 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1971 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1972 {
1973 if (!gsym->ns->proc_name->backend_decl)
1974 {
1975 /* By construction, the external function cannot be
1976 a contained procedure. */
1977 locus old_loc;
1978
1979 gfc_save_backend_locus (&old_loc);
1980 push_cfun (NULL);
1981
1982 gfc_create_function_decl (gsym->ns, true);
1983
1984 pop_cfun ();
1985 gfc_restore_backend_locus (&old_loc);
1986 }
1987
1988 /* If the namespace has entries, the proc_name is the
1989 entry master. Find the entry and use its backend_decl.
1990 otherwise, use the proc_name backend_decl. */
1991 if (gsym->ns->entries)
1992 {
1993 gfc_entry_list *entry = gsym->ns->entries;
1994
1995 for (; entry; entry = entry->next)
1996 {
1997 if (strcmp (gsym->name, entry->sym->name) == 0)
1998 {
1999 sym->backend_decl = entry->sym->backend_decl;
2000 break;
2001 }
2002 }
2003 }
2004 else
2005 sym->backend_decl = gsym->ns->proc_name->backend_decl;
2006
2007 if (sym->backend_decl)
2008 {
2009 /* Avoid problems of double deallocation of the backend declaration
2010 later in gfc_trans_use_stmts; cf. PR 45087. */
2011 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
2012 sym->attr.use_assoc = 0;
2013
2014 return sym->backend_decl;
2015 }
2016 }
2017
2018 /* See if this is a module procedure from the same file. If so,
2019 return the backend_decl. */
2020 if (sym->module)
2021 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
2022
2023 module_sym:
2024 if (gsym && gsym->ns
2025 && (gsym->type == GSYM_MODULE
2026 || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
2027 {
2028 gfc_symbol *s;
2029
2030 s = NULL;
2031 if (gsym->type == GSYM_MODULE)
2032 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2033 else
2034 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
2035
2036 if (s && s->backend_decl)
2037 {
2038 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
2039 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
2040 true);
2041 else if (sym->ts.type == BT_CHARACTER)
2042 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
2043 sym->backend_decl = s->backend_decl;
2044 return sym->backend_decl;
2045 }
2046 }
2047
2048 if (sym->attr.intrinsic)
2049 {
2050 /* Call the resolution function to get the actual name. This is
2051 a nasty hack which relies on the resolution functions only looking
2052 at the first argument. We pass NULL for the second argument
2053 otherwise things like AINT get confused. */
2054 isym = gfc_find_function (sym->name);
2055 gcc_assert (isym->resolve.f0 != NULL);
2056
2057 memset (&e, 0, sizeof (e));
2058 e.expr_type = EXPR_FUNCTION;
2059
2060 memset (&argexpr, 0, sizeof (argexpr));
2061 gcc_assert (isym->formal);
2062 argexpr.ts = isym->formal->ts;
2063
2064 if (isym->formal->next == NULL)
2065 isym->resolve.f1 (&e, &argexpr);
2066 else
2067 {
2068 if (isym->formal->next->next == NULL)
2069 isym->resolve.f2 (&e, &argexpr, NULL);
2070 else
2071 {
2072 if (isym->formal->next->next->next == NULL)
2073 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
2074 else
2075 {
2076 /* All specific intrinsics take less than 5 arguments. */
2077 gcc_assert (isym->formal->next->next->next->next == NULL);
2078 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
2079 }
2080 }
2081 }
2082
2083 if (flag_f2c
2084 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
2085 || e.ts.type == BT_COMPLEX))
2086 {
2087 /* Specific which needs a different implementation if f2c
2088 calling conventions are used. */
2089 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
2090 }
2091 else
2092 sprintf (s, "_gfortran_specific%s", e.value.function.name);
2093
2094 name = get_identifier (s);
2095 mangled_name = name;
2096 }
2097 else
2098 {
2099 name = gfc_sym_identifier (sym);
2100 mangled_name = gfc_sym_mangled_function_id (sym);
2101 }
2102
2103 type = gfc_get_function_type (sym);
2104 fndecl = build_decl (input_location,
2105 FUNCTION_DECL, name, type);
2106
2107 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2108 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2109 the opposite of declaring a function as static in C). */
2110 DECL_EXTERNAL (fndecl) = 1;
2111 TREE_PUBLIC (fndecl) = 1;
2112
2113 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
2114 decl_attributes (&fndecl, attributes, 0);
2115
2116 gfc_set_decl_assembler_name (fndecl, mangled_name);
2117
2118 /* Set the context of this decl. */
2119 if (0 && sym->ns && sym->ns->proc_name)
2120 {
2121 /* TODO: Add external decls to the appropriate scope. */
2122 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
2123 }
2124 else
2125 {
2126 /* Global declaration, e.g. intrinsic subroutine. */
2127 DECL_CONTEXT (fndecl) = NULL_TREE;
2128 }
2129
2130 /* Set attributes for PURE functions. A call to PURE function in the
2131 Fortran 95 sense is both pure and without side effects in the C
2132 sense. */
2133 if (sym->attr.pure || sym->attr.implicit_pure)
2134 {
2135 if (sym->attr.function && !gfc_return_by_reference (sym))
2136 DECL_PURE_P (fndecl) = 1;
2137 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2138 parameters and don't use alternate returns (is this
2139 allowed?). In that case, calls to them are meaningless, and
2140 can be optimized away. See also in build_function_decl(). */
2141 TREE_SIDE_EFFECTS (fndecl) = 0;
2142 }
2143
2144 /* Mark non-returning functions. */
2145 if (sym->attr.noreturn)
2146 TREE_THIS_VOLATILE(fndecl) = 1;
2147
2148 sym->backend_decl = fndecl;
2149
2150 if (DECL_CONTEXT (fndecl) == NULL_TREE)
2151 pushdecl_top_level (fndecl);
2152
2153 if (sym->formal_ns
2154 && sym->formal_ns->proc_name == sym
2155 && sym->formal_ns->omp_declare_simd)
2156 gfc_trans_omp_declare_simd (sym->formal_ns);
2157
2158 return fndecl;
2159 }
2160
2161
2162 /* Create a declaration for a procedure. For external functions (in the C
2163 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2164 a master function with alternate entry points. */
2165
2166 static void
2167 build_function_decl (gfc_symbol * sym, bool global)
2168 {
2169 tree fndecl, type, attributes;
2170 symbol_attribute attr;
2171 tree result_decl;
2172 gfc_formal_arglist *f;
2173
2174 bool module_procedure = sym->attr.module_procedure
2175 && sym->ns
2176 && sym->ns->proc_name
2177 && sym->ns->proc_name->attr.flavor == FL_MODULE;
2178
2179 gcc_assert (!sym->attr.external || module_procedure);
2180
2181 if (sym->backend_decl)
2182 return;
2183
2184 /* Set the line and filename. sym->declared_at seems to point to the
2185 last statement for subroutines, but it'll do for now. */
2186 gfc_set_backend_locus (&sym->declared_at);
2187
2188 /* Allow only one nesting level. Allow public declarations. */
2189 gcc_assert (current_function_decl == NULL_TREE
2190 || DECL_FILE_SCOPE_P (current_function_decl)
2191 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
2192 == NAMESPACE_DECL));
2193
2194 type = gfc_get_function_type (sym);
2195 fndecl = build_decl (input_location,
2196 FUNCTION_DECL, gfc_sym_identifier (sym), type);
2197
2198 attr = sym->attr;
2199
2200 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2201 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2202 the opposite of declaring a function as static in C). */
2203 DECL_EXTERNAL (fndecl) = 0;
2204
2205 if (sym->attr.access == ACCESS_UNKNOWN && sym->module
2206 && (sym->ns->default_access == ACCESS_PRIVATE
2207 || (sym->ns->default_access == ACCESS_UNKNOWN
2208 && flag_module_private)))
2209 sym->attr.access = ACCESS_PRIVATE;
2210
2211 if (!current_function_decl
2212 && !sym->attr.entry_master && !sym->attr.is_main_program
2213 && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
2214 || sym->attr.public_used))
2215 TREE_PUBLIC (fndecl) = 1;
2216
2217 if (sym->attr.referenced || sym->attr.entry_master)
2218 TREE_USED (fndecl) = 1;
2219
2220 attributes = add_attributes_to_decl (attr, NULL_TREE);
2221 decl_attributes (&fndecl, attributes, 0);
2222
2223 /* Figure out the return type of the declared function, and build a
2224 RESULT_DECL for it. If this is a subroutine with alternate
2225 returns, build a RESULT_DECL for it. */
2226 result_decl = NULL_TREE;
2227 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2228 if (attr.function)
2229 {
2230 if (gfc_return_by_reference (sym))
2231 type = void_type_node;
2232 else
2233 {
2234 if (sym->result != sym)
2235 result_decl = gfc_sym_identifier (sym->result);
2236
2237 type = TREE_TYPE (TREE_TYPE (fndecl));
2238 }
2239 }
2240 else
2241 {
2242 /* Look for alternate return placeholders. */
2243 int has_alternate_returns = 0;
2244 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2245 {
2246 if (f->sym == NULL)
2247 {
2248 has_alternate_returns = 1;
2249 break;
2250 }
2251 }
2252
2253 if (has_alternate_returns)
2254 type = integer_type_node;
2255 else
2256 type = void_type_node;
2257 }
2258
2259 result_decl = build_decl (input_location,
2260 RESULT_DECL, result_decl, type);
2261 DECL_ARTIFICIAL (result_decl) = 1;
2262 DECL_IGNORED_P (result_decl) = 1;
2263 DECL_CONTEXT (result_decl) = fndecl;
2264 DECL_RESULT (fndecl) = result_decl;
2265
2266 /* Don't call layout_decl for a RESULT_DECL.
2267 layout_decl (result_decl, 0); */
2268
2269 /* TREE_STATIC means the function body is defined here. */
2270 TREE_STATIC (fndecl) = 1;
2271
2272 /* Set attributes for PURE functions. A call to a PURE function in the
2273 Fortran 95 sense is both pure and without side effects in the C
2274 sense. */
2275 if (attr.pure || attr.implicit_pure)
2276 {
2277 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2278 including an alternate return. In that case it can also be
2279 marked as PURE. See also in gfc_get_extern_function_decl(). */
2280 if (attr.function && !gfc_return_by_reference (sym))
2281 DECL_PURE_P (fndecl) = 1;
2282 TREE_SIDE_EFFECTS (fndecl) = 0;
2283 }
2284
2285
2286 /* Layout the function declaration and put it in the binding level
2287 of the current function. */
2288
2289 if (global)
2290 pushdecl_top_level (fndecl);
2291 else
2292 pushdecl (fndecl);
2293
2294 /* Perform name mangling if this is a top level or module procedure. */
2295 if (current_function_decl == NULL_TREE)
2296 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
2297
2298 sym->backend_decl = fndecl;
2299 }
2300
2301
2302 /* Create the DECL_ARGUMENTS for a procedure. */
2303
2304 static void
2305 create_function_arglist (gfc_symbol * sym)
2306 {
2307 tree fndecl;
2308 gfc_formal_arglist *f;
2309 tree typelist, hidden_typelist;
2310 tree arglist, hidden_arglist;
2311 tree type;
2312 tree parm;
2313
2314 fndecl = sym->backend_decl;
2315
2316 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2317 the new FUNCTION_DECL node. */
2318 arglist = NULL_TREE;
2319 hidden_arglist = NULL_TREE;
2320 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
2321
2322 if (sym->attr.entry_master)
2323 {
2324 type = TREE_VALUE (typelist);
2325 parm = build_decl (input_location,
2326 PARM_DECL, get_identifier ("__entry"), type);
2327
2328 DECL_CONTEXT (parm) = fndecl;
2329 DECL_ARG_TYPE (parm) = type;
2330 TREE_READONLY (parm) = 1;
2331 gfc_finish_decl (parm);
2332 DECL_ARTIFICIAL (parm) = 1;
2333
2334 arglist = chainon (arglist, parm);
2335 typelist = TREE_CHAIN (typelist);
2336 }
2337
2338 if (gfc_return_by_reference (sym))
2339 {
2340 tree type = TREE_VALUE (typelist), length = NULL;
2341
2342 if (sym->ts.type == BT_CHARACTER)
2343 {
2344 /* Length of character result. */
2345 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2346
2347 length = build_decl (input_location,
2348 PARM_DECL,
2349 get_identifier (".__result"),
2350 len_type);
2351 if (POINTER_TYPE_P (len_type))
2352 {
2353 sym->ts.u.cl->passed_length = length;
2354 TREE_USED (length) = 1;
2355 }
2356 else if (!sym->ts.u.cl->length)
2357 {
2358 sym->ts.u.cl->backend_decl = length;
2359 TREE_USED (length) = 1;
2360 }
2361 gcc_assert (TREE_CODE (length) == PARM_DECL);
2362 DECL_CONTEXT (length) = fndecl;
2363 DECL_ARG_TYPE (length) = len_type;
2364 TREE_READONLY (length) = 1;
2365 DECL_ARTIFICIAL (length) = 1;
2366 gfc_finish_decl (length);
2367 if (sym->ts.u.cl->backend_decl == NULL
2368 || sym->ts.u.cl->backend_decl == length)
2369 {
2370 gfc_symbol *arg;
2371 tree backend_decl;
2372
2373 if (sym->ts.u.cl->backend_decl == NULL)
2374 {
2375 tree len = build_decl (input_location,
2376 VAR_DECL,
2377 get_identifier ("..__result"),
2378 gfc_charlen_type_node);
2379 DECL_ARTIFICIAL (len) = 1;
2380 TREE_USED (len) = 1;
2381 sym->ts.u.cl->backend_decl = len;
2382 }
2383
2384 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2385 arg = sym->result ? sym->result : sym;
2386 backend_decl = arg->backend_decl;
2387 /* Temporary clear it, so that gfc_sym_type creates complete
2388 type. */
2389 arg->backend_decl = NULL;
2390 type = gfc_sym_type (arg);
2391 arg->backend_decl = backend_decl;
2392 type = build_reference_type (type);
2393 }
2394 }
2395
2396 parm = build_decl (input_location,
2397 PARM_DECL, get_identifier ("__result"), type);
2398
2399 DECL_CONTEXT (parm) = fndecl;
2400 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2401 TREE_READONLY (parm) = 1;
2402 DECL_ARTIFICIAL (parm) = 1;
2403 gfc_finish_decl (parm);
2404
2405 arglist = chainon (arglist, parm);
2406 typelist = TREE_CHAIN (typelist);
2407
2408 if (sym->ts.type == BT_CHARACTER)
2409 {
2410 gfc_allocate_lang_decl (parm);
2411 arglist = chainon (arglist, length);
2412 typelist = TREE_CHAIN (typelist);
2413 }
2414 }
2415
2416 hidden_typelist = typelist;
2417 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2418 if (f->sym != NULL) /* Ignore alternate returns. */
2419 hidden_typelist = TREE_CHAIN (hidden_typelist);
2420
2421 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2422 {
2423 char name[GFC_MAX_SYMBOL_LEN + 2];
2424
2425 /* Ignore alternate returns. */
2426 if (f->sym == NULL)
2427 continue;
2428
2429 type = TREE_VALUE (typelist);
2430
2431 if (f->sym->ts.type == BT_CHARACTER
2432 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2433 {
2434 tree len_type = TREE_VALUE (hidden_typelist);
2435 tree length = NULL_TREE;
2436 if (!f->sym->ts.deferred)
2437 gcc_assert (len_type == gfc_charlen_type_node);
2438 else
2439 gcc_assert (POINTER_TYPE_P (len_type));
2440
2441 strcpy (&name[1], f->sym->name);
2442 name[0] = '_';
2443 length = build_decl (input_location,
2444 PARM_DECL, get_identifier (name), len_type);
2445
2446 hidden_arglist = chainon (hidden_arglist, length);
2447 DECL_CONTEXT (length) = fndecl;
2448 DECL_ARTIFICIAL (length) = 1;
2449 DECL_ARG_TYPE (length) = len_type;
2450 TREE_READONLY (length) = 1;
2451 gfc_finish_decl (length);
2452
2453 /* Remember the passed value. */
2454 if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2455 {
2456 /* This can happen if the same type is used for multiple
2457 arguments. We need to copy cl as otherwise
2458 cl->passed_length gets overwritten. */
2459 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2460 }
2461 f->sym->ts.u.cl->passed_length = length;
2462
2463 /* Use the passed value for assumed length variables. */
2464 if (!f->sym->ts.u.cl->length)
2465 {
2466 TREE_USED (length) = 1;
2467 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2468 f->sym->ts.u.cl->backend_decl = length;
2469 }
2470
2471 hidden_typelist = TREE_CHAIN (hidden_typelist);
2472
2473 if (f->sym->ts.u.cl->backend_decl == NULL
2474 || f->sym->ts.u.cl->backend_decl == length)
2475 {
2476 if (POINTER_TYPE_P (len_type))
2477 f->sym->ts.u.cl->backend_decl =
2478 build_fold_indirect_ref_loc (input_location, length);
2479 else if (f->sym->ts.u.cl->backend_decl == NULL)
2480 gfc_create_string_length (f->sym);
2481
2482 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2483 if (f->sym->attr.flavor == FL_PROCEDURE)
2484 type = build_pointer_type (gfc_get_function_type (f->sym));
2485 else
2486 type = gfc_sym_type (f->sym);
2487 }
2488 }
2489 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2490 hence, the optional status cannot be transferred via a NULL pointer.
2491 Thus, we will use a hidden argument in that case. */
2492 else if (f->sym->attr.optional && f->sym->attr.value
2493 && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2494 && !gfc_bt_struct (f->sym->ts.type))
2495 {
2496 tree tmp;
2497 strcpy (&name[1], f->sym->name);
2498 name[0] = '_';
2499 tmp = build_decl (input_location,
2500 PARM_DECL, get_identifier (name),
2501 boolean_type_node);
2502
2503 hidden_arglist = chainon (hidden_arglist, tmp);
2504 DECL_CONTEXT (tmp) = fndecl;
2505 DECL_ARTIFICIAL (tmp) = 1;
2506 DECL_ARG_TYPE (tmp) = boolean_type_node;
2507 TREE_READONLY (tmp) = 1;
2508 gfc_finish_decl (tmp);
2509 }
2510
2511 /* For non-constant length array arguments, make sure they use
2512 a different type node from TYPE_ARG_TYPES type. */
2513 if (f->sym->attr.dimension
2514 && type == TREE_VALUE (typelist)
2515 && TREE_CODE (type) == POINTER_TYPE
2516 && GFC_ARRAY_TYPE_P (type)
2517 && f->sym->as->type != AS_ASSUMED_SIZE
2518 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2519 {
2520 if (f->sym->attr.flavor == FL_PROCEDURE)
2521 type = build_pointer_type (gfc_get_function_type (f->sym));
2522 else
2523 type = gfc_sym_type (f->sym);
2524 }
2525
2526 if (f->sym->attr.proc_pointer)
2527 type = build_pointer_type (type);
2528
2529 if (f->sym->attr.volatile_)
2530 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2531
2532 /* Build the argument declaration. */
2533 parm = build_decl (input_location,
2534 PARM_DECL, gfc_sym_identifier (f->sym), type);
2535
2536 if (f->sym->attr.volatile_)
2537 {
2538 TREE_THIS_VOLATILE (parm) = 1;
2539 TREE_SIDE_EFFECTS (parm) = 1;
2540 }
2541
2542 /* Fill in arg stuff. */
2543 DECL_CONTEXT (parm) = fndecl;
2544 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2545 /* All implementation args except for VALUE are read-only. */
2546 if (!f->sym->attr.value)
2547 TREE_READONLY (parm) = 1;
2548 if (POINTER_TYPE_P (type)
2549 && (!f->sym->attr.proc_pointer
2550 && f->sym->attr.flavor != FL_PROCEDURE))
2551 DECL_BY_REFERENCE (parm) = 1;
2552
2553 gfc_finish_decl (parm);
2554 gfc_finish_decl_attrs (parm, &f->sym->attr);
2555
2556 f->sym->backend_decl = parm;
2557
2558 /* Coarrays which are descriptorless or assumed-shape pass with
2559 -fcoarray=lib the token and the offset as hidden arguments. */
2560 if (flag_coarray == GFC_FCOARRAY_LIB
2561 && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
2562 && !f->sym->attr.allocatable)
2563 || (f->sym->ts.type == BT_CLASS
2564 && CLASS_DATA (f->sym)->attr.codimension
2565 && !CLASS_DATA (f->sym)->attr.allocatable)))
2566 {
2567 tree caf_type;
2568 tree token;
2569 tree offset;
2570
2571 gcc_assert (f->sym->backend_decl != NULL_TREE
2572 && !sym->attr.is_bind_c);
2573 caf_type = f->sym->ts.type == BT_CLASS
2574 ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
2575 : TREE_TYPE (f->sym->backend_decl);
2576
2577 token = build_decl (input_location, PARM_DECL,
2578 create_tmp_var_name ("caf_token"),
2579 build_qualified_type (pvoid_type_node,
2580 TYPE_QUAL_RESTRICT));
2581 if ((f->sym->ts.type != BT_CLASS
2582 && f->sym->as->type != AS_DEFERRED)
2583 || (f->sym->ts.type == BT_CLASS
2584 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2585 {
2586 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2587 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2588 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2589 gfc_allocate_lang_decl (f->sym->backend_decl);
2590 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2591 }
2592 else
2593 {
2594 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2595 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2596 }
2597
2598 DECL_CONTEXT (token) = fndecl;
2599 DECL_ARTIFICIAL (token) = 1;
2600 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2601 TREE_READONLY (token) = 1;
2602 hidden_arglist = chainon (hidden_arglist, token);
2603 gfc_finish_decl (token);
2604
2605 offset = build_decl (input_location, PARM_DECL,
2606 create_tmp_var_name ("caf_offset"),
2607 gfc_array_index_type);
2608
2609 if ((f->sym->ts.type != BT_CLASS
2610 && f->sym->as->type != AS_DEFERRED)
2611 || (f->sym->ts.type == BT_CLASS
2612 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2613 {
2614 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2615 == NULL_TREE);
2616 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2617 }
2618 else
2619 {
2620 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2621 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2622 }
2623 DECL_CONTEXT (offset) = fndecl;
2624 DECL_ARTIFICIAL (offset) = 1;
2625 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2626 TREE_READONLY (offset) = 1;
2627 hidden_arglist = chainon (hidden_arglist, offset);
2628 gfc_finish_decl (offset);
2629 }
2630
2631 arglist = chainon (arglist, parm);
2632 typelist = TREE_CHAIN (typelist);
2633 }
2634
2635 /* Add the hidden string length parameters, unless the procedure
2636 is bind(C). */
2637 if (!sym->attr.is_bind_c)
2638 arglist = chainon (arglist, hidden_arglist);
2639
2640 gcc_assert (hidden_typelist == NULL_TREE
2641 || TREE_VALUE (hidden_typelist) == void_type_node);
2642 DECL_ARGUMENTS (fndecl) = arglist;
2643 }
2644
2645 /* Do the setup necessary before generating the body of a function. */
2646
2647 static void
2648 trans_function_start (gfc_symbol * sym)
2649 {
2650 tree fndecl;
2651
2652 fndecl = sym->backend_decl;
2653
2654 /* Let GCC know the current scope is this function. */
2655 current_function_decl = fndecl;
2656
2657 /* Let the world know what we're about to do. */
2658 announce_function (fndecl);
2659
2660 if (DECL_FILE_SCOPE_P (fndecl))
2661 {
2662 /* Create RTL for function declaration. */
2663 rest_of_decl_compilation (fndecl, 1, 0);
2664 }
2665
2666 /* Create RTL for function definition. */
2667 make_decl_rtl (fndecl);
2668
2669 allocate_struct_function (fndecl, false);
2670
2671 /* function.c requires a push at the start of the function. */
2672 pushlevel ();
2673 }
2674
2675 /* Create thunks for alternate entry points. */
2676
2677 static void
2678 build_entry_thunks (gfc_namespace * ns, bool global)
2679 {
2680 gfc_formal_arglist *formal;
2681 gfc_formal_arglist *thunk_formal;
2682 gfc_entry_list *el;
2683 gfc_symbol *thunk_sym;
2684 stmtblock_t body;
2685 tree thunk_fndecl;
2686 tree tmp;
2687 locus old_loc;
2688
2689 /* This should always be a toplevel function. */
2690 gcc_assert (current_function_decl == NULL_TREE);
2691
2692 gfc_save_backend_locus (&old_loc);
2693 for (el = ns->entries; el; el = el->next)
2694 {
2695 vec<tree, va_gc> *args = NULL;
2696 vec<tree, va_gc> *string_args = NULL;
2697
2698 thunk_sym = el->sym;
2699
2700 build_function_decl (thunk_sym, global);
2701 create_function_arglist (thunk_sym);
2702
2703 trans_function_start (thunk_sym);
2704
2705 thunk_fndecl = thunk_sym->backend_decl;
2706
2707 gfc_init_block (&body);
2708
2709 /* Pass extra parameter identifying this entry point. */
2710 tmp = build_int_cst (gfc_array_index_type, el->id);
2711 vec_safe_push (args, tmp);
2712
2713 if (thunk_sym->attr.function)
2714 {
2715 if (gfc_return_by_reference (ns->proc_name))
2716 {
2717 tree ref = DECL_ARGUMENTS (current_function_decl);
2718 vec_safe_push (args, ref);
2719 if (ns->proc_name->ts.type == BT_CHARACTER)
2720 vec_safe_push (args, DECL_CHAIN (ref));
2721 }
2722 }
2723
2724 for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
2725 formal = formal->next)
2726 {
2727 /* Ignore alternate returns. */
2728 if (formal->sym == NULL)
2729 continue;
2730
2731 /* We don't have a clever way of identifying arguments, so resort to
2732 a brute-force search. */
2733 for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
2734 thunk_formal;
2735 thunk_formal = thunk_formal->next)
2736 {
2737 if (thunk_formal->sym == formal->sym)
2738 break;
2739 }
2740
2741 if (thunk_formal)
2742 {
2743 /* Pass the argument. */
2744 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2745 vec_safe_push (args, thunk_formal->sym->backend_decl);
2746 if (formal->sym->ts.type == BT_CHARACTER)
2747 {
2748 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2749 vec_safe_push (string_args, tmp);
2750 }
2751 }
2752 else
2753 {
2754 /* Pass NULL for a missing argument. */
2755 vec_safe_push (args, null_pointer_node);
2756 if (formal->sym->ts.type == BT_CHARACTER)
2757 {
2758 tmp = build_int_cst (gfc_charlen_type_node, 0);
2759 vec_safe_push (string_args, tmp);
2760 }
2761 }
2762 }
2763
2764 /* Call the master function. */
2765 vec_safe_splice (args, string_args);
2766 tmp = ns->proc_name->backend_decl;
2767 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2768 if (ns->proc_name->attr.mixed_entry_master)
2769 {
2770 tree union_decl, field;
2771 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2772
2773 union_decl = build_decl (input_location,
2774 VAR_DECL, get_identifier ("__result"),
2775 TREE_TYPE (master_type));
2776 DECL_ARTIFICIAL (union_decl) = 1;
2777 DECL_EXTERNAL (union_decl) = 0;
2778 TREE_PUBLIC (union_decl) = 0;
2779 TREE_USED (union_decl) = 1;
2780 layout_decl (union_decl, 0);
2781 pushdecl (union_decl);
2782
2783 DECL_CONTEXT (union_decl) = current_function_decl;
2784 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2785 TREE_TYPE (union_decl), union_decl, tmp);
2786 gfc_add_expr_to_block (&body, tmp);
2787
2788 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2789 field; field = DECL_CHAIN (field))
2790 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2791 thunk_sym->result->name) == 0)
2792 break;
2793 gcc_assert (field != NULL_TREE);
2794 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2795 TREE_TYPE (field), union_decl, field,
2796 NULL_TREE);
2797 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2798 TREE_TYPE (DECL_RESULT (current_function_decl)),
2799 DECL_RESULT (current_function_decl), tmp);
2800 tmp = build1_v (RETURN_EXPR, tmp);
2801 }
2802 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2803 != void_type_node)
2804 {
2805 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2806 TREE_TYPE (DECL_RESULT (current_function_decl)),
2807 DECL_RESULT (current_function_decl), tmp);
2808 tmp = build1_v (RETURN_EXPR, tmp);
2809 }
2810 gfc_add_expr_to_block (&body, tmp);
2811
2812 /* Finish off this function and send it for code generation. */
2813 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2814 tmp = getdecls ();
2815 poplevel (1, 1);
2816 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2817 DECL_SAVED_TREE (thunk_fndecl)
2818 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2819 DECL_INITIAL (thunk_fndecl));
2820
2821 /* Output the GENERIC tree. */
2822 dump_function (TDI_original, thunk_fndecl);
2823
2824 /* Store the end of the function, so that we get good line number
2825 info for the epilogue. */
2826 cfun->function_end_locus = input_location;
2827
2828 /* We're leaving the context of this function, so zap cfun.
2829 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2830 tree_rest_of_compilation. */
2831 set_cfun (NULL);
2832
2833 current_function_decl = NULL_TREE;
2834
2835 cgraph_node::finalize_function (thunk_fndecl, true);
2836
2837 /* We share the symbols in the formal argument list with other entry
2838 points and the master function. Clear them so that they are
2839 recreated for each function. */
2840 for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
2841 formal = formal->next)
2842 if (formal->sym != NULL) /* Ignore alternate returns. */
2843 {
2844 formal->sym->backend_decl = NULL_TREE;
2845 if (formal->sym->ts.type == BT_CHARACTER)
2846 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2847 }
2848
2849 if (thunk_sym->attr.function)
2850 {
2851 if (thunk_sym->ts.type == BT_CHARACTER)
2852 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2853 if (thunk_sym->result->ts.type == BT_CHARACTER)
2854 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2855 }
2856 }
2857
2858 gfc_restore_backend_locus (&old_loc);
2859 }
2860
2861
2862 /* Create a decl for a function, and create any thunks for alternate entry
2863 points. If global is true, generate the function in the global binding
2864 level, otherwise in the current binding level (which can be global). */
2865
2866 void
2867 gfc_create_function_decl (gfc_namespace * ns, bool global)
2868 {
2869 /* Create a declaration for the master function. */
2870 build_function_decl (ns->proc_name, global);
2871
2872 /* Compile the entry thunks. */
2873 if (ns->entries)
2874 build_entry_thunks (ns, global);
2875
2876 /* Now create the read argument list. */
2877 create_function_arglist (ns->proc_name);
2878
2879 if (ns->omp_declare_simd)
2880 gfc_trans_omp_declare_simd (ns);
2881 }
2882
2883 /* Return the decl used to hold the function return value. If
2884 parent_flag is set, the context is the parent_scope. */
2885
2886 tree
2887 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2888 {
2889 tree decl;
2890 tree length;
2891 tree this_fake_result_decl;
2892 tree this_function_decl;
2893
2894 char name[GFC_MAX_SYMBOL_LEN + 10];
2895
2896 if (parent_flag)
2897 {
2898 this_fake_result_decl = parent_fake_result_decl;
2899 this_function_decl = DECL_CONTEXT (current_function_decl);
2900 }
2901 else
2902 {
2903 this_fake_result_decl = current_fake_result_decl;
2904 this_function_decl = current_function_decl;
2905 }
2906
2907 if (sym
2908 && sym->ns->proc_name->backend_decl == this_function_decl
2909 && sym->ns->proc_name->attr.entry_master
2910 && sym != sym->ns->proc_name)
2911 {
2912 tree t = NULL, var;
2913 if (this_fake_result_decl != NULL)
2914 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2915 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2916 break;
2917 if (t)
2918 return TREE_VALUE (t);
2919 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2920
2921 if (parent_flag)
2922 this_fake_result_decl = parent_fake_result_decl;
2923 else
2924 this_fake_result_decl = current_fake_result_decl;
2925
2926 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2927 {
2928 tree field;
2929
2930 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2931 field; field = DECL_CHAIN (field))
2932 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2933 sym->name) == 0)
2934 break;
2935
2936 gcc_assert (field != NULL_TREE);
2937 decl = fold_build3_loc (input_location, COMPONENT_REF,
2938 TREE_TYPE (field), decl, field, NULL_TREE);
2939 }
2940
2941 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2942 if (parent_flag)
2943 gfc_add_decl_to_parent_function (var);
2944 else
2945 gfc_add_decl_to_function (var);
2946
2947 SET_DECL_VALUE_EXPR (var, decl);
2948 DECL_HAS_VALUE_EXPR_P (var) = 1;
2949 GFC_DECL_RESULT (var) = 1;
2950
2951 TREE_CHAIN (this_fake_result_decl)
2952 = tree_cons (get_identifier (sym->name), var,
2953 TREE_CHAIN (this_fake_result_decl));
2954 return var;
2955 }
2956
2957 if (this_fake_result_decl != NULL_TREE)
2958 return TREE_VALUE (this_fake_result_decl);
2959
2960 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2961 sym is NULL. */
2962 if (!sym)
2963 return NULL_TREE;
2964
2965 if (sym->ts.type == BT_CHARACTER)
2966 {
2967 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2968 length = gfc_create_string_length (sym);
2969 else
2970 length = sym->ts.u.cl->backend_decl;
2971 if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE)
2972 gfc_add_decl_to_function (length);
2973 }
2974
2975 if (gfc_return_by_reference (sym))
2976 {
2977 decl = DECL_ARGUMENTS (this_function_decl);
2978
2979 if (sym->ns->proc_name->backend_decl == this_function_decl
2980 && sym->ns->proc_name->attr.entry_master)
2981 decl = DECL_CHAIN (decl);
2982
2983 TREE_USED (decl) = 1;
2984 if (sym->as)
2985 decl = gfc_build_dummy_array_decl (sym, decl);
2986 }
2987 else
2988 {
2989 sprintf (name, "__result_%.20s",
2990 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2991
2992 if (!sym->attr.mixed_entry_master && sym->attr.function)
2993 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2994 VAR_DECL, get_identifier (name),
2995 gfc_sym_type (sym));
2996 else
2997 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2998 VAR_DECL, get_identifier (name),
2999 TREE_TYPE (TREE_TYPE (this_function_decl)));
3000 DECL_ARTIFICIAL (decl) = 1;
3001 DECL_EXTERNAL (decl) = 0;
3002 TREE_PUBLIC (decl) = 0;
3003 TREE_USED (decl) = 1;
3004 GFC_DECL_RESULT (decl) = 1;
3005 TREE_ADDRESSABLE (decl) = 1;
3006
3007 layout_decl (decl, 0);
3008 gfc_finish_decl_attrs (decl, &sym->attr);
3009
3010 if (parent_flag)
3011 gfc_add_decl_to_parent_function (decl);
3012 else
3013 gfc_add_decl_to_function (decl);
3014 }
3015
3016 if (parent_flag)
3017 parent_fake_result_decl = build_tree_list (NULL, decl);
3018 else
3019 current_fake_result_decl = build_tree_list (NULL, decl);
3020
3021 return decl;
3022 }
3023
3024
3025 /* Builds a function decl. The remaining parameters are the types of the
3026 function arguments. Negative nargs indicates a varargs function. */
3027
3028 static tree
3029 build_library_function_decl_1 (tree name, const char *spec,
3030 tree rettype, int nargs, va_list p)
3031 {
3032 vec<tree, va_gc> *arglist;
3033 tree fntype;
3034 tree fndecl;
3035 int n;
3036
3037 /* Library functions must be declared with global scope. */
3038 gcc_assert (current_function_decl == NULL_TREE);
3039
3040 /* Create a list of the argument types. */
3041 vec_alloc (arglist, abs (nargs));
3042 for (n = abs (nargs); n > 0; n--)
3043 {
3044 tree argtype = va_arg (p, tree);
3045 arglist->quick_push (argtype);
3046 }
3047
3048 /* Build the function type and decl. */
3049 if (nargs >= 0)
3050 fntype = build_function_type_vec (rettype, arglist);
3051 else
3052 fntype = build_varargs_function_type_vec (rettype, arglist);
3053 if (spec)
3054 {
3055 tree attr_args = build_tree_list (NULL_TREE,
3056 build_string (strlen (spec), spec));
3057 tree attrs = tree_cons (get_identifier ("fn spec"),
3058 attr_args, TYPE_ATTRIBUTES (fntype));
3059 fntype = build_type_attribute_variant (fntype, attrs);
3060 }
3061 fndecl = build_decl (input_location,
3062 FUNCTION_DECL, name, fntype);
3063
3064 /* Mark this decl as external. */
3065 DECL_EXTERNAL (fndecl) = 1;
3066 TREE_PUBLIC (fndecl) = 1;
3067
3068 pushdecl (fndecl);
3069
3070 rest_of_decl_compilation (fndecl, 1, 0);
3071
3072 return fndecl;
3073 }
3074
3075 /* Builds a function decl. The remaining parameters are the types of the
3076 function arguments. Negative nargs indicates a varargs function. */
3077
3078 tree
3079 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
3080 {
3081 tree ret;
3082 va_list args;
3083 va_start (args, nargs);
3084 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
3085 va_end (args);
3086 return ret;
3087 }
3088
3089 /* Builds a function decl. The remaining parameters are the types of the
3090 function arguments. Negative nargs indicates a varargs function.
3091 The SPEC parameter specifies the function argument and return type
3092 specification according to the fnspec function type attribute. */
3093
3094 tree
3095 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
3096 tree rettype, int nargs, ...)
3097 {
3098 tree ret;
3099 va_list args;
3100 va_start (args, nargs);
3101 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
3102 va_end (args);
3103 return ret;
3104 }
3105
3106 static void
3107 gfc_build_intrinsic_function_decls (void)
3108 {
3109 tree gfc_int4_type_node = gfc_get_int_type (4);
3110 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
3111 tree gfc_int8_type_node = gfc_get_int_type (8);
3112 tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
3113 tree gfc_int16_type_node = gfc_get_int_type (16);
3114 tree gfc_logical4_type_node = gfc_get_logical_type (4);
3115 tree pchar1_type_node = gfc_get_pchar_type (1);
3116 tree pchar4_type_node = gfc_get_pchar_type (4);
3117
3118 /* String functions. */
3119 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
3120 get_identifier (PREFIX("compare_string")), "..R.R",
3121 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
3122 gfc_charlen_type_node, pchar1_type_node);
3123 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
3124 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
3125
3126 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
3127 get_identifier (PREFIX("concat_string")), "..W.R.R",
3128 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
3129 gfc_charlen_type_node, pchar1_type_node,
3130 gfc_charlen_type_node, pchar1_type_node);
3131 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
3132
3133 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
3134 get_identifier (PREFIX("string_len_trim")), "..R",
3135 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
3136 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
3137 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
3138
3139 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
3140 get_identifier (PREFIX("string_index")), "..R.R.",
3141 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3142 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3143 DECL_PURE_P (gfor_fndecl_string_index) = 1;
3144 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
3145
3146 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
3147 get_identifier (PREFIX("string_scan")), "..R.R.",
3148 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3149 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3150 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
3151 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
3152
3153 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
3154 get_identifier (PREFIX("string_verify")), "..R.R.",
3155 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3156 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3157 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
3158 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
3159
3160 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
3161 get_identifier (PREFIX("string_trim")), ".Ww.R",
3162 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3163 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
3164 pchar1_type_node);
3165
3166 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
3167 get_identifier (PREFIX("string_minmax")), ".Ww.R",
3168 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3169 build_pointer_type (pchar1_type_node), integer_type_node,
3170 integer_type_node);
3171
3172 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
3173 get_identifier (PREFIX("adjustl")), ".W.R",
3174 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3175 pchar1_type_node);
3176 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
3177
3178 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
3179 get_identifier (PREFIX("adjustr")), ".W.R",
3180 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3181 pchar1_type_node);
3182 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
3183
3184 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
3185 get_identifier (PREFIX("select_string")), ".R.R.",
3186 integer_type_node, 4, pvoid_type_node, integer_type_node,
3187 pchar1_type_node, gfc_charlen_type_node);
3188 DECL_PURE_P (gfor_fndecl_select_string) = 1;
3189 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
3190
3191 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
3192 get_identifier (PREFIX("compare_string_char4")), "..R.R",
3193 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
3194 gfc_charlen_type_node, pchar4_type_node);
3195 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
3196 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
3197
3198 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
3199 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
3200 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
3201 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
3202 pchar4_type_node);
3203 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
3204
3205 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
3206 get_identifier (PREFIX("string_len_trim_char4")), "..R",
3207 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
3208 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
3209 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
3210
3211 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
3212 get_identifier (PREFIX("string_index_char4")), "..R.R.",
3213 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3214 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3215 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
3216 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
3217
3218 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
3219 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
3220 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3221 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3222 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
3223 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
3224
3225 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
3226 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
3227 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3228 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3229 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
3230 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
3231
3232 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
3233 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
3234 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3235 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
3236 pchar4_type_node);
3237
3238 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
3239 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
3240 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3241 build_pointer_type (pchar4_type_node), integer_type_node,
3242 integer_type_node);
3243
3244 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
3245 get_identifier (PREFIX("adjustl_char4")), ".W.R",
3246 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3247 pchar4_type_node);
3248 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
3249
3250 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
3251 get_identifier (PREFIX("adjustr_char4")), ".W.R",
3252 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3253 pchar4_type_node);
3254 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
3255
3256 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
3257 get_identifier (PREFIX("select_string_char4")), ".R.R.",
3258 integer_type_node, 4, pvoid_type_node, integer_type_node,
3259 pvoid_type_node, gfc_charlen_type_node);
3260 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
3261 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
3262
3263
3264 /* Conversion between character kinds. */
3265
3266 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
3267 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
3268 void_type_node, 3, build_pointer_type (pchar4_type_node),
3269 gfc_charlen_type_node, pchar1_type_node);
3270
3271 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
3272 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
3273 void_type_node, 3, build_pointer_type (pchar1_type_node),
3274 gfc_charlen_type_node, pchar4_type_node);
3275
3276 /* Misc. functions. */
3277
3278 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
3279 get_identifier (PREFIX("ttynam")), ".W",
3280 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3281 integer_type_node);
3282
3283 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
3284 get_identifier (PREFIX("fdate")), ".W",
3285 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
3286
3287 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3288 get_identifier (PREFIX("ctime")), ".W",
3289 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3290 gfc_int8_type_node);
3291
3292 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3293 get_identifier (PREFIX("selected_char_kind")), "..R",
3294 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
3295 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3296 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3297
3298 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
3299 get_identifier (PREFIX("selected_int_kind")), ".R",
3300 gfc_int4_type_node, 1, pvoid_type_node);
3301 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
3302 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
3303
3304 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
3305 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
3306 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
3307 pvoid_type_node);
3308 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
3309 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
3310
3311 gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
3312 get_identifier (PREFIX("system_clock_4")),
3313 void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
3314 gfc_pint4_type_node);
3315
3316 gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
3317 get_identifier (PREFIX("system_clock_8")),
3318 void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
3319 gfc_pint8_type_node);
3320
3321 /* Power functions. */
3322 {
3323 tree ctype, rtype, itype, jtype;
3324 int rkind, ikind, jkind;
3325 #define NIKINDS 3
3326 #define NRKINDS 4
3327 static int ikinds[NIKINDS] = {4, 8, 16};
3328 static int rkinds[NRKINDS] = {4, 8, 10, 16};
3329 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
3330
3331 for (ikind=0; ikind < NIKINDS; ikind++)
3332 {
3333 itype = gfc_get_int_type (ikinds[ikind]);
3334
3335 for (jkind=0; jkind < NIKINDS; jkind++)
3336 {
3337 jtype = gfc_get_int_type (ikinds[jkind]);
3338 if (itype && jtype)
3339 {
3340 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3341 ikinds[jkind]);
3342 gfor_fndecl_math_powi[jkind][ikind].integer =
3343 gfc_build_library_function_decl (get_identifier (name),
3344 jtype, 2, jtype, itype);
3345 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3346 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3347 }
3348 }
3349
3350 for (rkind = 0; rkind < NRKINDS; rkind ++)
3351 {
3352 rtype = gfc_get_real_type (rkinds[rkind]);
3353 if (rtype && itype)
3354 {
3355 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
3356 ikinds[ikind]);
3357 gfor_fndecl_math_powi[rkind][ikind].real =
3358 gfc_build_library_function_decl (get_identifier (name),
3359 rtype, 2, rtype, itype);
3360 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3361 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3362 }
3363
3364 ctype = gfc_get_complex_type (rkinds[rkind]);
3365 if (ctype && itype)
3366 {
3367 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
3368 ikinds[ikind]);
3369 gfor_fndecl_math_powi[rkind][ikind].cmplx =
3370 gfc_build_library_function_decl (get_identifier (name),
3371 ctype, 2,ctype, itype);
3372 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3373 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3374 }
3375 }
3376 }
3377 #undef NIKINDS
3378 #undef NRKINDS
3379 }
3380
3381 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
3382 get_identifier (PREFIX("ishftc4")),
3383 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
3384 gfc_int4_type_node);
3385 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
3386 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
3387
3388 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
3389 get_identifier (PREFIX("ishftc8")),
3390 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
3391 gfc_int4_type_node);
3392 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3393 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3394
3395 if (gfc_int16_type_node)
3396 {
3397 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3398 get_identifier (PREFIX("ishftc16")),
3399 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
3400 gfc_int4_type_node);
3401 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3402 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3403 }
3404
3405 /* BLAS functions. */
3406 {
3407 tree pint = build_pointer_type (integer_type_node);
3408 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3409 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3410 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3411 tree pz = build_pointer_type
3412 (gfc_get_complex_type (gfc_default_double_kind));
3413
3414 gfor_fndecl_sgemm = gfc_build_library_function_decl
3415 (get_identifier
3416 (flag_underscoring ? "sgemm_" : "sgemm"),
3417 void_type_node, 15, pchar_type_node,
3418 pchar_type_node, pint, pint, pint, ps, ps, pint,
3419 ps, pint, ps, ps, pint, integer_type_node,
3420 integer_type_node);
3421 gfor_fndecl_dgemm = gfc_build_library_function_decl
3422 (get_identifier
3423 (flag_underscoring ? "dgemm_" : "dgemm"),
3424 void_type_node, 15, pchar_type_node,
3425 pchar_type_node, pint, pint, pint, pd, pd, pint,
3426 pd, pint, pd, pd, pint, integer_type_node,
3427 integer_type_node);
3428 gfor_fndecl_cgemm = gfc_build_library_function_decl
3429 (get_identifier
3430 (flag_underscoring ? "cgemm_" : "cgemm"),
3431 void_type_node, 15, pchar_type_node,
3432 pchar_type_node, pint, pint, pint, pc, pc, pint,
3433 pc, pint, pc, pc, pint, integer_type_node,
3434 integer_type_node);
3435 gfor_fndecl_zgemm = gfc_build_library_function_decl
3436 (get_identifier
3437 (flag_underscoring ? "zgemm_" : "zgemm"),
3438 void_type_node, 15, pchar_type_node,
3439 pchar_type_node, pint, pint, pint, pz, pz, pint,
3440 pz, pint, pz, pz, pint, integer_type_node,
3441 integer_type_node);
3442 }
3443
3444 /* Other functions. */
3445 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3446 get_identifier (PREFIX("size0")), ".R",
3447 gfc_array_index_type, 1, pvoid_type_node);
3448 DECL_PURE_P (gfor_fndecl_size0) = 1;
3449 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3450
3451 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3452 get_identifier (PREFIX("size1")), ".R",
3453 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3454 DECL_PURE_P (gfor_fndecl_size1) = 1;
3455 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3456
3457 gfor_fndecl_iargc = gfc_build_library_function_decl (
3458 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3459 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3460 }
3461
3462
3463 /* Make prototypes for runtime library functions. */
3464
3465 void
3466 gfc_build_builtin_function_decls (void)
3467 {
3468 tree gfc_int4_type_node = gfc_get_int_type (4);
3469
3470 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3471 get_identifier (PREFIX("stop_numeric")),
3472 void_type_node, 1, gfc_int4_type_node);
3473 /* STOP doesn't return. */
3474 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3475
3476 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3477 get_identifier (PREFIX("stop_string")), ".R.",
3478 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3479 /* STOP doesn't return. */
3480 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3481
3482 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3483 get_identifier (PREFIX("error_stop_numeric")),
3484 void_type_node, 1, gfc_int4_type_node);
3485 /* ERROR STOP doesn't return. */
3486 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3487
3488 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3489 get_identifier (PREFIX("error_stop_string")), ".R.",
3490 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3491 /* ERROR STOP doesn't return. */
3492 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3493
3494 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3495 get_identifier (PREFIX("pause_numeric")),
3496 void_type_node, 1, gfc_int4_type_node);
3497
3498 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3499 get_identifier (PREFIX("pause_string")), ".R.",
3500 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3501
3502 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3503 get_identifier (PREFIX("runtime_error")), ".R",
3504 void_type_node, -1, pchar_type_node);
3505 /* The runtime_error function does not return. */
3506 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3507
3508 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3509 get_identifier (PREFIX("runtime_error_at")), ".RR",
3510 void_type_node, -2, pchar_type_node, pchar_type_node);
3511 /* The runtime_error_at function does not return. */
3512 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3513
3514 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3515 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3516 void_type_node, -2, pchar_type_node, pchar_type_node);
3517
3518 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3519 get_identifier (PREFIX("generate_error")), ".R.R",
3520 void_type_node, 3, pvoid_type_node, integer_type_node,
3521 pchar_type_node);
3522
3523 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3524 get_identifier (PREFIX("os_error")), ".R",
3525 void_type_node, 1, pchar_type_node);
3526 /* The runtime_error function does not return. */
3527 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3528
3529 gfor_fndecl_set_args = gfc_build_library_function_decl (
3530 get_identifier (PREFIX("set_args")),
3531 void_type_node, 2, integer_type_node,
3532 build_pointer_type (pchar_type_node));
3533
3534 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3535 get_identifier (PREFIX("set_fpe")),
3536 void_type_node, 1, integer_type_node);
3537
3538 gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
3539 get_identifier (PREFIX("ieee_procedure_entry")),
3540 void_type_node, 1, pvoid_type_node);
3541
3542 gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
3543 get_identifier (PREFIX("ieee_procedure_exit")),
3544 void_type_node, 1, pvoid_type_node);
3545
3546 /* Keep the array dimension in sync with the call, later in this file. */
3547 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3548 get_identifier (PREFIX("set_options")), "..R",
3549 void_type_node, 2, integer_type_node,
3550 build_pointer_type (integer_type_node));
3551
3552 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3553 get_identifier (PREFIX("set_convert")),
3554 void_type_node, 1, integer_type_node);
3555
3556 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3557 get_identifier (PREFIX("set_record_marker")),
3558 void_type_node, 1, integer_type_node);
3559
3560 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3561 get_identifier (PREFIX("set_max_subrecord_length")),
3562 void_type_node, 1, integer_type_node);
3563
3564 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3565 get_identifier (PREFIX("internal_pack")), ".r",
3566 pvoid_type_node, 1, pvoid_type_node);
3567
3568 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3569 get_identifier (PREFIX("internal_unpack")), ".wR",
3570 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3571
3572 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3573 get_identifier (PREFIX("associated")), ".RR",
3574 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3575 DECL_PURE_P (gfor_fndecl_associated) = 1;
3576 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3577
3578 /* Coarray library calls. */
3579 if (flag_coarray == GFC_FCOARRAY_LIB)
3580 {
3581 tree pint_type, pppchar_type;
3582
3583 pint_type = build_pointer_type (integer_type_node);
3584 pppchar_type
3585 = build_pointer_type (build_pointer_type (pchar_type_node));
3586
3587 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3588 get_identifier (PREFIX("caf_init")), void_type_node,
3589 2, pint_type, pppchar_type);
3590
3591 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3592 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3593
3594 gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
3595 get_identifier (PREFIX("caf_this_image")), integer_type_node,
3596 1, integer_type_node);
3597
3598 gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
3599 get_identifier (PREFIX("caf_num_images")), integer_type_node,
3600 2, integer_type_node, integer_type_node);
3601
3602 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3603 get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7,
3604 size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
3605 pint_type, pchar_type_node, integer_type_node);
3606
3607 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3608 get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5,
3609 ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
3610 integer_type_node);
3611
3612 gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
3613 get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10,
3614 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3615 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3616 boolean_type_node, pint_type);
3617
3618 gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
3619 get_identifier (PREFIX("caf_send")), ".R.RRRRRRW", void_type_node, 10,
3620 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3621 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3622 boolean_type_node, pint_type);
3623
3624 gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
3625 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
3626 void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
3627 pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
3628 integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
3629 integer_type_node, boolean_type_node, integer_type_node);
3630
3631 gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
3632 get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRW", void_type_node,
3633 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node,
3634 integer_type_node, integer_type_node, boolean_type_node,
3635 boolean_type_node, pint_type);
3636
3637 gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
3638 get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRW", void_type_node,
3639 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node,
3640 integer_type_node, integer_type_node, boolean_type_node,
3641 boolean_type_node, pint_type);
3642
3643 gfor_fndecl_caf_sendget_by_ref
3644 = gfc_build_library_function_decl_with_spec (
3645 get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWW",
3646 void_type_node, 11, pvoid_type_node, integer_type_node,
3647 pvoid_type_node, pvoid_type_node, integer_type_node,
3648 pvoid_type_node, integer_type_node, integer_type_node,
3649 boolean_type_node, pint_type, pint_type);
3650
3651 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3652 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3653 3, pint_type, pchar_type_node, integer_type_node);
3654
3655 gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
3656 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node,
3657 3, pint_type, pchar_type_node, integer_type_node);
3658
3659 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3660 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3661 5, integer_type_node, pint_type, pint_type,
3662 pchar_type_node, integer_type_node);
3663
3664 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3665 get_identifier (PREFIX("caf_error_stop")),
3666 void_type_node, 1, gfc_int4_type_node);
3667 /* CAF's ERROR STOP doesn't return. */
3668 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3669
3670 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3671 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3672 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3673 /* CAF's ERROR STOP doesn't return. */
3674 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3675
3676 gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec (
3677 get_identifier (PREFIX("caf_stop_numeric")), ".R.",
3678 void_type_node, 1, gfc_int4_type_node);
3679 /* CAF's STOP doesn't return. */
3680 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
3681
3682 gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
3683 get_identifier (PREFIX("caf_stop_str")), ".R.",
3684 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3685 /* CAF's STOP doesn't return. */
3686 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
3687
3688 gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
3689 get_identifier (PREFIX("caf_atomic_define")), "R..RW",
3690 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3691 pvoid_type_node, pint_type, integer_type_node, integer_type_node);
3692
3693 gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
3694 get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
3695 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3696 pvoid_type_node, pint_type, integer_type_node, integer_type_node);
3697
3698 gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
3699 get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
3700 void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
3701 pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
3702 integer_type_node, integer_type_node);
3703
3704 gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
3705 get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
3706 void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
3707 integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
3708 integer_type_node, integer_type_node);
3709
3710 gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
3711 get_identifier (PREFIX("caf_lock")), "R..WWW",
3712 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3713 pint_type, pint_type, pchar_type_node, integer_type_node);
3714
3715 gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
3716 get_identifier (PREFIX("caf_unlock")), "R..WW",
3717 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3718 pint_type, pchar_type_node, integer_type_node);
3719
3720 gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
3721 get_identifier (PREFIX("caf_event_post")), "R..WW",
3722 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3723 pint_type, pchar_type_node, integer_type_node);
3724
3725 gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
3726 get_identifier (PREFIX("caf_event_wait")), "R..WW",
3727 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3728 pint_type, pchar_type_node, integer_type_node);
3729
3730 gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
3731 get_identifier (PREFIX("caf_event_query")), "R..WW",
3732 void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
3733 pint_type, pint_type);
3734
3735 gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
3736 get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
3737 void_type_node, 5, pvoid_type_node, integer_type_node,
3738 pint_type, pchar_type_node, integer_type_node);
3739
3740 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
3741 get_identifier (PREFIX("caf_co_max")), "W.WW",
3742 void_type_node, 6, pvoid_type_node, integer_type_node,
3743 pint_type, pchar_type_node, integer_type_node, integer_type_node);
3744
3745 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
3746 get_identifier (PREFIX("caf_co_min")), "W.WW",
3747 void_type_node, 6, pvoid_type_node, integer_type_node,
3748 pint_type, pchar_type_node, integer_type_node, integer_type_node);
3749
3750 gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
3751 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
3752 void_type_node, 8, pvoid_type_node,
3753 build_pointer_type (build_varargs_function_type_list (void_type_node,
3754 NULL_TREE)),
3755 integer_type_node, integer_type_node, pint_type, pchar_type_node,
3756 integer_type_node, integer_type_node);
3757
3758 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
3759 get_identifier (PREFIX("caf_co_sum")), "W.WW",
3760 void_type_node, 5, pvoid_type_node, integer_type_node,
3761 pint_type, pchar_type_node, integer_type_node);
3762
3763 gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
3764 get_identifier (PREFIX("caf_is_present")), "RRR",
3765 integer_type_node, 3, pvoid_type_node, integer_type_node,
3766 pvoid_type_node);
3767 }
3768
3769 gfc_build_intrinsic_function_decls ();
3770 gfc_build_intrinsic_lib_fndecls ();
3771 gfc_build_io_library_fndecls ();
3772 }
3773
3774
3775 /* Evaluate the length of dummy character variables. */
3776
3777 static void
3778 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3779 gfc_wrapped_block *block)
3780 {
3781 stmtblock_t init;
3782
3783 gfc_finish_decl (cl->backend_decl);
3784
3785 gfc_start_block (&init);
3786
3787 /* Evaluate the string length expression. */
3788 gfc_conv_string_length (cl, NULL, &init);
3789
3790 gfc_trans_vla_type_sizes (sym, &init);
3791
3792 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3793 }
3794
3795
3796 /* Allocate and cleanup an automatic character variable. */
3797
3798 static void
3799 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3800 {
3801 stmtblock_t init;
3802 tree decl;
3803 tree tmp;
3804
3805 gcc_assert (sym->backend_decl);
3806 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3807
3808 gfc_init_block (&init);
3809
3810 /* Evaluate the string length expression. */
3811 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3812
3813 gfc_trans_vla_type_sizes (sym, &init);
3814
3815 decl = sym->backend_decl;
3816
3817 /* Emit a DECL_EXPR for this variable, which will cause the
3818 gimplifier to allocate storage, and all that good stuff. */
3819 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3820 gfc_add_expr_to_block (&init, tmp);
3821
3822 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3823 }
3824
3825 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3826
3827 static void
3828 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3829 {
3830 stmtblock_t init;
3831
3832 gcc_assert (sym->backend_decl);
3833 gfc_start_block (&init);
3834
3835 /* Set the initial value to length. See the comments in
3836 function gfc_add_assign_aux_vars in this file. */
3837 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3838 build_int_cst (gfc_charlen_type_node, -2));
3839
3840 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3841 }
3842
3843 static void
3844 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3845 {
3846 tree t = *tp, var, val;
3847
3848 if (t == NULL || t == error_mark_node)
3849 return;
3850 if (TREE_CONSTANT (t) || DECL_P (t))
3851 return;
3852
3853 if (TREE_CODE (t) == SAVE_EXPR)
3854 {
3855 if (SAVE_EXPR_RESOLVED_P (t))
3856 {
3857 *tp = TREE_OPERAND (t, 0);
3858 return;
3859 }
3860 val = TREE_OPERAND (t, 0);
3861 }
3862 else
3863 val = t;
3864
3865 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3866 gfc_add_decl_to_function (var);
3867 gfc_add_modify (body, var, unshare_expr (val));
3868 if (TREE_CODE (t) == SAVE_EXPR)
3869 TREE_OPERAND (t, 0) = var;
3870 *tp = var;
3871 }
3872
3873 static void
3874 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3875 {
3876 tree t;
3877
3878 if (type == NULL || type == error_mark_node)
3879 return;
3880
3881 type = TYPE_MAIN_VARIANT (type);
3882
3883 if (TREE_CODE (type) == INTEGER_TYPE)
3884 {
3885 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3886 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3887
3888 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3889 {
3890 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3891 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3892 }
3893 }
3894 else if (TREE_CODE (type) == ARRAY_TYPE)
3895 {
3896 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3897 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3898 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3899 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3900
3901 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3902 {
3903 TYPE_SIZE (t) = TYPE_SIZE (type);
3904 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3905 }
3906 }
3907 }
3908
3909 /* Make sure all type sizes and array domains are either constant,
3910 or variable or parameter decls. This is a simplified variant
3911 of gimplify_type_sizes, but we can't use it here, as none of the
3912 variables in the expressions have been gimplified yet.
3913 As type sizes and domains for various variable length arrays
3914 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3915 time, without this routine gimplify_type_sizes in the middle-end
3916 could result in the type sizes being gimplified earlier than where
3917 those variables are initialized. */
3918
3919 void
3920 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3921 {
3922 tree type = TREE_TYPE (sym->backend_decl);
3923
3924 if (TREE_CODE (type) == FUNCTION_TYPE
3925 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3926 {
3927 if (! current_fake_result_decl)
3928 return;
3929
3930 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3931 }
3932
3933 while (POINTER_TYPE_P (type))
3934 type = TREE_TYPE (type);
3935
3936 if (GFC_DESCRIPTOR_TYPE_P (type))
3937 {
3938 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3939
3940 while (POINTER_TYPE_P (etype))
3941 etype = TREE_TYPE (etype);
3942
3943 gfc_trans_vla_type_sizes_1 (etype, body);
3944 }
3945
3946 gfc_trans_vla_type_sizes_1 (type, body);
3947 }
3948
3949
3950 /* Initialize a derived type by building an lvalue from the symbol
3951 and using trans_assignment to do the work. Set dealloc to false
3952 if no deallocation prior the assignment is needed. */
3953 void
3954 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3955 {
3956 gfc_expr *e;
3957 tree tmp;
3958 tree present;
3959
3960 gcc_assert (block);
3961
3962 gcc_assert (!sym->attr.allocatable);
3963 gfc_set_sym_referenced (sym);
3964 e = gfc_lval_expr_from_sym (sym);
3965 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3966 if (sym->attr.dummy && (sym->attr.optional
3967 || sym->ns->proc_name->attr.entry_master))
3968 {
3969 present = gfc_conv_expr_present (sym);
3970 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3971 tmp, build_empty_stmt (input_location));
3972 }
3973 gfc_add_expr_to_block (block, tmp);
3974 gfc_free_expr (e);
3975 }
3976
3977
3978 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3979 them their default initializer, if they do not have allocatable
3980 components, they have their allocatable components deallocated. */
3981
3982 static void
3983 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3984 {
3985 stmtblock_t init;
3986 gfc_formal_arglist *f;
3987 tree tmp;
3988 tree present;
3989
3990 gfc_init_block (&init);
3991 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
3992 if (f->sym && f->sym->attr.intent == INTENT_OUT
3993 && !f->sym->attr.pointer
3994 && f->sym->ts.type == BT_DERIVED)
3995 {
3996 tmp = NULL_TREE;
3997
3998 /* Note: Allocatables are excluded as they are already handled
3999 by the caller. */
4000 if (!f->sym->attr.allocatable
4001 && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
4002 {
4003 stmtblock_t block;
4004 gfc_expr *e;
4005
4006 gfc_init_block (&block);
4007 f->sym->attr.referenced = 1;
4008 e = gfc_lval_expr_from_sym (f->sym);
4009 gfc_add_finalizer_call (&block, e);
4010 gfc_free_expr (e);
4011 tmp = gfc_finish_block (&block);
4012 }
4013
4014 if (tmp == NULL_TREE && !f->sym->attr.allocatable
4015 && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
4016 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
4017 f->sym->backend_decl,
4018 f->sym->as ? f->sym->as->rank : 0);
4019
4020 if (tmp != NULL_TREE && (f->sym->attr.optional
4021 || f->sym->ns->proc_name->attr.entry_master))
4022 {
4023 present = gfc_conv_expr_present (f->sym);
4024 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4025 present, tmp, build_empty_stmt (input_location));
4026 }
4027
4028 if (tmp != NULL_TREE)
4029 gfc_add_expr_to_block (&init, tmp);
4030 else if (f->sym->value && !f->sym->attr.allocatable)
4031 gfc_init_default_dt (f->sym, &init, true);
4032 }
4033 else if (f->sym && f->sym->attr.intent == INTENT_OUT
4034 && f->sym->ts.type == BT_CLASS
4035 && !CLASS_DATA (f->sym)->attr.class_pointer
4036 && !CLASS_DATA (f->sym)->attr.allocatable)
4037 {
4038 stmtblock_t block;
4039 gfc_expr *e;
4040
4041 gfc_init_block (&block);
4042 f->sym->attr.referenced = 1;
4043 e = gfc_lval_expr_from_sym (f->sym);
4044 gfc_add_finalizer_call (&block, e);
4045 gfc_free_expr (e);
4046 tmp = gfc_finish_block (&block);
4047
4048 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
4049 {
4050 present = gfc_conv_expr_present (f->sym);
4051 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4052 present, tmp,
4053 build_empty_stmt (input_location));
4054 }
4055
4056 gfc_add_expr_to_block (&init, tmp);
4057 }
4058
4059 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4060 }
4061
4062
4063 /* Helper function to manage deferred string lengths. */
4064
4065 static tree
4066 gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
4067 locus *loc)
4068 {
4069 tree tmp;
4070
4071 /* Character length passed by reference. */
4072 tmp = sym->ts.u.cl->passed_length;
4073 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4074 tmp = fold_convert (gfc_charlen_type_node, tmp);
4075
4076 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4077 /* Zero the string length when entering the scope. */
4078 gfc_add_modify (init, sym->ts.u.cl->backend_decl,
4079 build_int_cst (gfc_charlen_type_node, 0));
4080 else
4081 {
4082 tree tmp2;
4083
4084 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
4085 gfc_charlen_type_node,
4086 sym->ts.u.cl->backend_decl, tmp);
4087 if (sym->attr.optional)
4088 {
4089 tree present = gfc_conv_expr_present (sym);
4090 tmp2 = build3_loc (input_location, COND_EXPR,
4091 void_type_node, present, tmp2,
4092 build_empty_stmt (input_location));
4093 }
4094 gfc_add_expr_to_block (init, tmp2);
4095 }
4096
4097 gfc_restore_backend_locus (loc);
4098
4099 /* Pass the final character length back. */
4100 if (sym->attr.intent != INTENT_IN)
4101 {
4102 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4103 gfc_charlen_type_node, tmp,
4104 sym->ts.u.cl->backend_decl);
4105 if (sym->attr.optional)
4106 {
4107 tree present = gfc_conv_expr_present (sym);
4108 tmp = build3_loc (input_location, COND_EXPR,
4109 void_type_node, present, tmp,
4110 build_empty_stmt (input_location));
4111 }
4112 }
4113 else
4114 tmp = NULL_TREE;
4115
4116 return tmp;
4117 }
4118
4119 /* Generate function entry and exit code, and add it to the function body.
4120 This includes:
4121 Allocation and initialization of array variables.
4122 Allocation of character string variables.
4123 Initialization and possibly repacking of dummy arrays.
4124 Initialization of ASSIGN statement auxiliary variable.
4125 Initialization of ASSOCIATE names.
4126 Automatic deallocation. */
4127
4128 void
4129 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4130 {
4131 locus loc;
4132 gfc_symbol *sym;
4133 gfc_formal_arglist *f;
4134 stmtblock_t tmpblock;
4135 bool seen_trans_deferred_array = false;
4136 tree tmp = NULL;
4137 gfc_expr *e;
4138 gfc_se se;
4139 stmtblock_t init;
4140
4141 /* Deal with implicit return variables. Explicit return variables will
4142 already have been added. */
4143 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
4144 {
4145 if (!current_fake_result_decl)
4146 {
4147 gfc_entry_list *el = NULL;
4148 if (proc_sym->attr.entry_master)
4149 {
4150 for (el = proc_sym->ns->entries; el; el = el->next)
4151 if (el->sym != el->sym->result)
4152 break;
4153 }
4154 /* TODO: move to the appropriate place in resolve.c. */
4155 if (warn_return_type && el == NULL)
4156 gfc_warning (OPT_Wreturn_type,
4157 "Return value of function %qs at %L not set",
4158 proc_sym->name, &proc_sym->declared_at);
4159 }
4160 else if (proc_sym->as)
4161 {
4162 tree result = TREE_VALUE (current_fake_result_decl);
4163 gfc_save_backend_locus (&loc);
4164 gfc_set_backend_locus (&proc_sym->declared_at);
4165 gfc_trans_dummy_array_bias (proc_sym, result, block);
4166
4167 /* An automatic character length, pointer array result. */
4168 if (proc_sym->ts.type == BT_CHARACTER
4169 && VAR_P (proc_sym->ts.u.cl->backend_decl))
4170 {
4171 tmp = NULL;
4172 if (proc_sym->ts.deferred)
4173 {
4174 gfc_start_block (&init);
4175 tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
4176 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4177 }
4178 else
4179 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4180 }
4181 }
4182 else if (proc_sym->ts.type == BT_CHARACTER)
4183 {
4184 if (proc_sym->ts.deferred)
4185 {
4186 tmp = NULL;
4187 gfc_save_backend_locus (&loc);
4188 gfc_set_backend_locus (&proc_sym->declared_at);
4189 gfc_start_block (&init);
4190 /* Zero the string length on entry. */
4191 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
4192 build_int_cst (gfc_charlen_type_node, 0));
4193 /* Null the pointer. */
4194 e = gfc_lval_expr_from_sym (proc_sym);
4195 gfc_init_se (&se, NULL);
4196 se.want_pointer = 1;
4197 gfc_conv_expr (&se, e);
4198 gfc_free_expr (e);
4199 tmp = se.expr;
4200 gfc_add_modify (&init, tmp,
4201 fold_convert (TREE_TYPE (se.expr),
4202 null_pointer_node));
4203 gfc_restore_backend_locus (&loc);
4204
4205 /* Pass back the string length on exit. */
4206 tmp = proc_sym->ts.u.cl->backend_decl;
4207 if (TREE_CODE (tmp) != INDIRECT_REF
4208 && proc_sym->ts.u.cl->passed_length)
4209 {
4210 tmp = proc_sym->ts.u.cl->passed_length;
4211 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4212 tmp = fold_convert (gfc_charlen_type_node, tmp);
4213 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4214 gfc_charlen_type_node, tmp,
4215 proc_sym->ts.u.cl->backend_decl);
4216 }
4217 else
4218 tmp = NULL_TREE;
4219
4220 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4221 }
4222 else if (VAR_P (proc_sym->ts.u.cl->backend_decl))
4223 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4224 }
4225 else
4226 gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
4227 }
4228
4229 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4230 should be done here so that the offsets and lbounds of arrays
4231 are available. */
4232 gfc_save_backend_locus (&loc);
4233 gfc_set_backend_locus (&proc_sym->declared_at);
4234 init_intent_out_dt (proc_sym, block);
4235 gfc_restore_backend_locus (&loc);
4236
4237 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
4238 {
4239 bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
4240 && (sym->ts.u.derived->attr.alloc_comp
4241 || gfc_is_finalizable (sym->ts.u.derived,
4242 NULL));
4243 if (sym->assoc)
4244 continue;
4245
4246 if (sym->attr.subref_array_pointer
4247 && GFC_DECL_SPAN (sym->backend_decl)
4248 && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
4249 {
4250 gfc_init_block (&tmpblock);
4251 gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
4252 build_int_cst (gfc_array_index_type, 0));
4253 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4254 NULL_TREE);
4255 }
4256
4257 if (sym->ts.type == BT_CLASS
4258 && (sym->attr.save || flag_max_stack_var_size == 0)
4259 && CLASS_DATA (sym)->attr.allocatable)
4260 {
4261 tree vptr;
4262
4263 if (UNLIMITED_POLY (sym))
4264 vptr = null_pointer_node;
4265 else
4266 {
4267 gfc_symbol *vsym;
4268 vsym = gfc_find_derived_vtab (sym->ts.u.derived);
4269 vptr = gfc_get_symbol_decl (vsym);
4270 vptr = gfc_build_addr_expr (NULL, vptr);
4271 }
4272
4273 if (CLASS_DATA (sym)->attr.dimension
4274 || (CLASS_DATA (sym)->attr.codimension
4275 && flag_coarray != GFC_FCOARRAY_LIB))
4276 {
4277 tmp = gfc_class_data_get (sym->backend_decl);
4278 tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
4279 }
4280 else
4281 tmp = null_pointer_node;
4282
4283 DECL_INITIAL (sym->backend_decl)
4284 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
4285 TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
4286 }
4287 else if ((sym->attr.dimension || sym->attr.codimension
4288 || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
4289 {
4290 bool is_classarray = IS_CLASS_ARRAY (sym);
4291 symbol_attribute *array_attr;
4292 gfc_array_spec *as;
4293 array_type type_of_array;
4294
4295 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
4296 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
4297 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4298 type_of_array = as->type;
4299 if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
4300 type_of_array = AS_EXPLICIT;
4301 switch (type_of_array)
4302 {
4303 case AS_EXPLICIT:
4304 if (sym->attr.dummy || sym->attr.result)
4305 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4306 /* Allocatable and pointer arrays need to processed
4307 explicitly. */
4308 else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
4309 || (sym->ts.type == BT_CLASS
4310 && CLASS_DATA (sym)->attr.class_pointer)
4311 || array_attr->allocatable)
4312 {
4313 if (TREE_STATIC (sym->backend_decl))
4314 {
4315 gfc_save_backend_locus (&loc);
4316 gfc_set_backend_locus (&sym->declared_at);
4317 gfc_trans_static_array_pointer (sym);
4318 gfc_restore_backend_locus (&loc);
4319 }
4320 else
4321 {
4322 seen_trans_deferred_array = true;
4323 gfc_trans_deferred_array (sym, block);
4324 }
4325 }
4326 else if (sym->attr.codimension
4327 && TREE_STATIC (sym->backend_decl))
4328 {
4329 gfc_init_block (&tmpblock);
4330 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
4331 &tmpblock, sym);
4332 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4333 NULL_TREE);
4334 continue;
4335 }
4336 else
4337 {
4338 gfc_save_backend_locus (&loc);
4339 gfc_set_backend_locus (&sym->declared_at);
4340
4341 if (alloc_comp_or_fini)
4342 {
4343 seen_trans_deferred_array = true;
4344 gfc_trans_deferred_array (sym, block);
4345 }
4346 else if (sym->ts.type == BT_DERIVED
4347 && sym->value
4348 && !sym->attr.data
4349 && sym->attr.save == SAVE_NONE)
4350 {
4351 gfc_start_block (&tmpblock);
4352 gfc_init_default_dt (sym, &tmpblock, false);
4353 gfc_add_init_cleanup (block,
4354 gfc_finish_block (&tmpblock),
4355 NULL_TREE);
4356 }
4357
4358 gfc_trans_auto_array_allocation (sym->backend_decl,
4359 sym, block);
4360 gfc_restore_backend_locus (&loc);
4361 }
4362 break;
4363
4364 case AS_ASSUMED_SIZE:
4365 /* Must be a dummy parameter. */
4366 gcc_assert (sym->attr.dummy || as->cp_was_assumed);
4367
4368 /* We should always pass assumed size arrays the g77 way. */
4369 if (sym->attr.dummy)
4370 gfc_trans_g77_array (sym, block);
4371 break;
4372
4373 case AS_ASSUMED_SHAPE:
4374 /* Must be a dummy parameter. */
4375 gcc_assert (sym->attr.dummy);
4376
4377 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4378 break;
4379
4380 case AS_ASSUMED_RANK:
4381 case AS_DEFERRED:
4382 seen_trans_deferred_array = true;
4383 gfc_trans_deferred_array (sym, block);
4384 if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
4385 && sym->attr.result)
4386 {
4387 gfc_start_block (&init);
4388 gfc_save_backend_locus (&loc);
4389 gfc_set_backend_locus (&sym->declared_at);
4390 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4391 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4392 }
4393 break;
4394
4395 default:
4396 gcc_unreachable ();
4397 }
4398 if (alloc_comp_or_fini && !seen_trans_deferred_array)
4399 gfc_trans_deferred_array (sym, block);
4400 }
4401 else if ((!sym->attr.dummy || sym->ts.deferred)
4402 && (sym->ts.type == BT_CLASS
4403 && CLASS_DATA (sym)->attr.class_pointer))
4404 continue;
4405 else if ((!sym->attr.dummy || sym->ts.deferred)
4406 && (sym->attr.allocatable
4407 || (sym->attr.pointer && sym->attr.result)
4408 || (sym->ts.type == BT_CLASS
4409 && CLASS_DATA (sym)->attr.allocatable)))
4410 {
4411 if (!sym->attr.save && flag_max_stack_var_size != 0)
4412 {
4413 tree descriptor = NULL_TREE;
4414
4415 gfc_save_backend_locus (&loc);
4416 gfc_set_backend_locus (&sym->declared_at);
4417 gfc_start_block (&init);
4418
4419 if (!sym->attr.pointer)
4420 {
4421 /* Nullify and automatic deallocation of allocatable
4422 scalars. */
4423 e = gfc_lval_expr_from_sym (sym);
4424 if (sym->ts.type == BT_CLASS)
4425 gfc_add_data_component (e);
4426
4427 gfc_init_se (&se, NULL);
4428 if (sym->ts.type != BT_CLASS
4429 || sym->ts.u.derived->attr.dimension
4430 || sym->ts.u.derived->attr.codimension)
4431 {
4432 se.want_pointer = 1;
4433 gfc_conv_expr (&se, e);
4434 }
4435 else if (sym->ts.type == BT_CLASS
4436 && !CLASS_DATA (sym)->attr.dimension
4437 && !CLASS_DATA (sym)->attr.codimension)
4438 {
4439 se.want_pointer = 1;
4440 gfc_conv_expr (&se, e);
4441 }
4442 else
4443 {
4444 se.descriptor_only = 1;
4445 gfc_conv_expr (&se, e);
4446 descriptor = se.expr;
4447 se.expr = gfc_conv_descriptor_data_addr (se.expr);
4448 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
4449 }
4450 gfc_free_expr (e);
4451
4452 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4453 {
4454 /* Nullify when entering the scope. */
4455 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4456 TREE_TYPE (se.expr), se.expr,
4457 fold_convert (TREE_TYPE (se.expr),
4458 null_pointer_node));
4459 if (sym->attr.optional)
4460 {
4461 tree present = gfc_conv_expr_present (sym);
4462 tmp = build3_loc (input_location, COND_EXPR,
4463 void_type_node, present, tmp,
4464 build_empty_stmt (input_location));
4465 }
4466 gfc_add_expr_to_block (&init, tmp);
4467 }
4468 }
4469
4470 if ((sym->attr.dummy || sym->attr.result)
4471 && sym->ts.type == BT_CHARACTER
4472 && sym->ts.deferred
4473 && sym->ts.u.cl->passed_length)
4474 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4475 else
4476 gfc_restore_backend_locus (&loc);
4477
4478 /* Deallocate when leaving the scope. Nullifying is not
4479 needed. */
4480 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
4481 && !sym->ns->proc_name->attr.is_main_program)
4482 {
4483 if (sym->ts.type == BT_CLASS
4484 && CLASS_DATA (sym)->attr.codimension)
4485 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
4486 NULL_TREE, NULL_TREE,
4487 NULL_TREE, true, NULL,
4488 GFC_CAF_COARRAY_ANALYZE);
4489 else
4490 {
4491 gfc_expr *expr = gfc_lval_expr_from_sym (sym);
4492 tmp = gfc_deallocate_scalar_with_status (se.expr,
4493 NULL_TREE,
4494 NULL_TREE,
4495 true, expr,
4496 sym->ts);
4497 gfc_free_expr (expr);
4498 }
4499 }
4500
4501 if (sym->ts.type == BT_CLASS)
4502 {
4503 /* Initialize _vptr to declared type. */
4504 gfc_symbol *vtab;
4505 tree rhs;
4506
4507 gfc_save_backend_locus (&loc);
4508 gfc_set_backend_locus (&sym->declared_at);
4509 e = gfc_lval_expr_from_sym (sym);
4510 gfc_add_vptr_component (e);
4511 gfc_init_se (&se, NULL);
4512 se.want_pointer = 1;
4513 gfc_conv_expr (&se, e);
4514 gfc_free_expr (e);
4515 if (UNLIMITED_POLY (sym))
4516 rhs = build_int_cst (TREE_TYPE (se.expr), 0);
4517 else
4518 {
4519 vtab = gfc_find_derived_vtab (sym->ts.u.derived);
4520 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
4521 gfc_get_symbol_decl (vtab));
4522 }
4523 gfc_add_modify (&init, se.expr, rhs);
4524 gfc_restore_backend_locus (&loc);
4525 }
4526
4527 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4528 }
4529 }
4530 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
4531 {
4532 tree tmp = NULL;
4533 stmtblock_t init;
4534
4535 /* If we get to here, all that should be left are pointers. */
4536 gcc_assert (sym->attr.pointer);
4537
4538 if (sym->attr.dummy)
4539 {
4540 gfc_start_block (&init);
4541 gfc_save_backend_locus (&loc);
4542 gfc_set_backend_locus (&sym->declared_at);
4543 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4544 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4545 }
4546 }
4547 else if (sym->ts.deferred)
4548 gfc_fatal_error ("Deferred type parameter not yet supported");
4549 else if (alloc_comp_or_fini)
4550 gfc_trans_deferred_array (sym, block);
4551 else if (sym->ts.type == BT_CHARACTER)
4552 {
4553 gfc_save_backend_locus (&loc);
4554 gfc_set_backend_locus (&sym->declared_at);
4555 if (sym->attr.dummy || sym->attr.result)
4556 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
4557 else
4558 gfc_trans_auto_character_variable (sym, block);
4559 gfc_restore_backend_locus (&loc);
4560 }
4561 else if (sym->attr.assign)
4562 {
4563 gfc_save_backend_locus (&loc);
4564 gfc_set_backend_locus (&sym->declared_at);
4565 gfc_trans_assign_aux_var (sym, block);
4566 gfc_restore_backend_locus (&loc);
4567 }
4568 else if (sym->ts.type == BT_DERIVED
4569 && sym->value
4570 && !sym->attr.data
4571 && sym->attr.save == SAVE_NONE)
4572 {
4573 gfc_start_block (&tmpblock);
4574 gfc_init_default_dt (sym, &tmpblock, false);
4575 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4576 NULL_TREE);
4577 }
4578 else if (!(UNLIMITED_POLY(sym)))
4579 gcc_unreachable ();
4580 }
4581
4582 gfc_init_block (&tmpblock);
4583
4584 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4585 {
4586 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
4587 {
4588 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
4589 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
4590 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
4591 }
4592 }
4593
4594 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
4595 && current_fake_result_decl != NULL)
4596 {
4597 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
4598 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
4599 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
4600 }
4601
4602 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
4603 }
4604
4605
4606 struct module_hasher : ggc_ptr_hash<module_htab_entry>
4607 {
4608 typedef const char *compare_type;
4609
4610 static hashval_t hash (module_htab_entry *s) { return htab_hash_string (s); }
4611 static bool
4612 equal (module_htab_entry *a, const char *b)
4613 {
4614 return !strcmp (a->name, b);
4615 }
4616 };
4617
4618 static GTY (()) hash_table<module_hasher> *module_htab;
4619
4620 /* Hash and equality functions for module_htab's decls. */
4621
4622 hashval_t
4623 module_decl_hasher::hash (tree t)
4624 {
4625 const_tree n = DECL_NAME (t);
4626 if (n == NULL_TREE)
4627 n = TYPE_NAME (TREE_TYPE (t));
4628 return htab_hash_string (IDENTIFIER_POINTER (n));
4629 }
4630
4631 bool
4632 module_decl_hasher::equal (tree t1, const char *x2)
4633 {
4634 const_tree n1 = DECL_NAME (t1);
4635 if (n1 == NULL_TREE)
4636 n1 = TYPE_NAME (TREE_TYPE (t1));
4637 return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
4638 }
4639
4640 struct module_htab_entry *
4641 gfc_find_module (const char *name)
4642 {
4643 if (! module_htab)
4644 module_htab = hash_table<module_hasher>::create_ggc (10);
4645
4646 module_htab_entry **slot
4647 = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
4648 if (*slot == NULL)
4649 {
4650 module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
4651
4652 entry->name = gfc_get_string ("%s", name);
4653 entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
4654 *slot = entry;
4655 }
4656 return *slot;
4657 }
4658
4659 void
4660 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
4661 {
4662 const char *name;
4663
4664 if (DECL_NAME (decl))
4665 name = IDENTIFIER_POINTER (DECL_NAME (decl));
4666 else
4667 {
4668 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
4669 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
4670 }
4671 tree *slot
4672 = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
4673 INSERT);
4674 if (*slot == NULL)
4675 *slot = decl;
4676 }
4677
4678
4679 /* Generate debugging symbols for namelists. This function must come after
4680 generate_local_decl to ensure that the variables in the namelist are
4681 already declared. */
4682
4683 static tree
4684 generate_namelist_decl (gfc_symbol * sym)
4685 {
4686 gfc_namelist *nml;
4687 tree decl;
4688 vec<constructor_elt, va_gc> *nml_decls = NULL;
4689
4690 gcc_assert (sym->attr.flavor == FL_NAMELIST);
4691 for (nml = sym->namelist; nml; nml = nml->next)
4692 {
4693 if (nml->sym->backend_decl == NULL_TREE)
4694 {
4695 nml->sym->attr.referenced = 1;
4696 nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
4697 }
4698 DECL_IGNORED_P (nml->sym->backend_decl) = 0;
4699 CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
4700 }
4701
4702 decl = make_node (NAMELIST_DECL);
4703 TREE_TYPE (decl) = void_type_node;
4704 NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
4705 DECL_NAME (decl) = get_identifier (sym->name);
4706 return decl;
4707 }
4708
4709
4710 /* Output an initialized decl for a module variable. */
4711
4712 static void
4713 gfc_create_module_variable (gfc_symbol * sym)
4714 {
4715 tree decl;
4716
4717 /* Module functions with alternate entries are dealt with later and
4718 would get caught by the next condition. */
4719 if (sym->attr.entry)
4720 return;
4721
4722 /* Make sure we convert the types of the derived types from iso_c_binding
4723 into (void *). */
4724 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4725 && sym->ts.type == BT_DERIVED)
4726 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4727
4728 if (gfc_fl_struct (sym->attr.flavor)
4729 && sym->backend_decl
4730 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4731 {
4732 decl = sym->backend_decl;
4733 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4734
4735 if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
4736 {
4737 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4738 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4739 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4740 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4741 == sym->ns->proc_name->backend_decl);
4742 }
4743 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4744 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4745 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4746 }
4747
4748 /* Only output variables, procedure pointers and array valued,
4749 or derived type, parameters. */
4750 if (sym->attr.flavor != FL_VARIABLE
4751 && !(sym->attr.flavor == FL_PARAMETER
4752 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4753 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4754 return;
4755
4756 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4757 {
4758 decl = sym->backend_decl;
4759 gcc_assert (DECL_FILE_SCOPE_P (decl));
4760 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4761 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4762 gfc_module_add_decl (cur_module, decl);
4763 }
4764
4765 /* Don't generate variables from other modules. Variables from
4766 COMMONs and Cray pointees will already have been generated. */
4767 if (sym->attr.use_assoc || sym->attr.used_in_submodule
4768 || sym->attr.in_common || sym->attr.cray_pointee)
4769 return;
4770
4771 /* Equivalenced variables arrive here after creation. */
4772 if (sym->backend_decl
4773 && (sym->equiv_built || sym->attr.in_equivalence))
4774 return;
4775
4776 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4777 gfc_internal_error ("backend decl for module variable %qs already exists",
4778 sym->name);
4779
4780 if (sym->module && !sym->attr.result && !sym->attr.dummy
4781 && (sym->attr.access == ACCESS_UNKNOWN
4782 && (sym->ns->default_access == ACCESS_PRIVATE
4783 || (sym->ns->default_access == ACCESS_UNKNOWN
4784 && flag_module_private))))
4785 sym->attr.access = ACCESS_PRIVATE;
4786
4787 if (warn_unused_variable && !sym->attr.referenced
4788 && sym->attr.access == ACCESS_PRIVATE)
4789 gfc_warning (OPT_Wunused_value,
4790 "Unused PRIVATE module variable %qs declared at %L",
4791 sym->name, &sym->declared_at);
4792
4793 /* We always want module variables to be created. */
4794 sym->attr.referenced = 1;
4795 /* Create the decl. */
4796 decl = gfc_get_symbol_decl (sym);
4797
4798 /* Create the variable. */
4799 pushdecl (decl);
4800 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
4801 || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
4802 && sym->fn_result_spec));
4803 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4804 rest_of_decl_compilation (decl, 1, 0);
4805 gfc_module_add_decl (cur_module, decl);
4806
4807 /* Also add length of strings. */
4808 if (sym->ts.type == BT_CHARACTER)
4809 {
4810 tree length;
4811
4812 length = sym->ts.u.cl->backend_decl;
4813 gcc_assert (length || sym->attr.proc_pointer);
4814 if (length && !INTEGER_CST_P (length))
4815 {
4816 pushdecl (length);
4817 rest_of_decl_compilation (length, 1, 0);
4818 }
4819 }
4820
4821 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4822 && sym->attr.referenced && !sym->attr.use_assoc)
4823 has_coarray_vars = true;
4824 }
4825
4826 /* Emit debug information for USE statements. */
4827
4828 static void
4829 gfc_trans_use_stmts (gfc_namespace * ns)
4830 {
4831 gfc_use_list *use_stmt;
4832 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4833 {
4834 struct module_htab_entry *entry
4835 = gfc_find_module (use_stmt->module_name);
4836 gfc_use_rename *rent;
4837
4838 if (entry->namespace_decl == NULL)
4839 {
4840 entry->namespace_decl
4841 = build_decl (input_location,
4842 NAMESPACE_DECL,
4843 get_identifier (use_stmt->module_name),
4844 void_type_node);
4845 DECL_EXTERNAL (entry->namespace_decl) = 1;
4846 }
4847 gfc_set_backend_locus (&use_stmt->where);
4848 if (!use_stmt->only_flag)
4849 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4850 NULL_TREE,
4851 ns->proc_name->backend_decl,
4852 false);
4853 for (rent = use_stmt->rename; rent; rent = rent->next)
4854 {
4855 tree decl, local_name;
4856
4857 if (rent->op != INTRINSIC_NONE)
4858 continue;
4859
4860 hashval_t hash = htab_hash_string (rent->use_name);
4861 tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
4862 INSERT);
4863 if (*slot == NULL)
4864 {
4865 gfc_symtree *st;
4866
4867 st = gfc_find_symtree (ns->sym_root,
4868 rent->local_name[0]
4869 ? rent->local_name : rent->use_name);
4870
4871 /* The following can happen if a derived type is renamed. */
4872 if (!st)
4873 {
4874 char *name;
4875 name = xstrdup (rent->local_name[0]
4876 ? rent->local_name : rent->use_name);
4877 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4878 st = gfc_find_symtree (ns->sym_root, name);
4879 free (name);
4880 gcc_assert (st);
4881 }
4882
4883 /* Sometimes, generic interfaces wind up being over-ruled by a
4884 local symbol (see PR41062). */
4885 if (!st->n.sym->attr.use_assoc)
4886 continue;
4887
4888 if (st->n.sym->backend_decl
4889 && DECL_P (st->n.sym->backend_decl)
4890 && st->n.sym->module
4891 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4892 {
4893 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4894 || !VAR_P (st->n.sym->backend_decl));
4895 decl = copy_node (st->n.sym->backend_decl);
4896 DECL_CONTEXT (decl) = entry->namespace_decl;
4897 DECL_EXTERNAL (decl) = 1;
4898 DECL_IGNORED_P (decl) = 0;
4899 DECL_INITIAL (decl) = NULL_TREE;
4900 }
4901 else if (st->n.sym->attr.flavor == FL_NAMELIST
4902 && st->n.sym->attr.use_only
4903 && st->n.sym->module
4904 && strcmp (st->n.sym->module, use_stmt->module_name)
4905 == 0)
4906 {
4907 decl = generate_namelist_decl (st->n.sym);
4908 DECL_CONTEXT (decl) = entry->namespace_decl;
4909 DECL_EXTERNAL (decl) = 1;
4910 DECL_IGNORED_P (decl) = 0;
4911 DECL_INITIAL (decl) = NULL_TREE;
4912 }
4913 else
4914 {
4915 *slot = error_mark_node;
4916 entry->decls->clear_slot (slot);
4917 continue;
4918 }
4919 *slot = decl;
4920 }
4921 decl = (tree) *slot;
4922 if (rent->local_name[0])
4923 local_name = get_identifier (rent->local_name);
4924 else
4925 local_name = NULL_TREE;
4926 gfc_set_backend_locus (&rent->where);
4927 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4928 ns->proc_name->backend_decl,
4929 !use_stmt->only_flag);
4930 }
4931 }
4932 }
4933
4934
4935 /* Return true if expr is a constant initializer that gfc_conv_initializer
4936 will handle. */
4937
4938 static bool
4939 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4940 bool pointer)
4941 {
4942 gfc_constructor *c;
4943 gfc_component *cm;
4944
4945 if (pointer)
4946 return true;
4947 else if (array)
4948 {
4949 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4950 return true;
4951 else if (expr->expr_type == EXPR_STRUCTURE)
4952 return check_constant_initializer (expr, ts, false, false);
4953 else if (expr->expr_type != EXPR_ARRAY)
4954 return false;
4955 for (c = gfc_constructor_first (expr->value.constructor);
4956 c; c = gfc_constructor_next (c))
4957 {
4958 if (c->iterator)
4959 return false;
4960 if (c->expr->expr_type == EXPR_STRUCTURE)
4961 {
4962 if (!check_constant_initializer (c->expr, ts, false, false))
4963 return false;
4964 }
4965 else if (c->expr->expr_type != EXPR_CONSTANT)
4966 return false;
4967 }
4968 return true;
4969 }
4970 else switch (ts->type)
4971 {
4972 case_bt_struct:
4973 if (expr->expr_type != EXPR_STRUCTURE)
4974 return false;
4975 cm = expr->ts.u.derived->components;
4976 for (c = gfc_constructor_first (expr->value.constructor);
4977 c; c = gfc_constructor_next (c), cm = cm->next)
4978 {
4979 if (!c->expr || cm->attr.allocatable)
4980 continue;
4981 if (!check_constant_initializer (c->expr, &cm->ts,
4982 cm->attr.dimension,
4983 cm->attr.pointer))
4984 return false;
4985 }
4986 return true;
4987 default:
4988 return expr->expr_type == EXPR_CONSTANT;
4989 }
4990 }
4991
4992 /* Emit debug info for parameters and unreferenced variables with
4993 initializers. */
4994
4995 static void
4996 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4997 {
4998 tree decl;
4999
5000 if (sym->attr.flavor != FL_PARAMETER
5001 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5002 return;
5003
5004 if (sym->backend_decl != NULL
5005 || sym->value == NULL
5006 || sym->attr.use_assoc
5007 || sym->attr.dummy
5008 || sym->attr.result
5009 || sym->attr.function
5010 || sym->attr.intrinsic
5011 || sym->attr.pointer
5012 || sym->attr.allocatable
5013 || sym->attr.cray_pointee
5014 || sym->attr.threadprivate
5015 || sym->attr.is_bind_c
5016 || sym->attr.subref_array_pointer
5017 || sym->attr.assign)
5018 return;
5019
5020 if (sym->ts.type == BT_CHARACTER)
5021 {
5022 gfc_conv_const_charlen (sym->ts.u.cl);
5023 if (sym->ts.u.cl->backend_decl == NULL
5024 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5025 return;
5026 }
5027 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5028 return;
5029
5030 if (sym->as)
5031 {
5032 int n;
5033
5034 if (sym->as->type != AS_EXPLICIT)
5035 return;
5036 for (n = 0; n < sym->as->rank; n++)
5037 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5038 || sym->as->upper[n] == NULL
5039 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5040 return;
5041 }
5042
5043 if (!check_constant_initializer (sym->value, &sym->ts,
5044 sym->attr.dimension, false))
5045 return;
5046
5047 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5048 return;
5049
5050 /* Create the decl for the variable or constant. */
5051 decl = build_decl (input_location,
5052 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5053 gfc_sym_identifier (sym), gfc_sym_type (sym));
5054 if (sym->attr.flavor == FL_PARAMETER)
5055 TREE_READONLY (decl) = 1;
5056 gfc_set_decl_location (decl, &sym->declared_at);
5057 if (sym->attr.dimension)
5058 GFC_DECL_PACKED_ARRAY (decl) = 1;
5059 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5060 TREE_STATIC (decl) = 1;
5061 TREE_USED (decl) = 1;
5062 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5063 TREE_PUBLIC (decl) = 1;
5064 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5065 TREE_TYPE (decl),
5066 sym->attr.dimension,
5067 false, false);
5068 debug_hooks->early_global_decl (decl);
5069 }
5070
5071
5072 static void
5073 generate_coarray_sym_init (gfc_symbol *sym)
5074 {
5075 tree tmp, size, decl, token, desc;
5076 bool is_lock_type, is_event_type;
5077 int reg_type;
5078 gfc_se se;
5079 symbol_attribute attr;
5080
5081 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5082 || sym->attr.use_assoc || !sym->attr.referenced
5083 || sym->attr.select_type_temporary)
5084 return;
5085
5086 decl = sym->backend_decl;
5087 TREE_USED(decl) = 1;
5088 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5089
5090 is_lock_type = sym->ts.type == BT_DERIVED
5091 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5092 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5093
5094 is_event_type = sym->ts.type == BT_DERIVED
5095 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5096 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5097
5098 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5099 to make sure the variable is not optimized away. */
5100 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5101
5102 /* For lock types, we pass the array size as only the library knows the
5103 size of the variable. */
5104 if (is_lock_type || is_event_type)
5105 size = gfc_index_one_node;
5106 else
5107 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5108
5109 /* Ensure that we do not have size=0 for zero-sized arrays. */
5110 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5111 fold_convert (size_type_node, size),
5112 build_int_cst (size_type_node, 1));
5113
5114 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5115 {
5116 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5117 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5118 fold_convert (size_type_node, tmp), size);
5119 }
5120
5121 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5122 token = gfc_build_addr_expr (ppvoid_type_node,
5123 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5124 if (is_lock_type)
5125 reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5126 else if (is_event_type)
5127 reg_type = GFC_CAF_EVENT_STATIC;
5128 else
5129 reg_type = GFC_CAF_COARRAY_STATIC;
5130
5131 /* Compile the symbol attribute. */
5132 if (sym->ts.type == BT_CLASS)
5133 {
5134 attr = CLASS_DATA (sym)->attr;
5135 /* The pointer attribute is always set on classes, overwrite it with the
5136 class_pointer attribute, which denotes the pointer for classes. */
5137 attr.pointer = attr.class_pointer;
5138 }
5139 else
5140 attr = sym->attr;
5141 gfc_init_se (&se, NULL);
5142 desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5143 gfc_add_block_to_block (&caf_init_block, &se.pre);
5144
5145 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5146 build_int_cst (integer_type_node, reg_type),
5147 token, gfc_build_addr_expr (pvoid_type_node, desc),
5148 null_pointer_node, /* stat. */
5149 null_pointer_node, /* errgmsg. */
5150 integer_zero_node); /* errmsg_len. */
5151 gfc_add_expr_to_block (&caf_init_block, tmp);
5152 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5153 gfc_conv_descriptor_data_get (desc)));
5154
5155 /* Handle "static" initializer. */
5156 if (sym->value)
5157 {
5158 sym->attr.pointer = 1;
5159 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5160 true, false);
5161 sym->attr.pointer = 0;
5162 gfc_add_expr_to_block (&caf_init_block, tmp);
5163 }
5164 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5165 {
5166 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5167 ? sym->as->rank : 0,
5168 GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5169 gfc_add_expr_to_block (&caf_init_block, tmp);
5170 }
5171 }
5172
5173
5174 /* Generate constructor function to initialize static, nonallocatable
5175 coarrays. */
5176
5177 static void
5178 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5179 {
5180 tree fndecl, tmp, decl, save_fn_decl;
5181
5182 save_fn_decl = current_function_decl;
5183 push_function_context ();
5184
5185 tmp = build_function_type_list (void_type_node, NULL_TREE);
5186 fndecl = build_decl (input_location, FUNCTION_DECL,
5187 create_tmp_var_name ("_caf_init"), tmp);
5188
5189 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5190 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5191
5192 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5193 DECL_ARTIFICIAL (decl) = 1;
5194 DECL_IGNORED_P (decl) = 1;
5195 DECL_CONTEXT (decl) = fndecl;
5196 DECL_RESULT (fndecl) = decl;
5197
5198 pushdecl (fndecl);
5199 current_function_decl = fndecl;
5200 announce_function (fndecl);
5201
5202 rest_of_decl_compilation (fndecl, 0, 0);
5203 make_decl_rtl (fndecl);
5204 allocate_struct_function (fndecl, false);
5205
5206 pushlevel ();
5207 gfc_init_block (&caf_init_block);
5208
5209 gfc_traverse_ns (ns, generate_coarray_sym_init);
5210
5211 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5212 decl = getdecls ();
5213
5214 poplevel (1, 1);
5215 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5216
5217 DECL_SAVED_TREE (fndecl)
5218 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5219 DECL_INITIAL (fndecl));
5220 dump_function (TDI_original, fndecl);
5221
5222 cfun->function_end_locus = input_location;
5223 set_cfun (NULL);
5224
5225 if (decl_function_context (fndecl))
5226 (void) cgraph_node::create (fndecl);
5227 else
5228 cgraph_node::finalize_function (fndecl, true);
5229
5230 pop_function_context ();
5231 current_function_decl = save_fn_decl;
5232 }
5233
5234
5235 static void
5236 create_module_nml_decl (gfc_symbol *sym)
5237 {
5238 if (sym->attr.flavor == FL_NAMELIST)
5239 {
5240 tree decl = generate_namelist_decl (sym);
5241 pushdecl (decl);
5242 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5243 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5244 rest_of_decl_compilation (decl, 1, 0);
5245 gfc_module_add_decl (cur_module, decl);
5246 }
5247 }
5248
5249
5250 /* Generate all the required code for module variables. */
5251
5252 void
5253 gfc_generate_module_vars (gfc_namespace * ns)
5254 {
5255 module_namespace = ns;
5256 cur_module = gfc_find_module (ns->proc_name->name);
5257
5258 /* Check if the frontend left the namespace in a reasonable state. */
5259 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5260
5261 /* Generate COMMON blocks. */
5262 gfc_trans_common (ns);
5263
5264 has_coarray_vars = false;
5265
5266 /* Create decls for all the module variables. */
5267 gfc_traverse_ns (ns, gfc_create_module_variable);
5268 gfc_traverse_ns (ns, create_module_nml_decl);
5269
5270 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5271 generate_coarray_init (ns);
5272
5273 cur_module = NULL;
5274
5275 gfc_trans_use_stmts (ns);
5276 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5277 }
5278
5279
5280 static void
5281 gfc_generate_contained_functions (gfc_namespace * parent)
5282 {
5283 gfc_namespace *ns;
5284
5285 /* We create all the prototypes before generating any code. */
5286 for (ns = parent->contained; ns; ns = ns->sibling)
5287 {
5288 /* Skip namespaces from used modules. */
5289 if (ns->parent != parent)
5290 continue;
5291
5292 gfc_create_function_decl (ns, false);
5293 }
5294
5295 for (ns = parent->contained; ns; ns = ns->sibling)
5296 {
5297 /* Skip namespaces from used modules. */
5298 if (ns->parent != parent)
5299 continue;
5300
5301 gfc_generate_function_code (ns);
5302 }
5303 }
5304
5305
5306 /* Drill down through expressions for the array specification bounds and
5307 character length calling generate_local_decl for all those variables
5308 that have not already been declared. */
5309
5310 static void
5311 generate_local_decl (gfc_symbol *);
5312
5313 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5314
5315 static bool
5316 expr_decls (gfc_expr *e, gfc_symbol *sym,
5317 int *f ATTRIBUTE_UNUSED)
5318 {
5319 if (e->expr_type != EXPR_VARIABLE
5320 || sym == e->symtree->n.sym
5321 || e->symtree->n.sym->mark
5322 || e->symtree->n.sym->ns != sym->ns)
5323 return false;
5324
5325 generate_local_decl (e->symtree->n.sym);
5326 return false;
5327 }
5328
5329 static void
5330 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
5331 {
5332 gfc_traverse_expr (e, sym, expr_decls, 0);
5333 }
5334
5335
5336 /* Check for dependencies in the character length and array spec. */
5337
5338 static void
5339 generate_dependency_declarations (gfc_symbol *sym)
5340 {
5341 int i;
5342
5343 if (sym->ts.type == BT_CHARACTER
5344 && sym->ts.u.cl
5345 && sym->ts.u.cl->length
5346 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5347 generate_expr_decls (sym, sym->ts.u.cl->length);
5348
5349 if (sym->as && sym->as->rank)
5350 {
5351 for (i = 0; i < sym->as->rank; i++)
5352 {
5353 generate_expr_decls (sym, sym->as->lower[i]);
5354 generate_expr_decls (sym, sym->as->upper[i]);
5355 }
5356 }
5357 }
5358
5359
5360 /* Generate decls for all local variables. We do this to ensure correct
5361 handling of expressions which only appear in the specification of
5362 other functions. */
5363
5364 static void
5365 generate_local_decl (gfc_symbol * sym)
5366 {
5367 if (sym->attr.flavor == FL_VARIABLE)
5368 {
5369 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5370 && sym->attr.referenced && !sym->attr.use_assoc)
5371 has_coarray_vars = true;
5372
5373 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
5374 generate_dependency_declarations (sym);
5375
5376 if (sym->attr.referenced)
5377 gfc_get_symbol_decl (sym);
5378
5379 /* Warnings for unused dummy arguments. */
5380 else if (sym->attr.dummy && !sym->attr.in_namelist)
5381 {
5382 /* INTENT(out) dummy arguments are likely meant to be set. */
5383 if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
5384 {
5385 if (sym->ts.type != BT_DERIVED)
5386 gfc_warning (OPT_Wunused_dummy_argument,
5387 "Dummy argument %qs at %L was declared "
5388 "INTENT(OUT) but was not set", sym->name,
5389 &sym->declared_at);
5390 else if (!gfc_has_default_initializer (sym->ts.u.derived)
5391 && !sym->ts.u.derived->attr.zero_comp)
5392 gfc_warning (OPT_Wunused_dummy_argument,
5393 "Derived-type dummy argument %qs at %L was "
5394 "declared INTENT(OUT) but was not set and "
5395 "does not have a default initializer",
5396 sym->name, &sym->declared_at);
5397 if (sym->backend_decl != NULL_TREE)
5398 TREE_NO_WARNING(sym->backend_decl) = 1;
5399 }
5400 else if (warn_unused_dummy_argument)
5401 {
5402 gfc_warning (OPT_Wunused_dummy_argument,
5403 "Unused dummy argument %qs at %L", sym->name,
5404 &sym->declared_at);
5405 if (sym->backend_decl != NULL_TREE)
5406 TREE_NO_WARNING(sym->backend_decl) = 1;
5407 }
5408 }
5409
5410 /* Warn for unused variables, but not if they're inside a common
5411 block or a namelist. */
5412 else if (warn_unused_variable
5413 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
5414 {
5415 if (sym->attr.use_only)
5416 {
5417 gfc_warning (OPT_Wunused_variable,
5418 "Unused module variable %qs which has been "
5419 "explicitly imported at %L", sym->name,
5420 &sym->declared_at);
5421 if (sym->backend_decl != NULL_TREE)
5422 TREE_NO_WARNING(sym->backend_decl) = 1;
5423 }
5424 else if (!sym->attr.use_assoc)
5425 {
5426 /* Corner case: the symbol may be an entry point. At this point,
5427 it may appear to be an unused variable. Suppress warning. */
5428 bool enter = false;
5429 gfc_entry_list *el;
5430
5431 for (el = sym->ns->entries; el; el=el->next)
5432 if (strcmp(sym->name, el->sym->name) == 0)
5433 enter = true;
5434
5435 if (!enter)
5436 gfc_warning (OPT_Wunused_variable,
5437 "Unused variable %qs declared at %L",
5438 sym->name, &sym->declared_at);
5439 if (sym->backend_decl != NULL_TREE)
5440 TREE_NO_WARNING(sym->backend_decl) = 1;
5441 }
5442 }
5443
5444 /* For variable length CHARACTER parameters, the PARM_DECL already
5445 references the length variable, so force gfc_get_symbol_decl
5446 even when not referenced. If optimize > 0, it will be optimized
5447 away anyway. But do this only after emitting -Wunused-parameter
5448 warning if requested. */
5449 if (sym->attr.dummy && !sym->attr.referenced
5450 && sym->ts.type == BT_CHARACTER
5451 && sym->ts.u.cl->backend_decl != NULL
5452 && VAR_P (sym->ts.u.cl->backend_decl))
5453 {
5454 sym->attr.referenced = 1;
5455 gfc_get_symbol_decl (sym);
5456 }
5457
5458 /* INTENT(out) dummy arguments and result variables with allocatable
5459 components are reset by default and need to be set referenced to
5460 generate the code for nullification and automatic lengths. */
5461 if (!sym->attr.referenced
5462 && sym->ts.type == BT_DERIVED
5463 && sym->ts.u.derived->attr.alloc_comp
5464 && !sym->attr.pointer
5465 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
5466 ||
5467 (sym->attr.result && sym != sym->result)))
5468 {
5469 sym->attr.referenced = 1;
5470 gfc_get_symbol_decl (sym);
5471 }
5472
5473 /* Check for dependencies in the array specification and string
5474 length, adding the necessary declarations to the function. We
5475 mark the symbol now, as well as in traverse_ns, to prevent
5476 getting stuck in a circular dependency. */
5477 sym->mark = 1;
5478 }
5479 else if (sym->attr.flavor == FL_PARAMETER)
5480 {
5481 if (warn_unused_parameter
5482 && !sym->attr.referenced)
5483 {
5484 if (!sym->attr.use_assoc)
5485 gfc_warning (OPT_Wunused_parameter,
5486 "Unused parameter %qs declared at %L", sym->name,
5487 &sym->declared_at);
5488 else if (sym->attr.use_only)
5489 gfc_warning (OPT_Wunused_parameter,
5490 "Unused parameter %qs which has been explicitly "
5491 "imported at %L", sym->name, &sym->declared_at);
5492 }
5493
5494 if (sym->ns
5495 && sym->ns->parent
5496 && sym->ns->parent->code
5497 && sym->ns->parent->code->op == EXEC_BLOCK)
5498 {
5499 if (sym->attr.referenced)
5500 gfc_get_symbol_decl (sym);
5501 sym->mark = 1;
5502 }
5503 }
5504 else if (sym->attr.flavor == FL_PROCEDURE)
5505 {
5506 /* TODO: move to the appropriate place in resolve.c. */
5507 if (warn_return_type
5508 && sym->attr.function
5509 && sym->result
5510 && sym != sym->result
5511 && !sym->result->attr.referenced
5512 && !sym->attr.use_assoc
5513 && sym->attr.if_source != IFSRC_IFBODY)
5514 {
5515 gfc_warning (OPT_Wreturn_type,
5516 "Return value %qs of function %qs declared at "
5517 "%L not set", sym->result->name, sym->name,
5518 &sym->result->declared_at);
5519
5520 /* Prevents "Unused variable" warning for RESULT variables. */
5521 sym->result->mark = 1;
5522 }
5523 }
5524
5525 if (sym->attr.dummy == 1)
5526 {
5527 /* Modify the tree type for scalar character dummy arguments of bind(c)
5528 procedures if they are passed by value. The tree type for them will
5529 be promoted to INTEGER_TYPE for the middle end, which appears to be
5530 what C would do with characters passed by-value. The value attribute
5531 implies the dummy is a scalar. */
5532 if (sym->attr.value == 1 && sym->backend_decl != NULL
5533 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
5534 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
5535 gfc_conv_scalar_char_value (sym, NULL, NULL);
5536
5537 /* Unused procedure passed as dummy argument. */
5538 if (sym->attr.flavor == FL_PROCEDURE)
5539 {
5540 if (!sym->attr.referenced)
5541 {
5542 if (warn_unused_dummy_argument)
5543 gfc_warning (OPT_Wunused_dummy_argument,
5544 "Unused dummy argument %qs at %L", sym->name,
5545 &sym->declared_at);
5546 }
5547
5548 /* Silence bogus "unused parameter" warnings from the
5549 middle end. */
5550 if (sym->backend_decl != NULL_TREE)
5551 TREE_NO_WARNING (sym->backend_decl) = 1;
5552 }
5553 }
5554
5555 /* Make sure we convert the types of the derived types from iso_c_binding
5556 into (void *). */
5557 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5558 && sym->ts.type == BT_DERIVED)
5559 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5560 }
5561
5562
5563 static void
5564 generate_local_nml_decl (gfc_symbol * sym)
5565 {
5566 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
5567 {
5568 tree decl = generate_namelist_decl (sym);
5569 pushdecl (decl);
5570 }
5571 }
5572
5573
5574 static void
5575 generate_local_vars (gfc_namespace * ns)
5576 {
5577 gfc_traverse_ns (ns, generate_local_decl);
5578 gfc_traverse_ns (ns, generate_local_nml_decl);
5579 }
5580
5581
5582 /* Generate a switch statement to jump to the correct entry point. Also
5583 creates the label decls for the entry points. */
5584
5585 static tree
5586 gfc_trans_entry_master_switch (gfc_entry_list * el)
5587 {
5588 stmtblock_t block;
5589 tree label;
5590 tree tmp;
5591 tree val;
5592
5593 gfc_init_block (&block);
5594 for (; el; el = el->next)
5595 {
5596 /* Add the case label. */
5597 label = gfc_build_label_decl (NULL_TREE);
5598 val = build_int_cst (gfc_array_index_type, el->id);
5599 tmp = build_case_label (val, NULL_TREE, label);
5600 gfc_add_expr_to_block (&block, tmp);
5601
5602 /* And jump to the actual entry point. */
5603 label = gfc_build_label_decl (NULL_TREE);
5604 tmp = build1_v (GOTO_EXPR, label);
5605 gfc_add_expr_to_block (&block, tmp);
5606
5607 /* Save the label decl. */
5608 el->label = label;
5609 }
5610 tmp = gfc_finish_block (&block);
5611 /* The first argument selects the entry point. */
5612 val = DECL_ARGUMENTS (current_function_decl);
5613 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
5614 val, tmp, NULL_TREE);
5615 return tmp;
5616 }
5617
5618
5619 /* Add code to string lengths of actual arguments passed to a function against
5620 the expected lengths of the dummy arguments. */
5621
5622 static void
5623 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
5624 {
5625 gfc_formal_arglist *formal;
5626
5627 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
5628 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
5629 && !formal->sym->ts.deferred)
5630 {
5631 enum tree_code comparison;
5632 tree cond;
5633 tree argname;
5634 gfc_symbol *fsym;
5635 gfc_charlen *cl;
5636 const char *message;
5637
5638 fsym = formal->sym;
5639 cl = fsym->ts.u.cl;
5640
5641 gcc_assert (cl);
5642 gcc_assert (cl->passed_length != NULL_TREE);
5643 gcc_assert (cl->backend_decl != NULL_TREE);
5644
5645 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5646 string lengths must match exactly. Otherwise, it is only required
5647 that the actual string length is *at least* the expected one.
5648 Sequence association allows for a mismatch of the string length
5649 if the actual argument is (part of) an array, but only if the
5650 dummy argument is an array. (See "Sequence association" in
5651 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5652 if (fsym->attr.pointer || fsym->attr.allocatable
5653 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
5654 || fsym->as->type == AS_ASSUMED_RANK)))
5655 {
5656 comparison = NE_EXPR;
5657 message = _("Actual string length does not match the declared one"
5658 " for dummy argument '%s' (%ld/%ld)");
5659 }
5660 else if (fsym->as && fsym->as->rank != 0)
5661 continue;
5662 else
5663 {
5664 comparison = LT_EXPR;
5665 message = _("Actual string length is shorter than the declared one"
5666 " for dummy argument '%s' (%ld/%ld)");
5667 }
5668
5669 /* Build the condition. For optional arguments, an actual length
5670 of 0 is also acceptable if the associated string is NULL, which
5671 means the argument was not passed. */
5672 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
5673 cl->passed_length, cl->backend_decl);
5674 if (fsym->attr.optional)
5675 {
5676 tree not_absent;
5677 tree not_0length;
5678 tree absent_failed;
5679
5680 not_0length = fold_build2_loc (input_location, NE_EXPR,
5681 boolean_type_node,
5682 cl->passed_length,
5683 build_zero_cst (gfc_charlen_type_node));
5684 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5685 fsym->attr.referenced = 1;
5686 not_absent = gfc_conv_expr_present (fsym);
5687
5688 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5689 boolean_type_node, not_0length,
5690 not_absent);
5691
5692 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5693 boolean_type_node, cond, absent_failed);
5694 }
5695
5696 /* Build the runtime check. */
5697 argname = gfc_build_cstring_const (fsym->name);
5698 argname = gfc_build_addr_expr (pchar_type_node, argname);
5699 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
5700 message, argname,
5701 fold_convert (long_integer_type_node,
5702 cl->passed_length),
5703 fold_convert (long_integer_type_node,
5704 cl->backend_decl));
5705 }
5706 }
5707
5708
5709 static void
5710 create_main_function (tree fndecl)
5711 {
5712 tree old_context;
5713 tree ftn_main;
5714 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
5715 stmtblock_t body;
5716
5717 old_context = current_function_decl;
5718
5719 if (old_context)
5720 {
5721 push_function_context ();
5722 saved_parent_function_decls = saved_function_decls;
5723 saved_function_decls = NULL_TREE;
5724 }
5725
5726 /* main() function must be declared with global scope. */
5727 gcc_assert (current_function_decl == NULL_TREE);
5728
5729 /* Declare the function. */
5730 tmp = build_function_type_list (integer_type_node, integer_type_node,
5731 build_pointer_type (pchar_type_node),
5732 NULL_TREE);
5733 main_identifier_node = get_identifier ("main");
5734 ftn_main = build_decl (input_location, FUNCTION_DECL,
5735 main_identifier_node, tmp);
5736 DECL_EXTERNAL (ftn_main) = 0;
5737 TREE_PUBLIC (ftn_main) = 1;
5738 TREE_STATIC (ftn_main) = 1;
5739 DECL_ATTRIBUTES (ftn_main)
5740 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
5741
5742 /* Setup the result declaration (for "return 0"). */
5743 result_decl = build_decl (input_location,
5744 RESULT_DECL, NULL_TREE, integer_type_node);
5745 DECL_ARTIFICIAL (result_decl) = 1;
5746 DECL_IGNORED_P (result_decl) = 1;
5747 DECL_CONTEXT (result_decl) = ftn_main;
5748 DECL_RESULT (ftn_main) = result_decl;
5749
5750 pushdecl (ftn_main);
5751
5752 /* Get the arguments. */
5753
5754 arglist = NULL_TREE;
5755 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
5756
5757 tmp = TREE_VALUE (typelist);
5758 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
5759 DECL_CONTEXT (argc) = ftn_main;
5760 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
5761 TREE_READONLY (argc) = 1;
5762 gfc_finish_decl (argc);
5763 arglist = chainon (arglist, argc);
5764
5765 typelist = TREE_CHAIN (typelist);
5766 tmp = TREE_VALUE (typelist);
5767 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5768 DECL_CONTEXT (argv) = ftn_main;
5769 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5770 TREE_READONLY (argv) = 1;
5771 DECL_BY_REFERENCE (argv) = 1;
5772 gfc_finish_decl (argv);
5773 arglist = chainon (arglist, argv);
5774
5775 DECL_ARGUMENTS (ftn_main) = arglist;
5776 current_function_decl = ftn_main;
5777 announce_function (ftn_main);
5778
5779 rest_of_decl_compilation (ftn_main, 1, 0);
5780 make_decl_rtl (ftn_main);
5781 allocate_struct_function (ftn_main, false);
5782 pushlevel ();
5783
5784 gfc_init_block (&body);
5785
5786 /* Call some libgfortran initialization routines, call then MAIN__(). */
5787
5788 /* Call _gfortran_caf_init (*argc, ***argv). */
5789 if (flag_coarray == GFC_FCOARRAY_LIB)
5790 {
5791 tree pint_type, pppchar_type;
5792 pint_type = build_pointer_type (integer_type_node);
5793 pppchar_type
5794 = build_pointer_type (build_pointer_type (pchar_type_node));
5795
5796 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
5797 gfc_build_addr_expr (pint_type, argc),
5798 gfc_build_addr_expr (pppchar_type, argv));
5799 gfc_add_expr_to_block (&body, tmp);
5800 }
5801
5802 /* Call _gfortran_set_args (argc, argv). */
5803 TREE_USED (argc) = 1;
5804 TREE_USED (argv) = 1;
5805 tmp = build_call_expr_loc (input_location,
5806 gfor_fndecl_set_args, 2, argc, argv);
5807 gfc_add_expr_to_block (&body, tmp);
5808
5809 /* Add a call to set_options to set up the runtime library Fortran
5810 language standard parameters. */
5811 {
5812 tree array_type, array, var;
5813 vec<constructor_elt, va_gc> *v = NULL;
5814 static const int noptions = 7;
5815
5816 /* Passing a new option to the library requires three modifications:
5817 + add it to the tree_cons list below
5818 + change the noptions variable above
5819 + modify the library (runtime/compile_options.c)! */
5820
5821 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5822 build_int_cst (integer_type_node,
5823 gfc_option.warn_std));
5824 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5825 build_int_cst (integer_type_node,
5826 gfc_option.allow_std));
5827 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5828 build_int_cst (integer_type_node, pedantic));
5829 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5830 build_int_cst (integer_type_node, flag_backtrace));
5831 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5832 build_int_cst (integer_type_node, flag_sign_zero));
5833 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5834 build_int_cst (integer_type_node,
5835 (gfc_option.rtcheck
5836 & GFC_RTCHECK_BOUNDS)));
5837 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5838 build_int_cst (integer_type_node,
5839 gfc_option.fpe_summary));
5840
5841 array_type = build_array_type_nelts (integer_type_node, noptions);
5842 array = build_constructor (array_type, v);
5843 TREE_CONSTANT (array) = 1;
5844 TREE_STATIC (array) = 1;
5845
5846 /* Create a static variable to hold the jump table. */
5847 var = build_decl (input_location, VAR_DECL,
5848 create_tmp_var_name ("options"), array_type);
5849 DECL_ARTIFICIAL (var) = 1;
5850 DECL_IGNORED_P (var) = 1;
5851 TREE_CONSTANT (var) = 1;
5852 TREE_STATIC (var) = 1;
5853 TREE_READONLY (var) = 1;
5854 DECL_INITIAL (var) = array;
5855 pushdecl (var);
5856 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5857
5858 tmp = build_call_expr_loc (input_location,
5859 gfor_fndecl_set_options, 2,
5860 build_int_cst (integer_type_node, noptions), var);
5861 gfc_add_expr_to_block (&body, tmp);
5862 }
5863
5864 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5865 the library will raise a FPE when needed. */
5866 if (gfc_option.fpe != 0)
5867 {
5868 tmp = build_call_expr_loc (input_location,
5869 gfor_fndecl_set_fpe, 1,
5870 build_int_cst (integer_type_node,
5871 gfc_option.fpe));
5872 gfc_add_expr_to_block (&body, tmp);
5873 }
5874
5875 /* If this is the main program and an -fconvert option was provided,
5876 add a call to set_convert. */
5877
5878 if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
5879 {
5880 tmp = build_call_expr_loc (input_location,
5881 gfor_fndecl_set_convert, 1,
5882 build_int_cst (integer_type_node, flag_convert));
5883 gfc_add_expr_to_block (&body, tmp);
5884 }
5885
5886 /* If this is the main program and an -frecord-marker option was provided,
5887 add a call to set_record_marker. */
5888
5889 if (flag_record_marker != 0)
5890 {
5891 tmp = build_call_expr_loc (input_location,
5892 gfor_fndecl_set_record_marker, 1,
5893 build_int_cst (integer_type_node,
5894 flag_record_marker));
5895 gfc_add_expr_to_block (&body, tmp);
5896 }
5897
5898 if (flag_max_subrecord_length != 0)
5899 {
5900 tmp = build_call_expr_loc (input_location,
5901 gfor_fndecl_set_max_subrecord_length, 1,
5902 build_int_cst (integer_type_node,
5903 flag_max_subrecord_length));
5904 gfc_add_expr_to_block (&body, tmp);
5905 }
5906
5907 /* Call MAIN__(). */
5908 tmp = build_call_expr_loc (input_location,
5909 fndecl, 0);
5910 gfc_add_expr_to_block (&body, tmp);
5911
5912 /* Mark MAIN__ as used. */
5913 TREE_USED (fndecl) = 1;
5914
5915 /* Coarray: Call _gfortran_caf_finalize(void). */
5916 if (flag_coarray == GFC_FCOARRAY_LIB)
5917 {
5918 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5919 gfc_add_expr_to_block (&body, tmp);
5920 }
5921
5922 /* "return 0". */
5923 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5924 DECL_RESULT (ftn_main),
5925 build_int_cst (integer_type_node, 0));
5926 tmp = build1_v (RETURN_EXPR, tmp);
5927 gfc_add_expr_to_block (&body, tmp);
5928
5929
5930 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5931 decl = getdecls ();
5932
5933 /* Finish off this function and send it for code generation. */
5934 poplevel (1, 1);
5935 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5936
5937 DECL_SAVED_TREE (ftn_main)
5938 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5939 DECL_INITIAL (ftn_main));
5940
5941 /* Output the GENERIC tree. */
5942 dump_function (TDI_original, ftn_main);
5943
5944 cgraph_node::finalize_function (ftn_main, true);
5945
5946 if (old_context)
5947 {
5948 pop_function_context ();
5949 saved_function_decls = saved_parent_function_decls;
5950 }
5951 current_function_decl = old_context;
5952 }
5953
5954
5955 /* Get the result expression for a procedure. */
5956
5957 static tree
5958 get_proc_result (gfc_symbol* sym)
5959 {
5960 if (sym->attr.subroutine || sym == sym->result)
5961 {
5962 if (current_fake_result_decl != NULL)
5963 return TREE_VALUE (current_fake_result_decl);
5964
5965 return NULL_TREE;
5966 }
5967
5968 return sym->result->backend_decl;
5969 }
5970
5971
5972 /* Generate an appropriate return-statement for a procedure. */
5973
5974 tree
5975 gfc_generate_return (void)
5976 {
5977 gfc_symbol* sym;
5978 tree result;
5979 tree fndecl;
5980
5981 sym = current_procedure_symbol;
5982 fndecl = sym->backend_decl;
5983
5984 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5985 result = NULL_TREE;
5986 else
5987 {
5988 result = get_proc_result (sym);
5989
5990 /* Set the return value to the dummy result variable. The
5991 types may be different for scalar default REAL functions
5992 with -ff2c, therefore we have to convert. */
5993 if (result != NULL_TREE)
5994 {
5995 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5996 result = fold_build2_loc (input_location, MODIFY_EXPR,
5997 TREE_TYPE (result), DECL_RESULT (fndecl),
5998 result);
5999 }
6000 }
6001
6002 return build1_v (RETURN_EXPR, result);
6003 }
6004
6005
6006 static void
6007 is_from_ieee_module (gfc_symbol *sym)
6008 {
6009 if (sym->from_intmod == INTMOD_IEEE_FEATURES
6010 || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6011 || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6012 seen_ieee_symbol = 1;
6013 }
6014
6015
6016 static int
6017 is_ieee_module_used (gfc_namespace *ns)
6018 {
6019 seen_ieee_symbol = 0;
6020 gfc_traverse_ns (ns, is_from_ieee_module);
6021 return seen_ieee_symbol;
6022 }
6023
6024
6025 static gfc_omp_clauses *module_oacc_clauses;
6026
6027
6028 static void
6029 add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6030 {
6031 gfc_omp_namelist *n;
6032
6033 n = gfc_get_omp_namelist ();
6034 n->sym = sym;
6035 n->u.map_op = map_op;
6036
6037 if (!module_oacc_clauses)
6038 module_oacc_clauses = gfc_get_omp_clauses ();
6039
6040 if (module_oacc_clauses->lists[OMP_LIST_MAP])
6041 n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6042
6043 module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6044 }
6045
6046
6047 static void
6048 find_module_oacc_declare_clauses (gfc_symbol *sym)
6049 {
6050 if (sym->attr.use_assoc)
6051 {
6052 gfc_omp_map_op map_op;
6053
6054 if (sym->attr.oacc_declare_create)
6055 map_op = OMP_MAP_FORCE_ALLOC;
6056
6057 if (sym->attr.oacc_declare_copyin)
6058 map_op = OMP_MAP_FORCE_TO;
6059
6060 if (sym->attr.oacc_declare_deviceptr)
6061 map_op = OMP_MAP_FORCE_DEVICEPTR;
6062
6063 if (sym->attr.oacc_declare_device_resident)
6064 map_op = OMP_MAP_DEVICE_RESIDENT;
6065
6066 if (sym->attr.oacc_declare_create
6067 || sym->attr.oacc_declare_copyin
6068 || sym->attr.oacc_declare_deviceptr
6069 || sym->attr.oacc_declare_device_resident)
6070 {
6071 sym->attr.referenced = 1;
6072 add_clause (sym, map_op);
6073 }
6074 }
6075 }
6076
6077
6078 void
6079 finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6080 {
6081 gfc_code *code;
6082 gfc_oacc_declare *oc;
6083 locus where = gfc_current_locus;
6084 gfc_omp_clauses *omp_clauses = NULL;
6085 gfc_omp_namelist *n, *p;
6086
6087 gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6088
6089 if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6090 {
6091 gfc_oacc_declare *new_oc;
6092
6093 new_oc = gfc_get_oacc_declare ();
6094 new_oc->next = ns->oacc_declare;
6095 new_oc->clauses = module_oacc_clauses;
6096
6097 ns->oacc_declare = new_oc;
6098 module_oacc_clauses = NULL;
6099 }
6100
6101 if (!ns->oacc_declare)
6102 return;
6103
6104 for (oc = ns->oacc_declare; oc; oc = oc->next)
6105 {
6106 if (oc->module_var)
6107 continue;
6108
6109 if (block)
6110 gfc_error ("Sorry, $!ACC DECLARE at %L is not allowed "
6111 "in BLOCK construct", &oc->loc);
6112
6113
6114 if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6115 {
6116 if (omp_clauses == NULL)
6117 {
6118 omp_clauses = oc->clauses;
6119 continue;
6120 }
6121
6122 for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6123 ;
6124
6125 gcc_assert (p->next == NULL);
6126
6127 p->next = omp_clauses->lists[OMP_LIST_MAP];
6128 omp_clauses = oc->clauses;
6129 }
6130 }
6131
6132 if (!omp_clauses)
6133 return;
6134
6135 for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6136 {
6137 switch (n->u.map_op)
6138 {
6139 case OMP_MAP_DEVICE_RESIDENT:
6140 n->u.map_op = OMP_MAP_FORCE_ALLOC;
6141 break;
6142
6143 default:
6144 break;
6145 }
6146 }
6147
6148 code = XCNEW (gfc_code);
6149 code->op = EXEC_OACC_DECLARE;
6150 code->loc = where;
6151
6152 code->ext.oacc_declare = gfc_get_oacc_declare ();
6153 code->ext.oacc_declare->clauses = omp_clauses;
6154
6155 code->block = XCNEW (gfc_code);
6156 code->block->op = EXEC_OACC_DECLARE;
6157 code->block->loc = where;
6158
6159 if (ns->code)
6160 code->block->next = ns->code;
6161
6162 ns->code = code;
6163
6164 return;
6165 }
6166
6167
6168 /* Generate code for a function. */
6169
6170 void
6171 gfc_generate_function_code (gfc_namespace * ns)
6172 {
6173 tree fndecl;
6174 tree old_context;
6175 tree decl;
6176 tree tmp;
6177 tree fpstate = NULL_TREE;
6178 stmtblock_t init, cleanup;
6179 stmtblock_t body;
6180 gfc_wrapped_block try_block;
6181 tree recurcheckvar = NULL_TREE;
6182 gfc_symbol *sym;
6183 gfc_symbol *previous_procedure_symbol;
6184 int rank, ieee;
6185 bool is_recursive;
6186
6187 sym = ns->proc_name;
6188 previous_procedure_symbol = current_procedure_symbol;
6189 current_procedure_symbol = sym;
6190
6191 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
6192 lost or worse. */
6193 sym->tlink = sym;
6194
6195 /* Create the declaration for functions with global scope. */
6196 if (!sym->backend_decl)
6197 gfc_create_function_decl (ns, false);
6198
6199 fndecl = sym->backend_decl;
6200 old_context = current_function_decl;
6201
6202 if (old_context)
6203 {
6204 push_function_context ();
6205 saved_parent_function_decls = saved_function_decls;
6206 saved_function_decls = NULL_TREE;
6207 }
6208
6209 trans_function_start (sym);
6210
6211 gfc_init_block (&init);
6212
6213 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
6214 {
6215 /* Copy length backend_decls to all entry point result
6216 symbols. */
6217 gfc_entry_list *el;
6218 tree backend_decl;
6219
6220 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
6221 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
6222 for (el = ns->entries; el; el = el->next)
6223 el->sym->result->ts.u.cl->backend_decl = backend_decl;
6224 }
6225
6226 /* Translate COMMON blocks. */
6227 gfc_trans_common (ns);
6228
6229 /* Null the parent fake result declaration if this namespace is
6230 a module function or an external procedures. */
6231 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6232 || ns->parent == NULL)
6233 parent_fake_result_decl = NULL_TREE;
6234
6235 gfc_generate_contained_functions (ns);
6236
6237 nonlocal_dummy_decls = NULL;
6238 nonlocal_dummy_decl_pset = NULL;
6239
6240 has_coarray_vars = false;
6241 generate_local_vars (ns);
6242
6243 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6244 generate_coarray_init (ns);
6245
6246 /* Keep the parent fake result declaration in module functions
6247 or external procedures. */
6248 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6249 || ns->parent == NULL)
6250 current_fake_result_decl = parent_fake_result_decl;
6251 else
6252 current_fake_result_decl = NULL_TREE;
6253
6254 is_recursive = sym->attr.recursive
6255 || (sym->attr.entry_master
6256 && sym->ns->entries->sym->attr.recursive);
6257 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6258 && !is_recursive && !flag_recursive)
6259 {
6260 char * msg;
6261
6262 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
6263 sym->name);
6264 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
6265 TREE_STATIC (recurcheckvar) = 1;
6266 DECL_INITIAL (recurcheckvar) = boolean_false_node;
6267 gfc_add_expr_to_block (&init, recurcheckvar);
6268 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
6269 &sym->declared_at, msg);
6270 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
6271 free (msg);
6272 }
6273
6274 /* Check if an IEEE module is used in the procedure. If so, save
6275 the floating point state. */
6276 ieee = is_ieee_module_used (ns);
6277 if (ieee)
6278 fpstate = gfc_save_fp_state (&init);
6279
6280 /* Now generate the code for the body of this function. */
6281 gfc_init_block (&body);
6282
6283 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6284 && sym->attr.subroutine)
6285 {
6286 tree alternate_return;
6287 alternate_return = gfc_get_fake_result_decl (sym, 0);
6288 gfc_add_modify (&body, alternate_return, integer_zero_node);
6289 }
6290
6291 if (ns->entries)
6292 {
6293 /* Jump to the correct entry point. */
6294 tmp = gfc_trans_entry_master_switch (ns->entries);
6295 gfc_add_expr_to_block (&body, tmp);
6296 }
6297
6298 /* If bounds-checking is enabled, generate code to check passed in actual
6299 arguments against the expected dummy argument attributes (e.g. string
6300 lengths). */
6301 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
6302 add_argument_checking (&body, sym);
6303
6304 finish_oacc_declare (ns, sym, false);
6305
6306 tmp = gfc_trans_code (ns->code);
6307 gfc_add_expr_to_block (&body, tmp);
6308
6309 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6310 || (sym->result && sym->result != sym
6311 && sym->result->ts.type == BT_DERIVED
6312 && sym->result->ts.u.derived->attr.alloc_comp))
6313 {
6314 bool artificial_result_decl = false;
6315 tree result = get_proc_result (sym);
6316 gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
6317
6318 /* Make sure that a function returning an object with
6319 alloc/pointer_components always has a result, where at least
6320 the allocatable/pointer components are set to zero. */
6321 if (result == NULL_TREE && sym->attr.function
6322 && ((sym->result->ts.type == BT_DERIVED
6323 && (sym->attr.allocatable
6324 || sym->attr.pointer
6325 || sym->result->ts.u.derived->attr.alloc_comp
6326 || sym->result->ts.u.derived->attr.pointer_comp))
6327 || (sym->result->ts.type == BT_CLASS
6328 && (CLASS_DATA (sym)->attr.allocatable
6329 || CLASS_DATA (sym)->attr.class_pointer
6330 || CLASS_DATA (sym->result)->attr.alloc_comp
6331 || CLASS_DATA (sym->result)->attr.pointer_comp))))
6332 {
6333 artificial_result_decl = true;
6334 result = gfc_get_fake_result_decl (sym, 0);
6335 }
6336
6337 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
6338 {
6339 if (sym->attr.allocatable && sym->attr.dimension == 0
6340 && sym->result == sym)
6341 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
6342 null_pointer_node));
6343 else if (sym->ts.type == BT_CLASS
6344 && CLASS_DATA (sym)->attr.allocatable
6345 && CLASS_DATA (sym)->attr.dimension == 0
6346 && sym->result == sym)
6347 {
6348 tmp = CLASS_DATA (sym)->backend_decl;
6349 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6350 TREE_TYPE (tmp), result, tmp, NULL_TREE);
6351 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
6352 null_pointer_node));
6353 }
6354 else if (sym->ts.type == BT_DERIVED
6355 && !sym->attr.allocatable)
6356 {
6357 gfc_expr *init_exp;
6358 /* Arrays are not initialized using the default initializer of
6359 their elements. Therefore only check if a default
6360 initializer is available when the result is scalar. */
6361 init_exp = rsym->as ? NULL
6362 : gfc_generate_initializer (&rsym->ts, true);
6363 if (init_exp)
6364 {
6365 tmp = gfc_trans_structure_assign (result, init_exp, 0);
6366 gfc_free_expr (init_exp);
6367 gfc_add_expr_to_block (&init, tmp);
6368 }
6369 else if (rsym->ts.u.derived->attr.alloc_comp)
6370 {
6371 rank = rsym->as ? rsym->as->rank : 0;
6372 tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
6373 rank);
6374 gfc_prepend_expr_to_block (&body, tmp);
6375 }
6376 }
6377 }
6378
6379 if (result == NULL_TREE || artificial_result_decl)
6380 {
6381 /* TODO: move to the appropriate place in resolve.c. */
6382 if (warn_return_type && sym == sym->result)
6383 gfc_warning (OPT_Wreturn_type,
6384 "Return value of function %qs at %L not set",
6385 sym->name, &sym->declared_at);
6386 if (warn_return_type)
6387 TREE_NO_WARNING(sym->backend_decl) = 1;
6388 }
6389 if (result != NULL_TREE)
6390 gfc_add_expr_to_block (&body, gfc_generate_return ());
6391 }
6392
6393 gfc_init_block (&cleanup);
6394
6395 /* Reset recursion-check variable. */
6396 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6397 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
6398 {
6399 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
6400 recurcheckvar = NULL;
6401 }
6402
6403 /* If IEEE modules are loaded, restore the floating-point state. */
6404 if (ieee)
6405 gfc_restore_fp_state (&cleanup, fpstate);
6406
6407 /* Finish the function body and add init and cleanup code. */
6408 tmp = gfc_finish_block (&body);
6409 gfc_start_wrapped_block (&try_block, tmp);
6410 /* Add code to create and cleanup arrays. */
6411 gfc_trans_deferred_vars (sym, &try_block);
6412 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
6413 gfc_finish_block (&cleanup));
6414
6415 /* Add all the decls we created during processing. */
6416 decl = nreverse (saved_function_decls);
6417 while (decl)
6418 {
6419 tree next;
6420
6421 next = DECL_CHAIN (decl);
6422 DECL_CHAIN (decl) = NULL_TREE;
6423 pushdecl (decl);
6424 decl = next;
6425 }
6426 saved_function_decls = NULL_TREE;
6427
6428 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
6429 decl = getdecls ();
6430
6431 /* Finish off this function and send it for code generation. */
6432 poplevel (1, 1);
6433 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6434
6435 DECL_SAVED_TREE (fndecl)
6436 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6437 DECL_INITIAL (fndecl));
6438
6439 if (nonlocal_dummy_decls)
6440 {
6441 BLOCK_VARS (DECL_INITIAL (fndecl))
6442 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
6443 delete nonlocal_dummy_decl_pset;
6444 nonlocal_dummy_decls = NULL;
6445 nonlocal_dummy_decl_pset = NULL;
6446 }
6447
6448 /* Output the GENERIC tree. */
6449 dump_function (TDI_original, fndecl);
6450
6451 /* Store the end of the function, so that we get good line number
6452 info for the epilogue. */
6453 cfun->function_end_locus = input_location;
6454
6455 /* We're leaving the context of this function, so zap cfun.
6456 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6457 tree_rest_of_compilation. */
6458 set_cfun (NULL);
6459
6460 if (old_context)
6461 {
6462 pop_function_context ();
6463 saved_function_decls = saved_parent_function_decls;
6464 }
6465 current_function_decl = old_context;
6466
6467 if (decl_function_context (fndecl))
6468 {
6469 /* Register this function with cgraph just far enough to get it
6470 added to our parent's nested function list.
6471 If there are static coarrays in this function, the nested _caf_init
6472 function has already called cgraph_create_node, which also created
6473 the cgraph node for this function. */
6474 if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
6475 (void) cgraph_node::get_create (fndecl);
6476 }
6477 else
6478 cgraph_node::finalize_function (fndecl, true);
6479
6480 gfc_trans_use_stmts (ns);
6481 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
6482
6483 if (sym->attr.is_main_program)
6484 create_main_function (fndecl);
6485
6486 current_procedure_symbol = previous_procedure_symbol;
6487 }
6488
6489
6490 void
6491 gfc_generate_constructors (void)
6492 {
6493 gcc_assert (gfc_static_ctors == NULL_TREE);
6494 #if 0
6495 tree fnname;
6496 tree type;
6497 tree fndecl;
6498 tree decl;
6499 tree tmp;
6500
6501 if (gfc_static_ctors == NULL_TREE)
6502 return;
6503
6504 fnname = get_file_function_name ("I");
6505 type = build_function_type_list (void_type_node, NULL_TREE);
6506
6507 fndecl = build_decl (input_location,
6508 FUNCTION_DECL, fnname, type);
6509 TREE_PUBLIC (fndecl) = 1;
6510
6511 decl = build_decl (input_location,
6512 RESULT_DECL, NULL_TREE, void_type_node);
6513 DECL_ARTIFICIAL (decl) = 1;
6514 DECL_IGNORED_P (decl) = 1;
6515 DECL_CONTEXT (decl) = fndecl;
6516 DECL_RESULT (fndecl) = decl;
6517
6518 pushdecl (fndecl);
6519
6520 current_function_decl = fndecl;
6521
6522 rest_of_decl_compilation (fndecl, 1, 0);
6523
6524 make_decl_rtl (fndecl);
6525
6526 allocate_struct_function (fndecl, false);
6527
6528 pushlevel ();
6529
6530 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
6531 {
6532 tmp = build_call_expr_loc (input_location,
6533 TREE_VALUE (gfc_static_ctors), 0);
6534 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
6535 }
6536
6537 decl = getdecls ();
6538 poplevel (1, 1);
6539
6540 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6541 DECL_SAVED_TREE (fndecl)
6542 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6543 DECL_INITIAL (fndecl));
6544
6545 free_after_parsing (cfun);
6546 free_after_compilation (cfun);
6547
6548 tree_rest_of_compilation (fndecl);
6549
6550 current_function_decl = NULL_TREE;
6551 #endif
6552 }
6553
6554 /* Translates a BLOCK DATA program unit. This means emitting the
6555 commons contained therein plus their initializations. We also emit
6556 a globally visible symbol to make sure that each BLOCK DATA program
6557 unit remains unique. */
6558
6559 void
6560 gfc_generate_block_data (gfc_namespace * ns)
6561 {
6562 tree decl;
6563 tree id;
6564
6565 /* Tell the backend the source location of the block data. */
6566 if (ns->proc_name)
6567 gfc_set_backend_locus (&ns->proc_name->declared_at);
6568 else
6569 gfc_set_backend_locus (&gfc_current_locus);
6570
6571 /* Process the DATA statements. */
6572 gfc_trans_common (ns);
6573
6574 /* Create a global symbol with the mane of the block data. This is to
6575 generate linker errors if the same name is used twice. It is never
6576 really used. */
6577 if (ns->proc_name)
6578 id = gfc_sym_mangled_function_id (ns->proc_name);
6579 else
6580 id = get_identifier ("__BLOCK_DATA__");
6581
6582 decl = build_decl (input_location,
6583 VAR_DECL, id, gfc_array_index_type);
6584 TREE_PUBLIC (decl) = 1;
6585 TREE_STATIC (decl) = 1;
6586 DECL_IGNORED_P (decl) = 1;
6587
6588 pushdecl (decl);
6589 rest_of_decl_compilation (decl, 1, 0);
6590 }
6591
6592
6593 /* Process the local variables of a BLOCK construct. */
6594
6595 void
6596 gfc_process_block_locals (gfc_namespace* ns)
6597 {
6598 tree decl;
6599
6600 gcc_assert (saved_local_decls == NULL_TREE);
6601 has_coarray_vars = false;
6602
6603 generate_local_vars (ns);
6604
6605 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6606 generate_coarray_init (ns);
6607
6608 decl = nreverse (saved_local_decls);
6609 while (decl)
6610 {
6611 tree next;
6612
6613 next = DECL_CHAIN (decl);
6614 DECL_CHAIN (decl) = NULL_TREE;
6615 pushdecl (decl);
6616 decl = next;
6617 }
6618 saved_local_decls = NULL_TREE;
6619 }
6620
6621
6622 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org