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