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