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