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