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