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