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