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