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