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