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