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