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