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