]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blob
? search:


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