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