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