?  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
blobe54d09817cc626449ffa21b3b9b187b4bdcd99a1
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 /* Associate names can use the hidden string length variable
1749 of their associated target. */
1750 if (sym->ts.type == BT_CHARACTER
1751 && TREE_CODE (length) != INTEGER_CST
1752 && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
1753 {
1754 gfc_finish_var_decl (length, sym);
1755 gcc_assert (!sym->value);
1756 }
1757
1758 gfc_finish_var_decl (decl, sym);
1759
1760 if (sym->ts.type == BT_CHARACTER)
1761 /* Character variables need special handling. */
1762 gfc_allocate_lang_decl (decl);
1763
1764 if (sym->assoc && sym->attr.subref_array_pointer)
1765 sym->attr.pointer = 1;
1766
1767 if (sym->attr.pointer && sym->attr.dimension
1768 && !sym->ts.deferred
1769 && !(sym->attr.select_type_temporary
1770 && !sym->attr.subref_array_pointer))
1771 GFC_DECL_PTR_ARRAY_P (decl) = 1;
1772
1773 if (sym->ts.type == BT_CLASS)
1774 GFC_DECL_CLASS(decl) = 1;
1775
1776 sym->backend_decl = decl;
1777
1778 if (sym->attr.assign)
1779 gfc_add_assign_aux_vars (sym);
1780
1781 if (intrinsic_array_parameter)
1782 {
1783 TREE_STATIC (decl) = 1;
1784 DECL_EXTERNAL (decl) = 0;
1785 }
1786
1787 if (TREE_STATIC (decl)
1788 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1789 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1790 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
1791 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1792 && (flag_coarray != GFC_FCOARRAY_LIB
1793 || !sym->attr.codimension || sym->attr.allocatable)
1794 && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
1795 && !(sym->ts.type == BT_CLASS
1796 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
1797 {
1798 /* Add static initializer. For procedures, it is only needed if
1799 SAVE is specified otherwise they need to be reinitialized
1800 every time the procedure is entered. The TREE_STATIC is
1801 in this case due to -fmax-stack-var-size=. */
1802
1803 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1804 TREE_TYPE (decl), sym->attr.dimension
1805 || (sym->attr.codimension
1806 && sym->attr.allocatable),
1807 sym->attr.pointer || sym->attr.allocatable
1808 || sym->ts.type == BT_CLASS,
1809 sym->attr.proc_pointer);
1810 }
1811
1812 if (!TREE_STATIC (decl)
1813 && POINTER_TYPE_P (TREE_TYPE (decl))
1814 && !sym->attr.pointer
1815 && !sym->attr.allocatable
1816 && !sym->attr.proc_pointer
1817 && !sym->attr.select_type_temporary)
1818 DECL_BY_REFERENCE (decl) = 1;
1819
1820 if (sym->attr.associate_var)
1821 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
1822
1823 if (sym->attr.vtab
1824 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1825 TREE_READONLY (decl) = 1;
1826
1827 return decl;
1828 }
1829
1830
1831 /* Substitute a temporary variable in place of the real one. */
1832
1833 void
1834 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1835 {
1836 save->attr = sym->attr;
1837 save->decl = sym->backend_decl;
1838
1839 gfc_clear_attr (&sym->attr);
1840 sym->attr.referenced = 1;
1841 sym->attr.flavor = FL_VARIABLE;
1842
1843 sym->backend_decl = decl;
1844 }
1845
1846
1847 /* Restore the original variable. */
1848
1849 void
1850 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1851 {
1852 sym->attr = save->attr;
1853 sym->backend_decl = save->decl;
1854 }
1855
1856
1857 /* Declare a procedure pointer. */
1858
1859 static tree
1860 get_proc_pointer_decl (gfc_symbol *sym)
1861 {
1862 tree decl;
1863 tree attributes;
1864
1865 decl = sym->backend_decl;
1866 if (decl)
1867 return decl;
1868
1869 decl = build_decl (input_location,
1870 VAR_DECL, get_identifier (sym->name),
1871 build_pointer_type (gfc_get_function_type (sym)));
1872
1873 if (sym->module)
1874 {
1875 /* Apply name mangling. */
1876 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1877 if (sym->attr.use_assoc)
1878 DECL_IGNORED_P (decl) = 1;
1879 }
1880
1881 if ((sym->ns->proc_name
1882 && sym->ns->proc_name->backend_decl == current_function_decl)
1883 || sym->attr.contained)
1884 gfc_add_decl_to_function (decl);
1885 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1886 gfc_add_decl_to_parent_function (decl);
1887
1888 sym->backend_decl = decl;
1889
1890 /* If a variable is USE associated, it's always external. */
1891 if (sym->attr.use_assoc)
1892 {
1893 DECL_EXTERNAL (decl) = 1;
1894 TREE_PUBLIC (decl) = 1;
1895 }
1896 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1897 {
1898 /* This is the declaration of a module variable. */
1899 TREE_PUBLIC (decl) = 1;
1900 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
1901 {
1902 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
1903 DECL_VISIBILITY_SPECIFIED (decl) = true;
1904 }
1905 TREE_STATIC (decl) = 1;
1906 }
1907
1908 if (!sym->attr.use_assoc
1909 && (sym->attr.save != SAVE_NONE || sym->attr.data
1910 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1911 TREE_STATIC (decl) = 1;
1912
1913 if (TREE_STATIC (decl) && sym->value)
1914 {
1915 /* Add static initializer. */
1916 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1917 TREE_TYPE (decl),
1918 sym->attr.dimension,
1919 false, true);
1920 }
1921
1922 /* Handle threadprivate procedure pointers. */
1923 if (sym->attr.threadprivate
1924 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1925 set_decl_tls_model (decl, decl_default_tls_model (decl));
1926
1927 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1928 decl_attributes (&decl, attributes, 0);
1929
1930 return decl;
1931 }
1932
1933
1934 /* Get a basic decl for an external function. */
1935
1936 tree
1937 gfc_get_extern_function_decl (gfc_symbol * sym)
1938 {
1939 tree type;
1940 tree fndecl;
1941 tree attributes;
1942 gfc_expr e;
1943 gfc_intrinsic_sym *isym;
1944 gfc_expr argexpr;
1945 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1946 tree name;
1947 tree mangled_name;
1948 gfc_gsymbol *gsym;
1949
1950 if (sym->backend_decl)
1951 return sym->backend_decl;
1952
1953 /* We should never be creating external decls for alternate entry points.
1954 The procedure may be an alternate entry point, but we don't want/need
1955 to know that. */
1956 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1957
1958 if (sym->attr.proc_pointer)
1959 return get_proc_pointer_decl (sym);
1960
1961 /* See if this is an external procedure from the same file. If so,
1962 return the backend_decl. */
1963 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
1964 ? sym->binding_label : sym->name);
1965
1966 if (gsym && !gsym->defined)
1967 gsym = NULL;
1968
1969 /* This can happen because of C binding. */
1970 if (gsym && gsym->ns && gsym->ns->proc_name
1971 && gsym->ns->proc_name->attr.flavor == FL_MODULE)
1972 goto module_sym;
1973
1974 if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1975 && !sym->backend_decl
1976 && gsym && gsym->ns
1977 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1978 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1979 {
1980 if (!gsym->ns->proc_name->backend_decl)
1981 {
1982 /* By construction, the external function cannot be
1983 a contained procedure. */
1984 locus old_loc;
1985
1986 gfc_save_backend_locus (&old_loc);
1987 push_cfun (NULL);
1988
1989 gfc_create_function_decl (gsym->ns, true);
1990
1991 pop_cfun ();
1992 gfc_restore_backend_locus (&old_loc);
1993 }
1994
1995 /* If the namespace has entries, the proc_name is the
1996 entry master. Find the entry and use its backend_decl.
1997 otherwise, use the proc_name backend_decl. */
1998 if (gsym->ns->entries)
1999 {
2000 gfc_entry_list *entry = gsym->ns->entries;
2001
2002 for (; entry; entry = entry->next)
2003 {
2004 if (strcmp (gsym->name, entry->sym->name) == 0)
2005 {
2006 sym->backend_decl = entry->sym->backend_decl;
2007 break;
2008 }
2009 }
2010 }
2011 else
2012 sym->backend_decl = gsym->ns->proc_name->backend_decl;
2013
2014 if (sym->backend_decl)
2015 {
2016 /* Avoid problems of double deallocation of the backend declaration
2017 later in gfc_trans_use_stmts; cf. PR 45087. */
2018 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
2019 sym->attr.use_assoc = 0;
2020
2021 return sym->backend_decl;
2022 }
2023 }
2024
2025 /* See if this is a module procedure from the same file. If so,
2026 return the backend_decl. */
2027 if (sym->module)
2028 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
2029
2030 module_sym:
2031 if (gsym && gsym->ns
2032 && (gsym->type == GSYM_MODULE
2033 || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
2034 {
2035 gfc_symbol *s;
2036
2037 s = NULL;
2038 if (gsym->type == GSYM_MODULE)
2039 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
2040 else
2041 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
2042
2043 if (s && s->backend_decl)
2044 {
2045 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
2046 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
2047 true);
2048 else if (sym->ts.type == BT_CHARACTER)
2049 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
2050 sym->backend_decl = s->backend_decl;
2051 return sym->backend_decl;
2052 }
2053 }
2054
2055 if (sym->attr.intrinsic)
2056 {
2057 /* Call the resolution function to get the actual name. This is
2058 a nasty hack which relies on the resolution functions only looking
2059 at the first argument. We pass NULL for the second argument
2060 otherwise things like AINT get confused. */
2061 isym = gfc_find_function (sym->name);
2062 gcc_assert (isym->resolve.f0 != NULL);
2063
2064 memset (&e, 0, sizeof (e));
2065 e.expr_type = EXPR_FUNCTION;
2066
2067 memset (&argexpr, 0, sizeof (argexpr));
2068 gcc_assert (isym->formal);
2069 argexpr.ts = isym->formal->ts;
2070
2071 if (isym->formal->next == NULL)
2072 isym->resolve.f1 (&e, &argexpr);
2073 else
2074 {
2075 if (isym->formal->next->next == NULL)
2076 isym->resolve.f2 (&e, &argexpr, NULL);
2077 else
2078 {
2079 if (isym->formal->next->next->next == NULL)
2080 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
2081 else
2082 {
2083 /* All specific intrinsics take less than 5 arguments. */
2084 gcc_assert (isym->formal->next->next->next->next == NULL);
2085 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
2086 }
2087 }
2088 }
2089
2090 if (flag_f2c
2091 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
2092 || e.ts.type == BT_COMPLEX))
2093 {
2094 /* Specific which needs a different implementation if f2c
2095 calling conventions are used. */
2096 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
2097 }
2098 else
2099 sprintf (s, "_gfortran_specific%s", e.value.function.name);
2100
2101 name = get_identifier (s);
2102 mangled_name = name;
2103 }
2104 else
2105 {
2106 name = gfc_sym_identifier (sym);
2107 mangled_name = gfc_sym_mangled_function_id (sym);
2108 }
2109
2110 type = gfc_get_function_type (sym);
2111 fndecl = build_decl (input_location,
2112 FUNCTION_DECL, name, type);
2113
2114 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2115 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2116 the opposite of declaring a function as static in C). */
2117 DECL_EXTERNAL (fndecl) = 1;
2118 TREE_PUBLIC (fndecl) = 1;
2119
2120 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
2121 decl_attributes (&fndecl, attributes, 0);
2122
2123 gfc_set_decl_assembler_name (fndecl, mangled_name);
2124
2125 /* Set the context of this decl. */
2126 if (0 && sym->ns && sym->ns->proc_name)
2127 {
2128 /* TODO: Add external decls to the appropriate scope. */
2129 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
2130 }
2131 else
2132 {
2133 /* Global declaration, e.g. intrinsic subroutine. */
2134 DECL_CONTEXT (fndecl) = NULL_TREE;
2135 }
2136
2137 /* Set attributes for PURE functions. A call to PURE function in the
2138 Fortran 95 sense is both pure and without side effects in the C
2139 sense. */
2140 if (sym->attr.pure || sym->attr.implicit_pure)
2141 {
2142 if (sym->attr.function && !gfc_return_by_reference (sym))
2143 DECL_PURE_P (fndecl) = 1;
2144 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2145 parameters and don't use alternate returns (is this
2146 allowed?). In that case, calls to them are meaningless, and
2147 can be optimized away. See also in build_function_decl(). */
2148 TREE_SIDE_EFFECTS (fndecl) = 0;
2149 }
2150
2151 /* Mark non-returning functions. */
2152 if (sym->attr.noreturn)
2153 TREE_THIS_VOLATILE(fndecl) = 1;
2154
2155 sym->backend_decl = fndecl;
2156
2157 if (DECL_CONTEXT (fndecl) == NULL_TREE)
2158 pushdecl_top_level (fndecl);
2159
2160 if (sym->formal_ns
2161 && sym->formal_ns->proc_name == sym
2162 && sym->formal_ns->omp_declare_simd)
2163 gfc_trans_omp_declare_simd (sym->formal_ns);
2164
2165 return fndecl;
2166 }
2167
2168
2169 /* Create a declaration for a procedure. For external functions (in the C
2170 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2171 a master function with alternate entry points. */
2172
2173 static void
2174 build_function_decl (gfc_symbol * sym, bool global)
2175 {
2176 tree fndecl, type, attributes;
2177 symbol_attribute attr;
2178 tree result_decl;
2179 gfc_formal_arglist *f;
2180
2181 bool module_procedure = sym->attr.module_procedure
2182 && sym->ns
2183 && sym->ns->proc_name
2184 && sym->ns->proc_name->attr.flavor == FL_MODULE;
2185
2186 gcc_assert (!sym->attr.external || module_procedure);
2187
2188 if (sym->backend_decl)
2189 return;
2190
2191 /* Set the line and filename. sym->declared_at seems to point to the
2192 last statement for subroutines, but it'll do for now. */
2193 gfc_set_backend_locus (&sym->declared_at);
2194
2195 /* Allow only one nesting level. Allow public declarations. */
2196 gcc_assert (current_function_decl == NULL_TREE
2197 || DECL_FILE_SCOPE_P (current_function_decl)
2198 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
2199 == NAMESPACE_DECL));
2200
2201 type = gfc_get_function_type (sym);
2202 fndecl = build_decl (input_location,
2203 FUNCTION_DECL, gfc_sym_identifier (sym), type);
2204
2205 attr = sym->attr;
2206
2207 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2208 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2209 the opposite of declaring a function as static in C). */
2210 DECL_EXTERNAL (fndecl) = 0;
2211
2212 if (sym->attr.access == ACCESS_UNKNOWN && sym->module
2213 && (sym->ns->default_access == ACCESS_PRIVATE
2214 || (sym->ns->default_access == ACCESS_UNKNOWN
2215 && flag_module_private)))
2216 sym->attr.access = ACCESS_PRIVATE;
2217
2218 if (!current_function_decl
2219 && !sym->attr.entry_master && !sym->attr.is_main_program
2220 && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
2221 || sym->attr.public_used))
2222 TREE_PUBLIC (fndecl) = 1;
2223
2224 if (sym->attr.referenced || sym->attr.entry_master)
2225 TREE_USED (fndecl) = 1;
2226
2227 attributes = add_attributes_to_decl (attr, NULL_TREE);
2228 decl_attributes (&fndecl, attributes, 0);
2229
2230 /* Figure out the return type of the declared function, and build a
2231 RESULT_DECL for it. If this is a subroutine with alternate
2232 returns, build a RESULT_DECL for it. */
2233 result_decl = NULL_TREE;
2234 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2235 if (attr.function)
2236 {
2237 if (gfc_return_by_reference (sym))
2238 type = void_type_node;
2239 else
2240 {
2241 if (sym->result != sym)
2242 result_decl = gfc_sym_identifier (sym->result);
2243
2244 type = TREE_TYPE (TREE_TYPE (fndecl));
2245 }
2246 }
2247 else
2248 {
2249 /* Look for alternate return placeholders. */
2250 int has_alternate_returns = 0;
2251 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2252 {
2253 if (f->sym == NULL)
2254 {
2255 has_alternate_returns = 1;
2256 break;
2257 }
2258 }
2259
2260 if (has_alternate_returns)
2261 type = integer_type_node;
2262 else
2263 type = void_type_node;
2264 }
2265
2266 result_decl = build_decl (input_location,
2267 RESULT_DECL, result_decl, type);
2268 DECL_ARTIFICIAL (result_decl) = 1;
2269 DECL_IGNORED_P (result_decl) = 1;
2270 DECL_CONTEXT (result_decl) = fndecl;
2271 DECL_RESULT (fndecl) = result_decl;
2272
2273 /* Don't call layout_decl for a RESULT_DECL.
2274 layout_decl (result_decl, 0); */
2275
2276 /* TREE_STATIC means the function body is defined here. */
2277 TREE_STATIC (fndecl) = 1;
2278
2279 /* Set attributes for PURE functions. A call to a PURE function in the
2280 Fortran 95 sense is both pure and without side effects in the C
2281 sense. */
2282 if (attr.pure || attr.implicit_pure)
2283 {
2284 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2285 including an alternate return. In that case it can also be
2286 marked as PURE. See also in gfc_get_extern_function_decl(). */
2287 if (attr.function && !gfc_return_by_reference (sym))
2288 DECL_PURE_P (fndecl) = 1;
2289 TREE_SIDE_EFFECTS (fndecl) = 0;
2290 }
2291
2292
2293 /* Layout the function declaration and put it in the binding level
2294 of the current function. */
2295
2296 if (global)
2297 pushdecl_top_level (fndecl);
2298 else
2299 pushdecl (fndecl);
2300
2301 /* Perform name mangling if this is a top level or module procedure. */
2302 if (current_function_decl == NULL_TREE)
2303 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
2304
2305 sym->backend_decl = fndecl;
2306 }
2307
2308
2309 /* Create the DECL_ARGUMENTS for a procedure. */
2310
2311 static void
2312 create_function_arglist (gfc_symbol * sym)
2313 {
2314 tree fndecl;
2315 gfc_formal_arglist *f;
2316 tree typelist, hidden_typelist;
2317 tree arglist, hidden_arglist;
2318 tree type;
2319 tree parm;
2320
2321 fndecl = sym->backend_decl;
2322
2323 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2324 the new FUNCTION_DECL node. */
2325 arglist = NULL_TREE;
2326 hidden_arglist = NULL_TREE;
2327 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
2328
2329 if (sym->attr.entry_master)
2330 {
2331 type = TREE_VALUE (typelist);
2332 parm = build_decl (input_location,
2333 PARM_DECL, get_identifier ("__entry"), type);
2334
2335 DECL_CONTEXT (parm) = fndecl;
2336 DECL_ARG_TYPE (parm) = type;
2337 TREE_READONLY (parm) = 1;
2338 gfc_finish_decl (parm);
2339 DECL_ARTIFICIAL (parm) = 1;
2340
2341 arglist = chainon (arglist, parm);
2342 typelist = TREE_CHAIN (typelist);
2343 }
2344
2345 if (gfc_return_by_reference (sym))
2346 {
2347 tree type = TREE_VALUE (typelist), length = NULL;
2348
2349 if (sym->ts.type == BT_CHARACTER)
2350 {
2351 /* Length of character result. */
2352 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2353
2354 length = build_decl (input_location,
2355 PARM_DECL,
2356 get_identifier (".__result"),
2357 len_type);
2358 if (POINTER_TYPE_P (len_type))
2359 {
2360 sym->ts.u.cl->passed_length = length;
2361 TREE_USED (length) = 1;
2362 }
2363 else if (!sym->ts.u.cl->length)
2364 {
2365 sym->ts.u.cl->backend_decl = length;
2366 TREE_USED (length) = 1;
2367 }
2368 gcc_assert (TREE_CODE (length) == PARM_DECL);
2369 DECL_CONTEXT (length) = fndecl;
2370 DECL_ARG_TYPE (length) = len_type;
2371 TREE_READONLY (length) = 1;
2372 DECL_ARTIFICIAL (length) = 1;
2373 gfc_finish_decl (length);
2374 if (sym->ts.u.cl->backend_decl == NULL
2375 || sym->ts.u.cl->backend_decl == length)
2376 {
2377 gfc_symbol *arg;
2378 tree backend_decl;
2379
2380 if (sym->ts.u.cl->backend_decl == NULL)
2381 {
2382 tree len = build_decl (input_location,
2383 VAR_DECL,
2384 get_identifier ("..__result"),
2385 gfc_charlen_type_node);
2386 DECL_ARTIFICIAL (len) = 1;
2387 TREE_USED (len) = 1;
2388 sym->ts.u.cl->backend_decl = len;
2389 }
2390
2391 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2392 arg = sym->result ? sym->result : sym;
2393 backend_decl = arg->backend_decl;
2394 /* Temporary clear it, so that gfc_sym_type creates complete
2395 type. */
2396 arg->backend_decl = NULL;
2397 type = gfc_sym_type (arg);
2398 arg->backend_decl = backend_decl;
2399 type = build_reference_type (type);
2400 }
2401 }
2402
2403 parm = build_decl (input_location,
2404 PARM_DECL, get_identifier ("__result"), type);
2405
2406 DECL_CONTEXT (parm) = fndecl;
2407 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2408 TREE_READONLY (parm) = 1;
2409 DECL_ARTIFICIAL (parm) = 1;
2410 gfc_finish_decl (parm);
2411
2412 arglist = chainon (arglist, parm);
2413 typelist = TREE_CHAIN (typelist);
2414
2415 if (sym->ts.type == BT_CHARACTER)
2416 {
2417 gfc_allocate_lang_decl (parm);
2418 arglist = chainon (arglist, length);
2419 typelist = TREE_CHAIN (typelist);
2420 }
2421 }
2422
2423 hidden_typelist = typelist;
2424 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2425 if (f->sym != NULL) /* Ignore alternate returns. */
2426 hidden_typelist = TREE_CHAIN (hidden_typelist);
2427
2428 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2429 {
2430 char name[GFC_MAX_SYMBOL_LEN + 2];
2431
2432 /* Ignore alternate returns. */
2433 if (f->sym == NULL)
2434 continue;
2435
2436 type = TREE_VALUE (typelist);
2437
2438 if (f->sym->ts.type == BT_CHARACTER
2439 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2440 {
2441 tree len_type = TREE_VALUE (hidden_typelist);
2442 tree length = NULL_TREE;
2443 if (!f->sym->ts.deferred)
2444 gcc_assert (len_type == gfc_charlen_type_node);
2445 else
2446 gcc_assert (POINTER_TYPE_P (len_type));
2447
2448 strcpy (&name[1], f->sym->name);
2449 name[0] = '_';
2450 length = build_decl (input_location,
2451 PARM_DECL, get_identifier (name), len_type);
2452
2453 hidden_arglist = chainon (hidden_arglist, length);
2454 DECL_CONTEXT (length) = fndecl;
2455 DECL_ARTIFICIAL (length) = 1;
2456 DECL_ARG_TYPE (length) = len_type;
2457 TREE_READONLY (length) = 1;
2458 gfc_finish_decl (length);
2459
2460 /* Remember the passed value. */
2461 if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2462 {
2463 /* This can happen if the same type is used for multiple
2464 arguments. We need to copy cl as otherwise
2465 cl->passed_length gets overwritten. */
2466 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2467 }
2468 f->sym->ts.u.cl->passed_length = length;
2469
2470 /* Use the passed value for assumed length variables. */
2471 if (!f->sym->ts.u.cl->length)
2472 {
2473 TREE_USED (length) = 1;
2474 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2475 f->sym->ts.u.cl->backend_decl = length;
2476 }
2477
2478 hidden_typelist = TREE_CHAIN (hidden_typelist);
2479
2480 if (f->sym->ts.u.cl->backend_decl == NULL
2481 || f->sym->ts.u.cl->backend_decl == length)
2482 {
2483 if (POINTER_TYPE_P (len_type))
2484 f->sym->ts.u.cl->backend_decl =
2485 build_fold_indirect_ref_loc (input_location, length);
2486 else if (f->sym->ts.u.cl->backend_decl == NULL)
2487 gfc_create_string_length (f->sym);
2488
2489 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2490 if (f->sym->attr.flavor == FL_PROCEDURE)
2491 type = build_pointer_type (gfc_get_function_type (f->sym));
2492 else
2493 type = gfc_sym_type (f->sym);
2494 }
2495 }
2496 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2497 hence, the optional status cannot be transferred via a NULL pointer.
2498 Thus, we will use a hidden argument in that case. */
2499 else if (f->sym->attr.optional && f->sym->attr.value
2500 && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2501 && !gfc_bt_struct (f->sym->ts.type))
2502 {
2503 tree tmp;
2504 strcpy (&name[1], f->sym->name);
2505 name[0] = '_';
2506 tmp = build_decl (input_location,
2507 PARM_DECL, get_identifier (name),
2508 boolean_type_node);
2509
2510 hidden_arglist = chainon (hidden_arglist, tmp);
2511 DECL_CONTEXT (tmp) = fndecl;
2512 DECL_ARTIFICIAL (tmp) = 1;
2513 DECL_ARG_TYPE (tmp) = boolean_type_node;
2514 TREE_READONLY (tmp) = 1;
2515 gfc_finish_decl (tmp);
2516 }
2517
2518 /* For non-constant length array arguments, make sure they use
2519 a different type node from TYPE_ARG_TYPES type. */
2520 if (f->sym->attr.dimension
2521 && type == TREE_VALUE (typelist)
2522 && TREE_CODE (type) == POINTER_TYPE
2523 && GFC_ARRAY_TYPE_P (type)
2524 && f->sym->as->type != AS_ASSUMED_SIZE
2525 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2526 {
2527 if (f->sym->attr.flavor == FL_PROCEDURE)
2528 type = build_pointer_type (gfc_get_function_type (f->sym));
2529 else
2530 type = gfc_sym_type (f->sym);
2531 }
2532
2533 if (f->sym->attr.proc_pointer)
2534 type = build_pointer_type (type);
2535
2536 if (f->sym->attr.volatile_)
2537 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2538
2539 /* Build the argument declaration. */
2540 parm = build_decl (input_location,
2541 PARM_DECL, gfc_sym_identifier (f->sym), type);
2542
2543 if (f->sym->attr.volatile_)
2544 {
2545 TREE_THIS_VOLATILE (parm) = 1;
2546 TREE_SIDE_EFFECTS (parm) = 1;
2547 }
2548
2549 /* Fill in arg stuff. */
2550 DECL_CONTEXT (parm) = fndecl;
2551 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2552 /* All implementation args except for VALUE are read-only. */
2553 if (!f->sym->attr.value)
2554 TREE_READONLY (parm) = 1;
2555 if (POINTER_TYPE_P (type)
2556 && (!f->sym->attr.proc_pointer
2557 && f->sym->attr.flavor != FL_PROCEDURE))
2558 DECL_BY_REFERENCE (parm) = 1;
2559
2560 gfc_finish_decl (parm);
2561 gfc_finish_decl_attrs (parm, &f->sym->attr);
2562
2563 f->sym->backend_decl = parm;
2564
2565 /* Coarrays which are descriptorless or assumed-shape pass with
2566 -fcoarray=lib the token and the offset as hidden arguments. */
2567 if (flag_coarray == GFC_FCOARRAY_LIB
2568 && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
2569 && !f->sym->attr.allocatable)
2570 || (f->sym->ts.type == BT_CLASS
2571 && CLASS_DATA (f->sym)->attr.codimension
2572 && !CLASS_DATA (f->sym)->attr.allocatable)))
2573 {
2574 tree caf_type;
2575 tree token;
2576 tree offset;
2577
2578 gcc_assert (f->sym->backend_decl != NULL_TREE
2579 && !sym->attr.is_bind_c);
2580 caf_type = f->sym->ts.type == BT_CLASS
2581 ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
2582 : TREE_TYPE (f->sym->backend_decl);
2583
2584 token = build_decl (input_location, PARM_DECL,
2585 create_tmp_var_name ("caf_token"),
2586 build_qualified_type (pvoid_type_node,
2587 TYPE_QUAL_RESTRICT));
2588 if ((f->sym->ts.type != BT_CLASS
2589 && f->sym->as->type != AS_DEFERRED)
2590 || (f->sym->ts.type == BT_CLASS
2591 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2592 {
2593 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2594 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2595 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2596 gfc_allocate_lang_decl (f->sym->backend_decl);
2597 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2598 }
2599 else
2600 {
2601 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2602 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2603 }
2604
2605 DECL_CONTEXT (token) = fndecl;
2606 DECL_ARTIFICIAL (token) = 1;
2607 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2608 TREE_READONLY (token) = 1;
2609 hidden_arglist = chainon (hidden_arglist, token);
2610 gfc_finish_decl (token);
2611
2612 offset = build_decl (input_location, PARM_DECL,
2613 create_tmp_var_name ("caf_offset"),
2614 gfc_array_index_type);
2615
2616 if ((f->sym->ts.type != BT_CLASS
2617 && f->sym->as->type != AS_DEFERRED)
2618 || (f->sym->ts.type == BT_CLASS
2619 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2620 {
2621 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2622 == NULL_TREE);
2623 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2624 }
2625 else
2626 {
2627 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2628 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2629 }
2630 DECL_CONTEXT (offset) = fndecl;
2631 DECL_ARTIFICIAL (offset) = 1;
2632 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2633 TREE_READONLY (offset) = 1;
2634 hidden_arglist = chainon (hidden_arglist, offset);
2635 gfc_finish_decl (offset);
2636 }
2637
2638 arglist = chainon (arglist, parm);
2639 typelist = TREE_CHAIN (typelist);
2640 }
2641
2642 /* Add the hidden string length parameters, unless the procedure
2643 is bind(C). */
2644 if (!sym->attr.is_bind_c)
2645 arglist = chainon (arglist, hidden_arglist);
2646
2647 gcc_assert (hidden_typelist == NULL_TREE
2648 || TREE_VALUE (hidden_typelist) == void_type_node);
2649 DECL_ARGUMENTS (fndecl) = arglist;
2650 }
2651
2652 /* Do the setup necessary before generating the body of a function. */
2653
2654 static void
2655 trans_function_start (gfc_symbol * sym)
2656 {
2657 tree fndecl;
2658
2659 fndecl = sym->backend_decl;
2660
2661 /* Let GCC know the current scope is this function. */
2662 current_function_decl = fndecl;
2663
2664 /* Let the world know what we're about to do. */
2665 announce_function (fndecl);
2666
2667 if (DECL_FILE_SCOPE_P (fndecl))
2668 {
2669 /* Create RTL for function declaration. */
2670 rest_of_decl_compilation (fndecl, 1, 0);
2671 }
2672
2673 /* Create RTL for function definition. */
2674 make_decl_rtl (fndecl);
2675
2676 allocate_struct_function (fndecl, false);
2677
2678 /* function.c requires a push at the start of the function. */
2679 pushlevel ();
2680 }
2681
2682 /* Create thunks for alternate entry points. */
2683
2684 static void
2685 build_entry_thunks (gfc_namespace * ns, bool global)
2686 {
2687 gfc_formal_arglist *formal;
2688 gfc_formal_arglist *thunk_formal;
2689 gfc_entry_list *el;
2690 gfc_symbol *thunk_sym;
2691 stmtblock_t body;
2692 tree thunk_fndecl;
2693 tree tmp;
2694 locus old_loc;
2695
2696 /* This should always be a toplevel function. */
2697 gcc_assert (current_function_decl == NULL_TREE);
2698
2699 gfc_save_backend_locus (&old_loc);
2700 for (el = ns->entries; el; el = el->next)
2701 {
2702 vec<tree, va_gc> *args = NULL;
2703 vec<tree, va_gc> *string_args = NULL;
2704
2705 thunk_sym = el->sym;
2706
2707 build_function_decl (thunk_sym, global);
2708 create_function_arglist (thunk_sym);
2709
2710 trans_function_start (thunk_sym);
2711
2712 thunk_fndecl = thunk_sym->backend_decl;
2713
2714 gfc_init_block (&body);
2715
2716 /* Pass extra parameter identifying this entry point. */
2717 tmp = build_int_cst (gfc_array_index_type, el->id);
2718 vec_safe_push (args, tmp);
2719
2720 if (thunk_sym->attr.function)
2721 {
2722 if (gfc_return_by_reference (ns->proc_name))
2723 {
2724 tree ref = DECL_ARGUMENTS (current_function_decl);
2725 vec_safe_push (args, ref);
2726 if (ns->proc_name->ts.type == BT_CHARACTER)
2727 vec_safe_push (args, DECL_CHAIN (ref));
2728 }
2729 }
2730
2731 for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
2732 formal = formal->next)
2733 {
2734 /* Ignore alternate returns. */
2735 if (formal->sym == NULL)
2736 continue;
2737
2738 /* We don't have a clever way of identifying arguments, so resort to
2739 a brute-force search. */
2740 for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
2741 thunk_formal;
2742 thunk_formal = thunk_formal->next)
2743 {
2744 if (thunk_formal->sym == formal->sym)
2745 break;
2746 }
2747
2748 if (thunk_formal)
2749 {
2750 /* Pass the argument. */
2751 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2752 vec_safe_push (args, thunk_formal->sym->backend_decl);
2753 if (formal->sym->ts.type == BT_CHARACTER)
2754 {
2755 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2756 vec_safe_push (string_args, tmp);
2757 }
2758 }
2759 else
2760 {
2761 /* Pass NULL for a missing argument. */
2762 vec_safe_push (args, null_pointer_node);
2763 if (formal->sym->ts.type == BT_CHARACTER)
2764 {
2765 tmp = build_int_cst (gfc_charlen_type_node, 0);
2766 vec_safe_push (string_args, tmp);
2767 }
2768 }
2769 }
2770
2771 /* Call the master function. */
2772 vec_safe_splice (args, string_args);
2773 tmp = ns->proc_name->backend_decl;
2774 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2775 if (ns->proc_name->attr.mixed_entry_master)
2776 {
2777 tree union_decl, field;
2778 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2779
2780 union_decl = build_decl (input_location,
2781 VAR_DECL, get_identifier ("__result"),
2782 TREE_TYPE (master_type));
2783 DECL_ARTIFICIAL (union_decl) = 1;
2784 DECL_EXTERNAL (union_decl) = 0;
2785 TREE_PUBLIC (union_decl) = 0;
2786 TREE_USED (union_decl) = 1;
2787 layout_decl (union_decl, 0);
2788 pushdecl (union_decl);
2789
2790 DECL_CONTEXT (union_decl) = current_function_decl;
2791 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2792 TREE_TYPE (union_decl), union_decl, tmp);
2793 gfc_add_expr_to_block (&body, tmp);
2794
2795 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2796 field; field = DECL_CHAIN (field))
2797 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2798 thunk_sym->result->name) == 0)
2799 break;
2800 gcc_assert (field != NULL_TREE);
2801 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2802 TREE_TYPE (field), union_decl, field,
2803 NULL_TREE);
2804 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2805 TREE_TYPE (DECL_RESULT (current_function_decl)),
2806 DECL_RESULT (current_function_decl), tmp);
2807 tmp = build1_v (RETURN_EXPR, tmp);
2808 }
2809 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2810 != void_type_node)
2811 {
2812 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2813 TREE_TYPE (DECL_RESULT (current_function_decl)),
2814 DECL_RESULT (current_function_decl), tmp);
2815 tmp = build1_v (RETURN_EXPR, tmp);
2816 }
2817 gfc_add_expr_to_block (&body, tmp);
2818
2819 /* Finish off this function and send it for code generation. */
2820 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2821 tmp = getdecls ();
2822 poplevel (1, 1);
2823 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2824 DECL_SAVED_TREE (thunk_fndecl)
2825 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2826 DECL_INITIAL (thunk_fndecl));
2827
2828 /* Output the GENERIC tree. */
2829 dump_function (TDI_original, thunk_fndecl);
2830
2831 /* Store the end of the function, so that we get good line number
2832 info for the epilogue. */
2833 cfun->function_end_locus = input_location;
2834
2835 /* We're leaving the context of this function, so zap cfun.
2836 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2837 tree_rest_of_compilation. */
2838 set_cfun (NULL);
2839
2840 current_function_decl = NULL_TREE;
2841
2842 cgraph_node::finalize_function (thunk_fndecl, true);
2843
2844 /* We share the symbols in the formal argument list with other entry
2845 points and the master function. Clear them so that they are
2846 recreated for each function. */
2847 for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
2848 formal = formal->next)
2849 if (formal->sym != NULL) /* Ignore alternate returns. */
2850 {
2851 formal->sym->backend_decl = NULL_TREE;
2852 if (formal->sym->ts.type == BT_CHARACTER)
2853 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2854 }
2855
2856 if (thunk_sym->attr.function)
2857 {
2858 if (thunk_sym->ts.type == BT_CHARACTER)
2859 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2860 if (thunk_sym->result->ts.type == BT_CHARACTER)
2861 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2862 }
2863 }
2864
2865 gfc_restore_backend_locus (&old_loc);
2866 }
2867
2868
2869 /* Create a decl for a function, and create any thunks for alternate entry
2870 points. If global is true, generate the function in the global binding
2871 level, otherwise in the current binding level (which can be global). */
2872
2873 void
2874 gfc_create_function_decl (gfc_namespace * ns, bool global)
2875 {
2876 /* Create a declaration for the master function. */
2877 build_function_decl (ns->proc_name, global);
2878
2879 /* Compile the entry thunks. */
2880 if (ns->entries)
2881 build_entry_thunks (ns, global);
2882
2883 /* Now create the read argument list. */
2884 create_function_arglist (ns->proc_name);
2885
2886 if (ns->omp_declare_simd)
2887 gfc_trans_omp_declare_simd (ns);
2888 }
2889
2890 /* Return the decl used to hold the function return value. If
2891 parent_flag is set, the context is the parent_scope. */
2892
2893 tree
2894 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2895 {
2896 tree decl;
2897 tree length;
2898 tree this_fake_result_decl;
2899 tree this_function_decl;
2900
2901 char name[GFC_MAX_SYMBOL_LEN + 10];
2902
2903 if (parent_flag)
2904 {
2905 this_fake_result_decl = parent_fake_result_decl;
2906 this_function_decl = DECL_CONTEXT (current_function_decl);
2907 }
2908 else
2909 {
2910 this_fake_result_decl = current_fake_result_decl;
2911 this_function_decl = current_function_decl;
2912 }
2913
2914 if (sym
2915 && sym->ns->proc_name->backend_decl == this_function_decl
2916 && sym->ns->proc_name->attr.entry_master
2917 && sym != sym->ns->proc_name)
2918 {
2919 tree t = NULL, var;
2920 if (this_fake_result_decl != NULL)
2921 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2922 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2923 break;
2924 if (t)
2925 return TREE_VALUE (t);
2926 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2927
2928 if (parent_flag)
2929 this_fake_result_decl = parent_fake_result_decl;
2930 else
2931 this_fake_result_decl = current_fake_result_decl;
2932
2933 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2934 {
2935 tree field;
2936
2937 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2938 field; field = DECL_CHAIN (field))
2939 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2940 sym->name) == 0)
2941 break;
2942
2943 gcc_assert (field != NULL_TREE);
2944 decl = fold_build3_loc (input_location, COMPONENT_REF,
2945 TREE_TYPE (field), decl, field, NULL_TREE);
2946 }
2947
2948 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2949 if (parent_flag)
2950 gfc_add_decl_to_parent_function (var);
2951 else
2952 gfc_add_decl_to_function (var);
2953
2954 SET_DECL_VALUE_EXPR (var, decl);
2955 DECL_HAS_VALUE_EXPR_P (var) = 1;
2956 GFC_DECL_RESULT (var) = 1;
2957
2958 TREE_CHAIN (this_fake_result_decl)
2959 = tree_cons (get_identifier (sym->name), var,
2960 TREE_CHAIN (this_fake_result_decl));
2961 return var;
2962 }
2963
2964 if (this_fake_result_decl != NULL_TREE)
2965 return TREE_VALUE (this_fake_result_decl);
2966
2967 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2968 sym is NULL. */
2969 if (!sym)
2970 return NULL_TREE;
2971
2972 if (sym->ts.type == BT_CHARACTER)
2973 {
2974 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2975 length = gfc_create_string_length (sym);
2976 else
2977 length = sym->ts.u.cl->backend_decl;
2978 if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE)
2979 gfc_add_decl_to_function (length);
2980 }
2981
2982 if (gfc_return_by_reference (sym))
2983 {
2984 decl = DECL_ARGUMENTS (this_function_decl);
2985
2986 if (sym->ns->proc_name->backend_decl == this_function_decl
2987 && sym->ns->proc_name->attr.entry_master)
2988 decl = DECL_CHAIN (decl);
2989
2990 TREE_USED (decl) = 1;
2991 if (sym->as)
2992 decl = gfc_build_dummy_array_decl (sym, decl);
2993 }
2994 else
2995 {
2996 sprintf (name, "__result_%.20s",
2997 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2998
2999 if (!sym->attr.mixed_entry_master && sym->attr.function)
3000 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3001 VAR_DECL, get_identifier (name),
3002 gfc_sym_type (sym));
3003 else
3004 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
3005 VAR_DECL, get_identifier (name),
3006 TREE_TYPE (TREE_TYPE (this_function_decl)));
3007 DECL_ARTIFICIAL (decl) = 1;
3008 DECL_EXTERNAL (decl) = 0;
3009 TREE_PUBLIC (decl) = 0;
3010 TREE_USED (decl) = 1;
3011 GFC_DECL_RESULT (decl) = 1;
3012 TREE_ADDRESSABLE (decl) = 1;
3013
3014 layout_decl (decl, 0);
3015 gfc_finish_decl_attrs (decl, &sym->attr);
3016
3017 if (parent_flag)
3018 gfc_add_decl_to_parent_function (decl);
3019 else
3020 gfc_add_decl_to_function (decl);
3021 }
3022
3023 if (parent_flag)
3024 parent_fake_result_decl = build_tree_list (NULL, decl);
3025 else
3026 current_fake_result_decl = build_tree_list (NULL, decl);
3027
3028 return decl;
3029 }
3030
3031
3032 /* Builds a function decl. The remaining parameters are the types of the
3033 function arguments. Negative nargs indicates a varargs function. */
3034
3035 static tree
3036 build_library_function_decl_1 (tree name, const char *spec,
3037 tree rettype, int nargs, va_list p)
3038 {
3039 vec<tree, va_gc> *arglist;
3040 tree fntype;
3041 tree fndecl;
3042 int n;
3043
3044 /* Library functions must be declared with global scope. */
3045 gcc_assert (current_function_decl == NULL_TREE);
3046
3047 /* Create a list of the argument types. */
3048 vec_alloc (arglist, abs (nargs));
3049 for (n = abs (nargs); n > 0; n--)
3050 {
3051 tree argtype = va_arg (p, tree);
3052 arglist->quick_push (argtype);
3053 }
3054
3055 /* Build the function type and decl. */
3056 if (nargs >= 0)
3057 fntype = build_function_type_vec (rettype, arglist);
3058 else
3059 fntype = build_varargs_function_type_vec (rettype, arglist);
3060 if (spec)
3061 {
3062 tree attr_args = build_tree_list (NULL_TREE,
3063 build_string (strlen (spec), spec));
3064 tree attrs = tree_cons (get_identifier ("fn spec"),
3065 attr_args, TYPE_ATTRIBUTES (fntype));
3066 fntype = build_type_attribute_variant (fntype, attrs);
3067 }
3068 fndecl = build_decl (input_location,
3069 FUNCTION_DECL, name, fntype);
3070
3071 /* Mark this decl as external. */
3072 DECL_EXTERNAL (fndecl) = 1;
3073 TREE_PUBLIC (fndecl) = 1;
3074
3075 pushdecl (fndecl);
3076
3077 rest_of_decl_compilation (fndecl, 1, 0);
3078
3079 return fndecl;
3080 }
3081
3082 /* Builds a function decl. The remaining parameters are the types of the
3083 function arguments. Negative nargs indicates a varargs function. */
3084
3085 tree
3086 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
3087 {
3088 tree ret;
3089 va_list args;
3090 va_start (args, nargs);
3091 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
3092 va_end (args);
3093 return ret;
3094 }
3095
3096 /* Builds a function decl. The remaining parameters are the types of the
3097 function arguments. Negative nargs indicates a varargs function.
3098 The SPEC parameter specifies the function argument and return type
3099 specification according to the fnspec function type attribute. */
3100
3101 tree
3102 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
3103 tree rettype, int nargs, ...)
3104 {
3105 tree ret;
3106 va_list args;
3107 va_start (args, nargs);
3108 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
3109 va_end (args);
3110 return ret;
3111 }
3112
3113 static void
3114 gfc_build_intrinsic_function_decls (void)
3115 {
3116 tree gfc_int4_type_node = gfc_get_int_type (4);
3117 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
3118 tree gfc_int8_type_node = gfc_get_int_type (8);
3119 tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
3120 tree gfc_int16_type_node = gfc_get_int_type (16);
3121 tree gfc_logical4_type_node = gfc_get_logical_type (4);
3122 tree pchar1_type_node = gfc_get_pchar_type (1);
3123 tree pchar4_type_node = gfc_get_pchar_type (4);
3124
3125 /* String functions. */
3126 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
3127 get_identifier (PREFIX("compare_string")), "..R.R",
3128 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
3129 gfc_charlen_type_node, pchar1_type_node);
3130 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
3131 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
3132
3133 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
3134 get_identifier (PREFIX("concat_string")), "..W.R.R",
3135 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
3136 gfc_charlen_type_node, pchar1_type_node,
3137 gfc_charlen_type_node, pchar1_type_node);
3138 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
3139
3140 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
3141 get_identifier (PREFIX("string_len_trim")), "..R",
3142 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
3143 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
3144 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
3145
3146 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
3147 get_identifier (PREFIX("string_index")), "..R.R.",
3148 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
3149 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
3150 DECL_PURE_P (gfor_fndecl_string_index) = 1;
3151 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
3152
3153 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
3154 get_identifier (PREFIX("string_scan")), "..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_scan) = 1;
3158 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
3159
3160 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
3161 get_identifier (PREFIX("string_verify")), "..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_verify) = 1;
3165 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
3166
3167 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
3168 get_identifier (PREFIX("string_trim")), ".Ww.R",
3169 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3170 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
3171 pchar1_type_node);
3172
3173 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
3174 get_identifier (PREFIX("string_minmax")), ".Ww.R",
3175 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3176 build_pointer_type (pchar1_type_node), integer_type_node,
3177 integer_type_node);
3178
3179 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
3180 get_identifier (PREFIX("adjustl")), ".W.R",
3181 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3182 pchar1_type_node);
3183 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
3184
3185 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
3186 get_identifier (PREFIX("adjustr")), ".W.R",
3187 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
3188 pchar1_type_node);
3189 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
3190
3191 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
3192 get_identifier (PREFIX("select_string")), ".R.R.",
3193 integer_type_node, 4, pvoid_type_node, integer_type_node,
3194 pchar1_type_node, gfc_charlen_type_node);
3195 DECL_PURE_P (gfor_fndecl_select_string) = 1;
3196 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
3197
3198 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
3199 get_identifier (PREFIX("compare_string_char4")), "..R.R",
3200 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
3201 gfc_charlen_type_node, pchar4_type_node);
3202 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
3203 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
3204
3205 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
3206 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
3207 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
3208 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
3209 pchar4_type_node);
3210 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
3211
3212 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
3213 get_identifier (PREFIX("string_len_trim_char4")), "..R",
3214 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
3215 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
3216 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
3217
3218 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
3219 get_identifier (PREFIX("string_index_char4")), "..R.R.",
3220 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
3221 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
3222 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
3223 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
3224
3225 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
3226 get_identifier (PREFIX("string_scan_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_scan_char4) = 1;
3230 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
3231
3232 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
3233 get_identifier (PREFIX("string_verify_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_verify_char4) = 1;
3237 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
3238
3239 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
3240 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
3241 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
3242 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
3243 pchar4_type_node);
3244
3245 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
3246 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
3247 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
3248 build_pointer_type (pchar4_type_node), integer_type_node,
3249 integer_type_node);
3250
3251 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
3252 get_identifier (PREFIX("adjustl_char4")), ".W.R",
3253 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3254 pchar4_type_node);
3255 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
3256
3257 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
3258 get_identifier (PREFIX("adjustr_char4")), ".W.R",
3259 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
3260 pchar4_type_node);
3261 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
3262
3263 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
3264 get_identifier (PREFIX("select_string_char4")), ".R.R.",
3265 integer_type_node, 4, pvoid_type_node, integer_type_node,
3266 pvoid_type_node, gfc_charlen_type_node);
3267 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
3268 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
3269
3270
3271 /* Conversion between character kinds. */
3272
3273 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
3274 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
3275 void_type_node, 3, build_pointer_type (pchar4_type_node),
3276 gfc_charlen_type_node, pchar1_type_node);
3277
3278 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
3279 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
3280 void_type_node, 3, build_pointer_type (pchar1_type_node),
3281 gfc_charlen_type_node, pchar4_type_node);
3282
3283 /* Misc. functions. */
3284
3285 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
3286 get_identifier (PREFIX("ttynam")), ".W",
3287 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3288 integer_type_node);
3289
3290 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
3291 get_identifier (PREFIX("fdate")), ".W",
3292 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
3293
3294 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3295 get_identifier (PREFIX("ctime")), ".W",
3296 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3297 gfc_int8_type_node);
3298
3299 gfor_fndecl_random_init = gfc_build_library_function_decl (
3300 get_identifier (PREFIX("random_init")),
3301 void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
3302 gfc_int4_type_node);
3303
3304 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3305 get_identifier (PREFIX("selected_char_kind")), "..R",
3306 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
3307 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3308 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3309
3310 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
3311 get_identifier (PREFIX("selected_int_kind")), ".R",
3312 gfc_int4_type_node, 1, pvoid_type_node);
3313 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
3314 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
3315
3316 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
3317 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
3318 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
3319 pvoid_type_node);
3320 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
3321 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
3322
3323 gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
3324 get_identifier (PREFIX("system_clock_4")),
3325 void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
3326 gfc_pint4_type_node);
3327
3328 gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
3329 get_identifier (PREFIX("system_clock_8")),
3330 void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
3331 gfc_pint8_type_node);
3332
3333 /* Power functions. */
3334 {
3335 tree ctype, rtype, itype, jtype;
3336 int rkind, ikind, jkind;
3337 #define NIKINDS 3
3338 #define NRKINDS 4
3339 static int ikinds[NIKINDS] = {4, 8, 16};
3340 static int rkinds[NRKINDS] = {4, 8, 10, 16};
3341 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
3342
3343 for (ikind=0; ikind < NIKINDS; ikind++)
3344 {
3345 itype = gfc_get_int_type (ikinds[ikind]);
3346
3347 for (jkind=0; jkind < NIKINDS; jkind++)
3348 {
3349 jtype = gfc_get_int_type (ikinds[jkind]);
3350 if (itype && jtype)
3351 {
3352 sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3353 ikinds[jkind]);
3354 gfor_fndecl_math_powi[jkind][ikind].integer =
3355 gfc_build_library_function_decl (get_identifier (name),
3356 jtype, 2, jtype, itype);
3357 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3358 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3359 }
3360 }
3361
3362 for (rkind = 0; rkind < NRKINDS; rkind ++)
3363 {
3364 rtype = gfc_get_real_type (rkinds[rkind]);
3365 if (rtype && itype)
3366 {
3367 sprintf (name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
3368 ikinds[ikind]);
3369 gfor_fndecl_math_powi[rkind][ikind].real =
3370 gfc_build_library_function_decl (get_identifier (name),
3371 rtype, 2, rtype, itype);
3372 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3373 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3374 }
3375
3376 ctype = gfc_get_complex_type (rkinds[rkind]);
3377 if (ctype && itype)
3378 {
3379 sprintf (name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
3380 ikinds[ikind]);
3381 gfor_fndecl_math_powi[rkind][ikind].cmplx =
3382 gfc_build_library_function_decl (get_identifier (name),
3383 ctype, 2,ctype, itype);
3384 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3385 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3386 }
3387 }
3388 }
3389 #undef NIKINDS
3390 #undef NRKINDS
3391 }
3392
3393 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
3394 get_identifier (PREFIX("ishftc4")),
3395 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
3396 gfc_int4_type_node);
3397 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
3398 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
3399
3400 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
3401 get_identifier (PREFIX("ishftc8")),
3402 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
3403 gfc_int4_type_node);
3404 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3405 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3406
3407 if (gfc_int16_type_node)
3408 {
3409 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3410 get_identifier (PREFIX("ishftc16")),
3411 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
3412 gfc_int4_type_node);
3413 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3414 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3415 }
3416
3417 /* BLAS functions. */
3418 {
3419 tree pint = build_pointer_type (integer_type_node);
3420 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3421 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3422 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3423 tree pz = build_pointer_type
3424 (gfc_get_complex_type (gfc_default_double_kind));
3425
3426 gfor_fndecl_sgemm = gfc_build_library_function_decl
3427 (get_identifier
3428 (flag_underscoring ? "sgemm_" : "sgemm"),
3429 void_type_node, 15, pchar_type_node,
3430 pchar_type_node, pint, pint, pint, ps, ps, pint,
3431 ps, pint, ps, ps, pint, integer_type_node,
3432 integer_type_node);
3433 gfor_fndecl_dgemm = gfc_build_library_function_decl
3434 (get_identifier
3435 (flag_underscoring ? "dgemm_" : "dgemm"),
3436 void_type_node, 15, pchar_type_node,
3437 pchar_type_node, pint, pint, pint, pd, pd, pint,
3438 pd, pint, pd, pd, pint, integer_type_node,
3439 integer_type_node);
3440 gfor_fndecl_cgemm = gfc_build_library_function_decl
3441 (get_identifier
3442 (flag_underscoring ? "cgemm_" : "cgemm"),
3443 void_type_node, 15, pchar_type_node,
3444 pchar_type_node, pint, pint, pint, pc, pc, pint,
3445 pc, pint, pc, pc, pint, integer_type_node,
3446 integer_type_node);
3447 gfor_fndecl_zgemm = gfc_build_library_function_decl
3448 (get_identifier
3449 (flag_underscoring ? "zgemm_" : "zgemm"),
3450 void_type_node, 15, pchar_type_node,
3451 pchar_type_node, pint, pint, pint, pz, pz, pint,
3452 pz, pint, pz, pz, pint, integer_type_node,
3453 integer_type_node);
3454 }
3455
3456 /* Other functions. */
3457 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3458 get_identifier (PREFIX("size0")), ".R",
3459 gfc_array_index_type, 1, pvoid_type_node);
3460 DECL_PURE_P (gfor_fndecl_size0) = 1;
3461 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3462
3463 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3464 get_identifier (PREFIX("size1")), ".R",
3465 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3466 DECL_PURE_P (gfor_fndecl_size1) = 1;
3467 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3468
3469 gfor_fndecl_iargc = gfc_build_library_function_decl (
3470 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3471 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3472
3473 gfor_fndecl_kill_sub = gfc_build_library_function_decl (
3474 get_identifier (PREFIX ("kill_sub")), void_type_node,
3475 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node);
3476
3477 gfor_fndecl_kill = gfc_build_library_function_decl (
3478 get_identifier (PREFIX ("kill")), gfc_int4_type_node,
3479 2, gfc_int4_type_node, gfc_int4_type_node);
3480 }
3481
3482
3483 /* Make prototypes for runtime library functions. */
3484
3485 void
3486 gfc_build_builtin_function_decls (void)
3487 {
3488 tree gfc_int8_type_node = gfc_get_int_type (8);
3489
3490 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3491 get_identifier (PREFIX("stop_numeric")),
3492 void_type_node, 2, integer_type_node, boolean_type_node);
3493 /* STOP doesn't return. */
3494 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3495
3496 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3497 get_identifier (PREFIX("stop_string")), ".R.",
3498 void_type_node, 3, pchar_type_node, size_type_node,
3499 boolean_type_node);
3500 /* STOP doesn't return. */
3501 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3502
3503 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3504 get_identifier (PREFIX("error_stop_numeric")),
3505 void_type_node, 2, integer_type_node, boolean_type_node);
3506 /* ERROR STOP doesn't return. */
3507 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3508
3509 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3510 get_identifier (PREFIX("error_stop_string")), ".R.",
3511 void_type_node, 3, pchar_type_node, size_type_node,
3512 boolean_type_node);
3513 /* ERROR STOP doesn't return. */
3514 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3515
3516 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3517 get_identifier (PREFIX("pause_numeric")),
3518 void_type_node, 1, gfc_int8_type_node);
3519
3520 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3521 get_identifier (PREFIX("pause_string")), ".R.",
3522 void_type_node, 2, pchar_type_node, size_type_node);
3523
3524 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3525 get_identifier (PREFIX("runtime_error")), ".R",
3526 void_type_node, -1, pchar_type_node);
3527 /* The runtime_error function does not return. */
3528 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3529
3530 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3531 get_identifier (PREFIX("runtime_error_at")), ".RR",
3532 void_type_node, -2, pchar_type_node, pchar_type_node);
3533 /* The runtime_error_at function does not return. */
3534 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3535
3536 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3537 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3538 void_type_node, -2, pchar_type_node, pchar_type_node);
3539
3540 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3541 get_identifier (PREFIX("generate_error")), ".R.R",
3542 void_type_node, 3, pvoid_type_node, integer_type_node,
3543 pchar_type_node);
3544
3545 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3546 get_identifier (PREFIX("os_error")), ".R",
3547 void_type_node, 1, pchar_type_node);
3548 /* The runtime_error function does not return. */
3549 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3550
3551 gfor_fndecl_set_args = gfc_build_library_function_decl (
3552 get_identifier (PREFIX("set_args")),
3553 void_type_node, 2, integer_type_node,
3554 build_pointer_type (pchar_type_node));
3555
3556 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3557 get_identifier (PREFIX("set_fpe")),
3558 void_type_node, 1, integer_type_node);
3559
3560 gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl (
3561 get_identifier (PREFIX("ieee_procedure_entry")),
3562 void_type_node, 1, pvoid_type_node);
3563
3564 gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl (
3565 get_identifier (PREFIX("ieee_procedure_exit")),
3566 void_type_node, 1, pvoid_type_node);
3567
3568 /* Keep the array dimension in sync with the call, later in this file. */
3569 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3570 get_identifier (PREFIX("set_options")), "..R",
3571 void_type_node, 2, integer_type_node,
3572 build_pointer_type (integer_type_node));
3573
3574 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3575 get_identifier (PREFIX("set_convert")),
3576 void_type_node, 1, integer_type_node);
3577
3578 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3579 get_identifier (PREFIX("set_record_marker")),
3580 void_type_node, 1, integer_type_node);
3581
3582 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3583 get_identifier (PREFIX("set_max_subrecord_length")),
3584 void_type_node, 1, integer_type_node);
3585
3586 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3587 get_identifier (PREFIX("internal_pack")), ".r",
3588 pvoid_type_node, 1, pvoid_type_node);
3589
3590 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3591 get_identifier (PREFIX("internal_unpack")), ".wR",
3592 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3593
3594 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3595 get_identifier (PREFIX("associated")), ".RR",
3596 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3597 DECL_PURE_P (gfor_fndecl_associated) = 1;
3598 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3599
3600 /* Coarray library calls. */
3601 if (flag_coarray == GFC_FCOARRAY_LIB)
3602 {
3603 tree pint_type, pppchar_type;
3604
3605 pint_type = build_pointer_type (integer_type_node);
3606 pppchar_type
3607 = build_pointer_type (build_pointer_type (pchar_type_node));
3608
3609 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3610 get_identifier (PREFIX("caf_init")), void_type_node,
3611 2, pint_type, pppchar_type);
3612
3613 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3614 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3615
3616 gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
3617 get_identifier (PREFIX("caf_this_image")), integer_type_node,
3618 1, integer_type_node);
3619
3620 gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
3621 get_identifier (PREFIX("caf_num_images")), integer_type_node,
3622 2, integer_type_node, integer_type_node);
3623
3624 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3625 get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7,
3626 size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
3627 pint_type, pchar_type_node, size_type_node);
3628
3629 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3630 get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5,
3631 ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
3632 size_type_node);
3633
3634 gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
3635 get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10,
3636 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3637 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3638 boolean_type_node, pint_type);
3639
3640 gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
3641 get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node, 11,
3642 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3643 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3644 boolean_type_node, pint_type, pvoid_type_node);
3645
3646 gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
3647 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
3648 void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
3649 pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
3650 integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
3651 integer_type_node, boolean_type_node, integer_type_node);
3652
3653 gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
3654 get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node,
3655 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3656 pvoid_type_node, integer_type_node, integer_type_node,
3657 boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3658
3659 gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
3660 get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR",
3661 void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3662 pvoid_type_node, integer_type_node, integer_type_node,
3663 boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3664
3665 gfor_fndecl_caf_sendget_by_ref
3666 = gfc_build_library_function_decl_with_spec (
3667 get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR",
3668 void_type_node, 13, pvoid_type_node, integer_type_node,
3669 pvoid_type_node, pvoid_type_node, integer_type_node,
3670 pvoid_type_node, integer_type_node, integer_type_node,
3671 boolean_type_node, pint_type, pint_type, integer_type_node,
3672 integer_type_node);
3673
3674 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3675 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3676 3, pint_type, pchar_type_node, size_type_node);
3677
3678 gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
3679 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node,
3680 3, pint_type, pchar_type_node, size_type_node);
3681
3682 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3683 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3684 5, integer_type_node, pint_type, pint_type,
3685 pchar_type_node, size_type_node);
3686
3687 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3688 get_identifier (PREFIX("caf_error_stop")),
3689 void_type_node, 1, integer_type_node);
3690 /* CAF's ERROR STOP doesn't return. */
3691 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3692
3693 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3694 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3695 void_type_node, 2, pchar_type_node, size_type_node);
3696 /* CAF's ERROR STOP doesn't return. */
3697 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3698
3699 gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec (
3700 get_identifier (PREFIX("caf_stop_numeric")), ".R.",
3701 void_type_node, 1, integer_type_node);
3702 /* CAF's STOP doesn't return. */
3703 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
3704
3705 gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
3706 get_identifier (PREFIX("caf_stop_str")), ".R.",
3707 void_type_node, 2, pchar_type_node, size_type_node);
3708 /* CAF's STOP doesn't return. */
3709 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
3710
3711 gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
3712 get_identifier (PREFIX("caf_atomic_define")), "R..RW",
3713 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3714 pvoid_type_node, pint_type, integer_type_node, integer_type_node);
3715
3716 gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
3717 get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
3718 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3719 pvoid_type_node, pint_type, integer_type_node, integer_type_node);
3720
3721 gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
3722 get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
3723 void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
3724 pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
3725 integer_type_node, integer_type_node);
3726
3727 gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
3728 get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
3729 void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
3730 integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
3731 integer_type_node, integer_type_node);
3732
3733 gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
3734 get_identifier (PREFIX("caf_lock")), "R..WWW",
3735 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3736 pint_type, pint_type, pchar_type_node, size_type_node);
3737
3738 gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
3739 get_identifier (PREFIX("caf_unlock")), "R..WW",
3740 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3741 pint_type, pchar_type_node, size_type_node);
3742
3743 gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
3744 get_identifier (PREFIX("caf_event_post")), "R..WW",
3745 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3746 pint_type, pchar_type_node, size_type_node);
3747
3748 gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
3749 get_identifier (PREFIX("caf_event_wait")), "R..WW",
3750 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3751 pint_type, pchar_type_node, size_type_node);
3752
3753 gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
3754 get_identifier (PREFIX("caf_event_query")), "R..WW",
3755 void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
3756 pint_type, pint_type);
3757
3758 gfor_fndecl_caf_fail_image = gfc_build_library_function_decl (
3759 get_identifier (PREFIX("caf_fail_image")), void_type_node, 0);
3760 /* CAF's FAIL doesn't return. */
3761 TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1;
3762
3763 gfor_fndecl_caf_failed_images
3764 = gfc_build_library_function_decl_with_spec (
3765 get_identifier (PREFIX("caf_failed_images")), "WRR",
3766 void_type_node, 3, pvoid_type_node, ppvoid_type_node,
3767 integer_type_node);
3768
3769 gfor_fndecl_caf_form_team
3770 = gfc_build_library_function_decl_with_spec (
3771 get_identifier (PREFIX("caf_form_team")), "RWR",
3772 void_type_node, 3, integer_type_node, ppvoid_type_node,
3773 integer_type_node);
3774
3775 gfor_fndecl_caf_change_team
3776 = gfc_build_library_function_decl_with_spec (
3777 get_identifier (PREFIX("caf_change_team")), "RR",
3778 void_type_node, 2, ppvoid_type_node,
3779 integer_type_node);
3780
3781 gfor_fndecl_caf_end_team
3782 = gfc_build_library_function_decl (
3783 get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
3784
3785 gfor_fndecl_caf_get_team
3786 = gfc_build_library_function_decl_with_spec (
3787 get_identifier (PREFIX("caf_get_team")), "R",
3788 void_type_node, 1, integer_type_node);
3789
3790 gfor_fndecl_caf_sync_team
3791 = gfc_build_library_function_decl_with_spec (
3792 get_identifier (PREFIX("caf_sync_team")), "RR",
3793 void_type_node, 2, ppvoid_type_node,
3794 integer_type_node);
3795
3796 gfor_fndecl_caf_team_number
3797 = gfc_build_library_function_decl_with_spec (
3798 get_identifier (PREFIX("caf_team_number")), "R",
3799 integer_type_node, 1, integer_type_node);
3800
3801 gfor_fndecl_caf_image_status
3802 = gfc_build_library_function_decl_with_spec (
3803 get_identifier (PREFIX("caf_image_status")), "RR",
3804 integer_type_node, 2, integer_type_node, ppvoid_type_node);
3805
3806 gfor_fndecl_caf_stopped_images
3807 = gfc_build_library_function_decl_with_spec (
3808 get_identifier (PREFIX("caf_stopped_images")), "WRR",
3809 void_type_node, 3, pvoid_type_node, ppvoid_type_node,
3810 integer_type_node);
3811
3812 gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
3813 get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
3814 void_type_node, 5, pvoid_type_node, integer_type_node,
3815 pint_type, pchar_type_node, size_type_node);
3816
3817 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
3818 get_identifier (PREFIX("caf_co_max")), "W.WW",
3819 void_type_node, 6, pvoid_type_node, integer_type_node,
3820 pint_type, pchar_type_node, integer_type_node, size_type_node);
3821
3822 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
3823 get_identifier (PREFIX("caf_co_min")), "W.WW",
3824 void_type_node, 6, pvoid_type_node, integer_type_node,
3825 pint_type, pchar_type_node, integer_type_node, size_type_node);
3826
3827 gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
3828 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
3829 void_type_node, 8, pvoid_type_node,
3830 build_pointer_type (build_varargs_function_type_list (void_type_node,
3831 NULL_TREE)),
3832 integer_type_node, integer_type_node, pint_type, pchar_type_node,
3833 integer_type_node, size_type_node);
3834
3835 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
3836 get_identifier (PREFIX("caf_co_sum")), "W.WW",
3837 void_type_node, 5, pvoid_type_node, integer_type_node,
3838 pint_type, pchar_type_node, size_type_node);
3839
3840 gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
3841 get_identifier (PREFIX("caf_is_present")), "RRR",
3842 integer_type_node, 3, pvoid_type_node, integer_type_node,
3843 pvoid_type_node);
3844 }
3845
3846 gfc_build_intrinsic_function_decls ();
3847 gfc_build_intrinsic_lib_fndecls ();
3848 gfc_build_io_library_fndecls ();
3849 }
3850
3851
3852 /* Evaluate the length of dummy character variables. */
3853
3854 static void
3855 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3856 gfc_wrapped_block *block)
3857 {
3858 stmtblock_t init;
3859
3860 gfc_finish_decl (cl->backend_decl);
3861
3862 gfc_start_block (&init);
3863
3864 /* Evaluate the string length expression. */
3865 gfc_conv_string_length (cl, NULL, &init);
3866
3867 gfc_trans_vla_type_sizes (sym, &init);
3868
3869 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3870 }
3871
3872
3873 /* Allocate and cleanup an automatic character variable. */
3874
3875 static void
3876 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3877 {
3878 stmtblock_t init;
3879 tree decl;
3880 tree tmp;
3881
3882 gcc_assert (sym->backend_decl);
3883 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3884
3885 gfc_init_block (&init);
3886
3887 /* Evaluate the string length expression. */
3888 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3889
3890 gfc_trans_vla_type_sizes (sym, &init);
3891
3892 decl = sym->backend_decl;
3893
3894 /* Emit a DECL_EXPR for this variable, which will cause the
3895 gimplifier to allocate storage, and all that good stuff. */
3896 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3897 gfc_add_expr_to_block (&init, tmp);
3898
3899 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3900 }
3901
3902 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3903
3904 static void
3905 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3906 {
3907 stmtblock_t init;
3908
3909 gcc_assert (sym->backend_decl);
3910 gfc_start_block (&init);
3911
3912 /* Set the initial value to length. See the comments in
3913 function gfc_add_assign_aux_vars in this file. */
3914 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3915 build_int_cst (gfc_charlen_type_node, -2));
3916
3917 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3918 }
3919
3920 static void
3921 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3922 {
3923 tree t = *tp, var, val;
3924
3925 if (t == NULL || t == error_mark_node)
3926 return;
3927 if (TREE_CONSTANT (t) || DECL_P (t))
3928 return;
3929
3930 if (TREE_CODE (t) == SAVE_EXPR)
3931 {
3932 if (SAVE_EXPR_RESOLVED_P (t))
3933 {
3934 *tp = TREE_OPERAND (t, 0);
3935 return;
3936 }
3937 val = TREE_OPERAND (t, 0);
3938 }
3939 else
3940 val = t;
3941
3942 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3943 gfc_add_decl_to_function (var);
3944 gfc_add_modify (body, var, unshare_expr (val));
3945 if (TREE_CODE (t) == SAVE_EXPR)
3946 TREE_OPERAND (t, 0) = var;
3947 *tp = var;
3948 }
3949
3950 static void
3951 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3952 {
3953 tree t;
3954
3955 if (type == NULL || type == error_mark_node)
3956 return;
3957
3958 type = TYPE_MAIN_VARIANT (type);
3959
3960 if (TREE_CODE (type) == INTEGER_TYPE)
3961 {
3962 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3963 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3964
3965 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3966 {
3967 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3968 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3969 }
3970 }
3971 else if (TREE_CODE (type) == ARRAY_TYPE)
3972 {
3973 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3974 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3975 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3976 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3977
3978 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3979 {
3980 TYPE_SIZE (t) = TYPE_SIZE (type);
3981 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3982 }
3983 }
3984 }
3985
3986 /* Make sure all type sizes and array domains are either constant,
3987 or variable or parameter decls. This is a simplified variant
3988 of gimplify_type_sizes, but we can't use it here, as none of the
3989 variables in the expressions have been gimplified yet.
3990 As type sizes and domains for various variable length arrays
3991 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3992 time, without this routine gimplify_type_sizes in the middle-end
3993 could result in the type sizes being gimplified earlier than where
3994 those variables are initialized. */
3995
3996 void
3997 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3998 {
3999 tree type = TREE_TYPE (sym->backend_decl);
4000
4001 if (TREE_CODE (type) == FUNCTION_TYPE
4002 && (sym->attr.function || sym->attr.result || sym->attr.entry))
4003 {
4004 if (! current_fake_result_decl)
4005 return;
4006
4007 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
4008 }
4009
4010 while (POINTER_TYPE_P (type))
4011 type = TREE_TYPE (type);
4012
4013 if (GFC_DESCRIPTOR_TYPE_P (type))
4014 {
4015 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
4016
4017 while (POINTER_TYPE_P (etype))
4018 etype = TREE_TYPE (etype);
4019
4020 gfc_trans_vla_type_sizes_1 (etype, body);
4021 }
4022
4023 gfc_trans_vla_type_sizes_1 (type, body);
4024 }
4025
4026
4027 /* Initialize a derived type by building an lvalue from the symbol
4028 and using trans_assignment to do the work. Set dealloc to false
4029 if no deallocation prior the assignment is needed. */
4030 void
4031 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
4032 {
4033 gfc_expr *e;
4034 tree tmp;
4035 tree present;
4036
4037 gcc_assert (block);
4038
4039 /* Initialization of PDTs is done elsewhere. */
4040 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
4041 return;
4042
4043 gcc_assert (!sym->attr.allocatable);
4044 gfc_set_sym_referenced (sym);
4045 e = gfc_lval_expr_from_sym (sym);
4046 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
4047 if (sym->attr.dummy && (sym->attr.optional
4048 || sym->ns->proc_name->attr.entry_master))
4049 {
4050 present = gfc_conv_expr_present (sym);
4051 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
4052 tmp, build_empty_stmt (input_location));
4053 }
4054 gfc_add_expr_to_block (block, tmp);
4055 gfc_free_expr (e);
4056 }
4057
4058
4059 /* Initialize INTENT(OUT) derived type dummies. As well as giving
4060 them their default initializer, if they do not have allocatable
4061 components, they have their allocatable components deallocated. */
4062
4063 static void
4064 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4065 {
4066 stmtblock_t init;
4067 gfc_formal_arglist *f;
4068 tree tmp;
4069 tree present;
4070
4071 gfc_init_block (&init);
4072 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4073 if (f->sym && f->sym->attr.intent == INTENT_OUT
4074 && !f->sym->attr.pointer
4075 && f->sym->ts.type == BT_DERIVED)
4076 {
4077 tmp = NULL_TREE;
4078
4079 /* Note: Allocatables are excluded as they are already handled
4080 by the caller. */
4081 if (!f->sym->attr.allocatable
4082 && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
4083 {
4084 stmtblock_t block;
4085 gfc_expr *e;
4086
4087 gfc_init_block (&block);
4088 f->sym->attr.referenced = 1;
4089 e = gfc_lval_expr_from_sym (f->sym);
4090 gfc_add_finalizer_call (&block, e);
4091 gfc_free_expr (e);
4092 tmp = gfc_finish_block (&block);
4093 }
4094
4095 if (tmp == NULL_TREE && !f->sym->attr.allocatable
4096 && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
4097 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
4098 f->sym->backend_decl,
4099 f->sym->as ? f->sym->as->rank : 0);
4100
4101 if (tmp != NULL_TREE && (f->sym->attr.optional
4102 || f->sym->ns->proc_name->attr.entry_master))
4103 {
4104 present = gfc_conv_expr_present (f->sym);
4105 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4106 present, tmp, build_empty_stmt (input_location));
4107 }
4108
4109 if (tmp != NULL_TREE)
4110 gfc_add_expr_to_block (&init, tmp);
4111 else if (f->sym->value && !f->sym->attr.allocatable)
4112 gfc_init_default_dt (f->sym, &init, true);
4113 }
4114 else if (f->sym && f->sym->attr.intent == INTENT_OUT
4115 && f->sym->ts.type == BT_CLASS
4116 && !CLASS_DATA (f->sym)->attr.class_pointer
4117 && !CLASS_DATA (f->sym)->attr.allocatable)
4118 {
4119 stmtblock_t block;
4120 gfc_expr *e;
4121
4122 gfc_init_block (&block);
4123 f->sym->attr.referenced = 1;
4124 e = gfc_lval_expr_from_sym (f->sym);
4125 gfc_add_finalizer_call (&block, e);
4126 gfc_free_expr (e);
4127 tmp = gfc_finish_block (&block);
4128
4129 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
4130 {
4131 present = gfc_conv_expr_present (f->sym);
4132 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
4133 present, tmp,
4134 build_empty_stmt (input_location));
4135 }
4136
4137 gfc_add_expr_to_block (&init, tmp);
4138 }
4139
4140 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4141 }
4142
4143
4144 /* Helper function to manage deferred string lengths. */
4145
4146 static tree
4147 gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
4148 locus *loc)
4149 {
4150 tree tmp;
4151
4152 /* Character length passed by reference. */
4153 tmp = sym->ts.u.cl->passed_length;
4154 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4155 tmp = fold_convert (gfc_charlen_type_node, tmp);
4156
4157 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4158 /* Zero the string length when entering the scope. */
4159 gfc_add_modify (init, sym->ts.u.cl->backend_decl,
4160 build_int_cst (gfc_charlen_type_node, 0));
4161 else
4162 {
4163 tree tmp2;
4164
4165 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
4166 gfc_charlen_type_node,
4167 sym->ts.u.cl->backend_decl, tmp);
4168 if (sym->attr.optional)
4169 {
4170 tree present = gfc_conv_expr_present (sym);
4171 tmp2 = build3_loc (input_location, COND_EXPR,
4172 void_type_node, present, tmp2,
4173 build_empty_stmt (input_location));
4174 }
4175 gfc_add_expr_to_block (init, tmp2);
4176 }
4177
4178 gfc_restore_backend_locus (loc);
4179
4180 /* Pass the final character length back. */
4181 if (sym->attr.intent != INTENT_IN)
4182 {
4183 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4184 gfc_charlen_type_node, tmp,
4185 sym->ts.u.cl->backend_decl);
4186 if (sym->attr.optional)
4187 {
4188 tree present = gfc_conv_expr_present (sym);
4189 tmp = build3_loc (input_location, COND_EXPR,
4190 void_type_node, present, tmp,
4191 build_empty_stmt (input_location));
4192 }
4193 }
4194 else
4195 tmp = NULL_TREE;
4196
4197 return tmp;
4198 }
4199
4200
4201 /* Get the result expression for a procedure. */
4202
4203 static tree
4204 get_proc_result (gfc_symbol* sym)
4205 {
4206 if (sym->attr.subroutine || sym == sym->result)
4207 {
4208 if (current_fake_result_decl != NULL)
4209 return TREE_VALUE (current_fake_result_decl);
4210
4211 return NULL_TREE;
4212 }
4213
4214 return sym->result->backend_decl;
4215 }
4216
4217
4218 /* Generate function entry and exit code, and add it to the function body.
4219 This includes:
4220 Allocation and initialization of array variables.
4221 Allocation of character string variables.
4222 Initialization and possibly repacking of dummy arrays.
4223 Initialization of ASSIGN statement auxiliary variable.
4224 Initialization of ASSOCIATE names.
4225 Automatic deallocation. */
4226
4227 void
4228 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
4229 {
4230 locus loc;
4231 gfc_symbol *sym;
4232 gfc_formal_arglist *f;
4233 stmtblock_t tmpblock;
4234 bool seen_trans_deferred_array = false;
4235 bool is_pdt_type = false;
4236 tree tmp = NULL;
4237 gfc_expr *e;
4238 gfc_se se;
4239 stmtblock_t init;
4240
4241 /* Deal with implicit return variables. Explicit return variables will
4242 already have been added. */
4243 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
4244 {
4245 if (!current_fake_result_decl)
4246 {
4247 gfc_entry_list *el = NULL;
4248 if (proc_sym->attr.entry_master)
4249 {
4250 for (el = proc_sym->ns->entries; el; el = el->next)
4251 if (el->sym != el->sym->result)
4252 break;
4253 }
4254 /* TODO: move to the appropriate place in resolve.c. */
4255 if (warn_return_type > 0 && el == NULL)
4256 gfc_warning (OPT_Wreturn_type,
4257 "Return value of function %qs at %L not set",
4258 proc_sym->name, &proc_sym->declared_at);
4259 }
4260 else if (proc_sym->as)
4261 {
4262 tree result = TREE_VALUE (current_fake_result_decl);
4263 gfc_save_backend_locus (&loc);
4264 gfc_set_backend_locus (&proc_sym->declared_at);
4265 gfc_trans_dummy_array_bias (proc_sym, result, block);
4266
4267 /* An automatic character length, pointer array result. */
4268 if (proc_sym->ts.type == BT_CHARACTER
4269 && VAR_P (proc_sym->ts.u.cl->backend_decl))
4270 {
4271 tmp = NULL;
4272 if (proc_sym->ts.deferred)
4273 {
4274 gfc_start_block (&init);
4275 tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
4276 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4277 }
4278 else
4279 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4280 }
4281 }
4282 else if (proc_sym->ts.type == BT_CHARACTER)
4283 {
4284 if (proc_sym->ts.deferred)
4285 {
4286 tmp = NULL;
4287 gfc_save_backend_locus (&loc);
4288 gfc_set_backend_locus (&proc_sym->declared_at);
4289 gfc_start_block (&init);
4290 /* Zero the string length on entry. */
4291 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
4292 build_int_cst (gfc_charlen_type_node, 0));
4293 /* Null the pointer. */
4294 e = gfc_lval_expr_from_sym (proc_sym);
4295 gfc_init_se (&se, NULL);
4296 se.want_pointer = 1;
4297 gfc_conv_expr (&se, e);
4298 gfc_free_expr (e);
4299 tmp = se.expr;
4300 gfc_add_modify (&init, tmp,
4301 fold_convert (TREE_TYPE (se.expr),
4302 null_pointer_node));
4303 gfc_restore_backend_locus (&loc);
4304
4305 /* Pass back the string length on exit. */
4306 tmp = proc_sym->ts.u.cl->backend_decl;
4307 if (TREE_CODE (tmp) != INDIRECT_REF
4308 && proc_sym->ts.u.cl->passed_length)
4309 {
4310 tmp = proc_sym->ts.u.cl->passed_length;
4311 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4312 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4313 TREE_TYPE (tmp), tmp,
4314 fold_convert
4315 (TREE_TYPE (tmp),
4316 proc_sym->ts.u.cl->backend_decl));
4317 }
4318 else
4319 tmp = NULL_TREE;
4320
4321 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4322 }
4323 else if (VAR_P (proc_sym->ts.u.cl->backend_decl))
4324 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4325 }
4326 else
4327 gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
4328 }
4329 else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
4330 {
4331 /* Nullify explicit return class arrays on entry. */
4332 tree type;
4333 tmp = get_proc_result (proc_sym);
4334 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
4335 {
4336 gfc_start_block (&init);
4337 tmp = gfc_class_data_get (tmp);
4338 type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
4339 gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
4340 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4341 }
4342 }
4343
4344
4345 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4346 should be done here so that the offsets and lbounds of arrays
4347 are available. */
4348 gfc_save_backend_locus (&loc);
4349 gfc_set_backend_locus (&proc_sym->declared_at);
4350 init_intent_out_dt (proc_sym, block);
4351 gfc_restore_backend_locus (&loc);
4352
4353 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
4354 {
4355 bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
4356 && (sym->ts.u.derived->attr.alloc_comp
4357 || gfc_is_finalizable (sym->ts.u.derived,
4358 NULL));
4359 if (sym->assoc)
4360 continue;
4361
4362 if (sym->ts.type == BT_DERIVED
4363 && sym->ts.u.derived
4364 && sym->ts.u.derived->attr.pdt_type)
4365 {
4366 is_pdt_type = true;
4367 gfc_init_block (&tmpblock);
4368 if (!(sym->attr.dummy
4369 || sym->attr.pointer
4370 || sym->attr.allocatable))
4371 {
4372 tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
4373 sym->backend_decl,
4374 sym->as ? sym->as->rank : 0,
4375 sym->param_list);
4376 gfc_add_expr_to_block (&tmpblock, tmp);
4377 if (!sym->attr.result)
4378 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
4379 sym->backend_decl,
4380 sym->as ? sym->as->rank : 0);
4381 else
4382 tmp = NULL_TREE;
4383 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4384 }
4385 else if (sym->attr.dummy)
4386 {
4387 tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
4388 sym->backend_decl,
4389 sym->as ? sym->as->rank : 0,
4390 sym->param_list);
4391 gfc_add_expr_to_block (&tmpblock, tmp);
4392 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
4393 }
4394 }
4395 else if (sym->ts.type == BT_CLASS
4396 && CLASS_DATA (sym)->ts.u.derived
4397 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
4398 {
4399 gfc_component *data = CLASS_DATA (sym);
4400 is_pdt_type = true;
4401 gfc_init_block (&tmpblock);
4402 if (!(sym->attr.dummy
4403 || CLASS_DATA (sym)->attr.pointer
4404 || CLASS_DATA (sym)->attr.allocatable))
4405 {
4406 tmp = gfc_class_data_get (sym->backend_decl);
4407 tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
4408 data->as ? data->as->rank : 0,
4409 sym->param_list);
4410 gfc_add_expr_to_block (&tmpblock, tmp);
4411 tmp = gfc_class_data_get (sym->backend_decl);
4412 if (!sym->attr.result)
4413 tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
4414 data->as ? data->as->rank : 0);
4415 else
4416 tmp = NULL_TREE;
4417 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4418 }
4419 else if (sym->attr.dummy)
4420 {
4421 tmp = gfc_class_data_get (sym->backend_decl);
4422 tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp,
4423 data->as ? data->as->rank : 0,
4424 sym->param_list);
4425 gfc_add_expr_to_block (&tmpblock, tmp);
4426 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
4427 }
4428 }
4429
4430 if (sym->attr.pointer && sym->attr.dimension
4431 && sym->attr.save == SAVE_NONE
4432 && !sym->attr.use_assoc
4433 && !sym->attr.host_assoc
4434 && !sym->attr.dummy
4435 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
4436 {
4437 gfc_init_block (&tmpblock);
4438 gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
4439 build_int_cst (gfc_array_index_type, 0));
4440 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4441 NULL_TREE);
4442 }
4443
4444 if (sym->ts.type == BT_CLASS
4445 && (sym->attr.save || flag_max_stack_var_size == 0)
4446 && CLASS_DATA (sym)->attr.allocatable)
4447 {
4448 tree vptr;
4449
4450 if (UNLIMITED_POLY (sym))
4451 vptr = null_pointer_node;
4452 else
4453 {
4454 gfc_symbol *vsym;
4455 vsym = gfc_find_derived_vtab (sym->ts.u.derived);
4456 vptr = gfc_get_symbol_decl (vsym);
4457 vptr = gfc_build_addr_expr (NULL, vptr);
4458 }
4459
4460 if (CLASS_DATA (sym)->attr.dimension
4461 || (CLASS_DATA (sym)->attr.codimension
4462 && flag_coarray != GFC_FCOARRAY_LIB))
4463 {
4464 tmp = gfc_class_data_get (sym->backend_decl);
4465 tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
4466 }
4467 else
4468 tmp = null_pointer_node;
4469
4470 DECL_INITIAL (sym->backend_decl)
4471 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
4472 TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
4473 }
4474 else if ((sym->attr.dimension || sym->attr.codimension
4475 || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
4476 {
4477 bool is_classarray = IS_CLASS_ARRAY (sym);
4478 symbol_attribute *array_attr;
4479 gfc_array_spec *as;
4480 array_type type_of_array;
4481
4482 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
4483 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
4484 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4485 type_of_array = as->type;
4486 if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
4487 type_of_array = AS_EXPLICIT;
4488 switch (type_of_array)
4489 {
4490 case AS_EXPLICIT:
4491 if (sym->attr.dummy || sym->attr.result)
4492 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4493 /* Allocatable and pointer arrays need to processed
4494 explicitly. */
4495 else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
4496 || (sym->ts.type == BT_CLASS
4497 && CLASS_DATA (sym)->attr.class_pointer)
4498 || array_attr->allocatable)
4499 {
4500 if (TREE_STATIC (sym->backend_decl))
4501 {
4502 gfc_save_backend_locus (&loc);
4503 gfc_set_backend_locus (&sym->declared_at);
4504 gfc_trans_static_array_pointer (sym);
4505 gfc_restore_backend_locus (&loc);
4506 }
4507 else
4508 {
4509 seen_trans_deferred_array = true;
4510 gfc_trans_deferred_array (sym, block);
4511 }
4512 }
4513 else if (sym->attr.codimension
4514 && TREE_STATIC (sym->backend_decl))
4515 {
4516 gfc_init_block (&tmpblock);
4517 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
4518 &tmpblock, sym);
4519 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4520 NULL_TREE);
4521 continue;
4522 }
4523 else
4524 {
4525 gfc_save_backend_locus (&loc);
4526 gfc_set_backend_locus (&sym->declared_at);
4527
4528 if (alloc_comp_or_fini)
4529 {
4530 seen_trans_deferred_array = true;
4531 gfc_trans_deferred_array (sym, block);
4532 }
4533 else if (sym->ts.type == BT_DERIVED
4534 && sym->value
4535 && !sym->attr.data
4536 && sym->attr.save == SAVE_NONE)
4537 {
4538 gfc_start_block (&tmpblock);
4539 gfc_init_default_dt (sym, &tmpblock, false);
4540 gfc_add_init_cleanup (block,
4541 gfc_finish_block (&tmpblock),
4542 NULL_TREE);
4543 }
4544
4545 gfc_trans_auto_array_allocation (sym->backend_decl,
4546 sym, block);
4547 gfc_restore_backend_locus (&loc);
4548 }
4549 break;
4550
4551 case AS_ASSUMED_SIZE:
4552 /* Must be a dummy parameter. */
4553 gcc_assert (sym->attr.dummy || as->cp_was_assumed);
4554
4555 /* We should always pass assumed size arrays the g77 way. */
4556 if (sym->attr.dummy)
4557 gfc_trans_g77_array (sym, block);
4558 break;
4559
4560 case AS_ASSUMED_SHAPE:
4561 /* Must be a dummy parameter. */
4562 gcc_assert (sym->attr.dummy);
4563
4564 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4565 break;
4566
4567 case AS_ASSUMED_RANK:
4568 case AS_DEFERRED:
4569 seen_trans_deferred_array = true;
4570 gfc_trans_deferred_array (sym, block);
4571 if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
4572 && sym->attr.result)
4573 {
4574 gfc_start_block (&init);
4575 gfc_save_backend_locus (&loc);
4576 gfc_set_backend_locus (&sym->declared_at);
4577 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4578 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4579 }
4580 break;
4581
4582 default:
4583 gcc_unreachable ();
4584 }
4585 if (alloc_comp_or_fini && !seen_trans_deferred_array)
4586 gfc_trans_deferred_array (sym, block);
4587 }
4588 else if ((!sym->attr.dummy || sym->ts.deferred)
4589 && (sym->ts.type == BT_CLASS
4590 && CLASS_DATA (sym)->attr.class_pointer))
4591 continue;
4592 else if ((!sym->attr.dummy || sym->ts.deferred)
4593 && (sym->attr.allocatable
4594 || (sym->attr.pointer && sym->attr.result)
4595 || (sym->ts.type == BT_CLASS
4596 && CLASS_DATA (sym)->attr.allocatable)))
4597 {
4598 if (!sym->attr.save && flag_max_stack_var_size != 0)
4599 {
4600 tree descriptor = NULL_TREE;
4601
4602 gfc_save_backend_locus (&loc);
4603 gfc_set_backend_locus (&sym->declared_at);
4604 gfc_start_block (&init);
4605
4606 if (!sym->attr.pointer)
4607 {
4608 /* Nullify and automatic deallocation of allocatable
4609 scalars. */
4610 e = gfc_lval_expr_from_sym (sym);
4611 if (sym->ts.type == BT_CLASS)
4612 gfc_add_data_component (e);
4613
4614 gfc_init_se (&se, NULL);
4615 if (sym->ts.type != BT_CLASS
4616 || sym->ts.u.derived->attr.dimension
4617 || sym->ts.u.derived->attr.codimension)
4618 {
4619 se.want_pointer = 1;
4620 gfc_conv_expr (&se, e);
4621 }
4622 else if (sym->ts.type == BT_CLASS
4623 && !CLASS_DATA (sym)->attr.dimension
4624 && !CLASS_DATA (sym)->attr.codimension)
4625 {
4626 se.want_pointer = 1;
4627 gfc_conv_expr (&se, e);
4628 }
4629 else
4630 {
4631 se.descriptor_only = 1;
4632 gfc_conv_expr (&se, e);
4633 descriptor = se.expr;
4634 se.expr = gfc_conv_descriptor_data_addr (se.expr);
4635 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
4636 }
4637 gfc_free_expr (e);
4638
4639 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4640 {
4641 /* Nullify when entering the scope. */
4642 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4643 TREE_TYPE (se.expr), se.expr,
4644 fold_convert (TREE_TYPE (se.expr),
4645 null_pointer_node));
4646 if (sym->attr.optional)
4647 {
4648 tree present = gfc_conv_expr_present (sym);
4649 tmp = build3_loc (input_location, COND_EXPR,
4650 void_type_node, present, tmp,
4651 build_empty_stmt (input_location));
4652 }
4653 gfc_add_expr_to_block (&init, tmp);
4654 }
4655 }
4656
4657 if ((sym->attr.dummy || sym->attr.result)
4658 && sym->ts.type == BT_CHARACTER
4659 && sym->ts.deferred
4660 && sym->ts.u.cl->passed_length)
4661 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4662 else
4663 {
4664 gfc_restore_backend_locus (&loc);
4665 tmp = NULL_TREE;
4666 }
4667
4668 /* Deallocate when leaving the scope. Nullifying is not
4669 needed. */
4670 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
4671 && !sym->ns->proc_name->attr.is_main_program)
4672 {
4673 if (sym->ts.type == BT_CLASS
4674 && CLASS_DATA (sym)->attr.codimension)
4675 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
4676 NULL_TREE, NULL_TREE,
4677 NULL_TREE, true, NULL,
4678 GFC_CAF_COARRAY_ANALYZE);
4679 else
4680 {
4681 gfc_expr *expr = gfc_lval_expr_from_sym (sym);
4682 tmp = gfc_deallocate_scalar_with_status (se.expr,
4683 NULL_TREE,
4684 NULL_TREE,
4685 true, expr,
4686 sym->ts);
4687 gfc_free_expr (expr);
4688 }
4689 }
4690
4691 if (sym->ts.type == BT_CLASS)
4692 {
4693 /* Initialize _vptr to declared type. */
4694 gfc_symbol *vtab;
4695 tree rhs;
4696
4697 gfc_save_backend_locus (&loc);
4698 gfc_set_backend_locus (&sym->declared_at);
4699 e = gfc_lval_expr_from_sym (sym);
4700 gfc_add_vptr_component (e);
4701 gfc_init_se (&se, NULL);
4702 se.want_pointer = 1;
4703 gfc_conv_expr (&se, e);
4704 gfc_free_expr (e);
4705 if (UNLIMITED_POLY (sym))
4706 rhs = build_int_cst (TREE_TYPE (se.expr), 0);
4707 else
4708 {
4709 vtab = gfc_find_derived_vtab (sym->ts.u.derived);
4710 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
4711 gfc_get_symbol_decl (vtab));
4712 }
4713 gfc_add_modify (&init, se.expr, rhs);
4714 gfc_restore_backend_locus (&loc);
4715 }
4716
4717 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4718 }
4719 }
4720 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
4721 {
4722 tree tmp = NULL;
4723 stmtblock_t init;
4724
4725 /* If we get to here, all that should be left are pointers. */
4726 gcc_assert (sym->attr.pointer);
4727
4728 if (sym->attr.dummy)
4729 {
4730 gfc_start_block (&init);
4731 gfc_save_backend_locus (&loc);
4732 gfc_set_backend_locus (&sym->declared_at);
4733 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4734 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4735 }
4736 }
4737 else if (sym->ts.deferred)
4738 gfc_fatal_error ("Deferred type parameter not yet supported");
4739 else if (alloc_comp_or_fini)
4740 gfc_trans_deferred_array (sym, block);
4741 else if (sym->ts.type == BT_CHARACTER)
4742 {
4743 gfc_save_backend_locus (&loc);
4744 gfc_set_backend_locus (&sym->declared_at);
4745 if (sym->attr.dummy || sym->attr.result)
4746 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
4747 else
4748 gfc_trans_auto_character_variable (sym, block);
4749 gfc_restore_backend_locus (&loc);
4750 }
4751 else if (sym->attr.assign)
4752 {
4753 gfc_save_backend_locus (&loc);
4754 gfc_set_backend_locus (&sym->declared_at);
4755 gfc_trans_assign_aux_var (sym, block);
4756 gfc_restore_backend_locus (&loc);
4757 }
4758 else if (sym->ts.type == BT_DERIVED
4759 && sym->value
4760 && !sym->attr.data
4761 && sym->attr.save == SAVE_NONE)
4762 {
4763 gfc_start_block (&tmpblock);
4764 gfc_init_default_dt (sym, &tmpblock, false);
4765 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4766 NULL_TREE);
4767 }
4768 else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
4769 gcc_unreachable ();
4770 }
4771
4772 gfc_init_block (&tmpblock);
4773
4774 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4775 {
4776 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
4777 {
4778 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
4779 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
4780 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
4781 }
4782 }
4783
4784 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
4785 && current_fake_result_decl != NULL)
4786 {
4787 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
4788 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
4789 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
4790 }
4791
4792 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
4793 }
4794
4795
4796 struct module_hasher : ggc_ptr_hash<module_htab_entry>
4797 {
4798 typedef const char *compare_type;
4799
4800 static hashval_t hash (module_htab_entry *s) { return htab_hash_string (s); }
4801 static bool
4802 equal (module_htab_entry *a, const char *b)
4803 {
4804 return !strcmp (a->name, b);
4805 }
4806 };
4807
4808 static GTY (()) hash_table<module_hasher> *module_htab;
4809
4810 /* Hash and equality functions for module_htab's decls. */
4811
4812 hashval_t
4813 module_decl_hasher::hash (tree t)
4814 {
4815 const_tree n = DECL_NAME (t);
4816 if (n == NULL_TREE)
4817 n = TYPE_NAME (TREE_TYPE (t));
4818 return htab_hash_string (IDENTIFIER_POINTER (n));
4819 }
4820
4821 bool
4822 module_decl_hasher::equal (tree t1, const char *x2)
4823 {
4824 const_tree n1 = DECL_NAME (t1);
4825 if (n1 == NULL_TREE)
4826 n1 = TYPE_NAME (TREE_TYPE (t1));
4827 return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
4828 }
4829
4830 struct module_htab_entry *
4831 gfc_find_module (const char *name)
4832 {
4833 if (! module_htab)
4834 module_htab = hash_table<module_hasher>::create_ggc (10);
4835
4836 module_htab_entry **slot
4837 = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
4838 if (*slot == NULL)
4839 {
4840 module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
4841
4842 entry->name = gfc_get_string ("%s", name);
4843 entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
4844 *slot = entry;
4845 }
4846 return *slot;
4847 }
4848
4849 void
4850 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
4851 {
4852 const char *name;
4853
4854 if (DECL_NAME (decl))
4855 name = IDENTIFIER_POINTER (DECL_NAME (decl));
4856 else
4857 {
4858 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
4859 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
4860 }
4861 tree *slot
4862 = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
4863 INSERT);
4864 if (*slot == NULL)
4865 *slot = decl;
4866 }
4867
4868
4869 /* Generate debugging symbols for namelists. This function must come after
4870 generate_local_decl to ensure that the variables in the namelist are
4871 already declared. */
4872
4873 static tree
4874 generate_namelist_decl (gfc_symbol * sym)
4875 {
4876 gfc_namelist *nml;
4877 tree decl;
4878 vec<constructor_elt, va_gc> *nml_decls = NULL;
4879
4880 gcc_assert (sym->attr.flavor == FL_NAMELIST);
4881 for (nml = sym->namelist; nml; nml = nml->next)
4882 {
4883 if (nml->sym->backend_decl == NULL_TREE)
4884 {
4885 nml->sym->attr.referenced = 1;
4886 nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
4887 }
4888 DECL_IGNORED_P (nml->sym->backend_decl) = 0;
4889 CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
4890 }
4891
4892 decl = make_node (NAMELIST_DECL);
4893 TREE_TYPE (decl) = void_type_node;
4894 NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
4895 DECL_NAME (decl) = get_identifier (sym->name);
4896 return decl;
4897 }
4898
4899
4900 /* Output an initialized decl for a module variable. */
4901
4902 static void
4903 gfc_create_module_variable (gfc_symbol * sym)
4904 {
4905 tree decl;
4906
4907 /* Module functions with alternate entries are dealt with later and
4908 would get caught by the next condition. */
4909 if (sym->attr.entry)
4910 return;
4911
4912 /* Make sure we convert the types of the derived types from iso_c_binding
4913 into (void *). */
4914 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4915 && sym->ts.type == BT_DERIVED)
4916 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4917
4918 if (gfc_fl_struct (sym->attr.flavor)
4919 && sym->backend_decl
4920 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4921 {
4922 decl = sym->backend_decl;
4923 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4924
4925 if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
4926 {
4927 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4928 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4929 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4930 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4931 == sym->ns->proc_name->backend_decl);
4932 }
4933 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4934 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4935 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4936 }
4937
4938 /* Only output variables, procedure pointers and array valued,
4939 or derived type, parameters. */
4940 if (sym->attr.flavor != FL_VARIABLE
4941 && !(sym->attr.flavor == FL_PARAMETER
4942 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4943 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4944 return;
4945
4946 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4947 {
4948 decl = sym->backend_decl;
4949 gcc_assert (DECL_FILE_SCOPE_P (decl));
4950 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4951 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4952 gfc_module_add_decl (cur_module, decl);
4953 }
4954
4955 /* Don't generate variables from other modules. Variables from
4956 COMMONs and Cray pointees will already have been generated. */
4957 if (sym->attr.use_assoc || sym->attr.used_in_submodule
4958 || sym->attr.in_common || sym->attr.cray_pointee)
4959 return;
4960
4961 /* Equivalenced variables arrive here after creation. */
4962 if (sym->backend_decl
4963 && (sym->equiv_built || sym->attr.in_equivalence))
4964 return;
4965
4966 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4967 gfc_internal_error ("backend decl for module variable %qs already exists",
4968 sym->name);
4969
4970 if (sym->module && !sym->attr.result && !sym->attr.dummy
4971 && (sym->attr.access == ACCESS_UNKNOWN
4972 && (sym->ns->default_access == ACCESS_PRIVATE
4973 || (sym->ns->default_access == ACCESS_UNKNOWN
4974 && flag_module_private))))
4975 sym->attr.access = ACCESS_PRIVATE;
4976
4977 if (warn_unused_variable && !sym->attr.referenced
4978 && sym->attr.access == ACCESS_PRIVATE)
4979 gfc_warning (OPT_Wunused_value,
4980 "Unused PRIVATE module variable %qs declared at %L",
4981 sym->name, &sym->declared_at);
4982
4983 /* We always want module variables to be created. */
4984 sym->attr.referenced = 1;
4985 /* Create the decl. */
4986 decl = gfc_get_symbol_decl (sym);
4987
4988 /* Create the variable. */
4989 pushdecl (decl);
4990 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
4991 || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
4992 && sym->fn_result_spec));
4993 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4994 rest_of_decl_compilation (decl, 1, 0);
4995 gfc_module_add_decl (cur_module, decl);
4996
4997 /* Also add length of strings. */
4998 if (sym->ts.type == BT_CHARACTER)
4999 {
5000 tree length;
5001
5002 length = sym->ts.u.cl->backend_decl;
5003 gcc_assert (length || sym->attr.proc_pointer);
5004 if (length && !INTEGER_CST_P (length))
5005 {
5006 pushdecl (length);
5007 rest_of_decl_compilation (length, 1, 0);
5008 }
5009 }
5010
5011 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5012 && sym->attr.referenced && !sym->attr.use_assoc)
5013 has_coarray_vars = true;
5014 }
5015
5016 /* Emit debug information for USE statements. */
5017
5018 static void
5019 gfc_trans_use_stmts (gfc_namespace * ns)
5020 {
5021 gfc_use_list *use_stmt;
5022 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
5023 {
5024 struct module_htab_entry *entry
5025 = gfc_find_module (use_stmt->module_name);
5026 gfc_use_rename *rent;
5027
5028 if (entry->namespace_decl == NULL)
5029 {
5030 entry->namespace_decl
5031 = build_decl (input_location,
5032 NAMESPACE_DECL,
5033 get_identifier (use_stmt->module_name),
5034 void_type_node);
5035 DECL_EXTERNAL (entry->namespace_decl) = 1;
5036 }
5037 gfc_set_backend_locus (&use_stmt->where);
5038 if (!use_stmt->only_flag)
5039 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
5040 NULL_TREE,
5041 ns->proc_name->backend_decl,
5042 false, false);
5043 for (rent = use_stmt->rename; rent; rent = rent->next)
5044 {
5045 tree decl, local_name;
5046
5047 if (rent->op != INTRINSIC_NONE)
5048 continue;
5049
5050 hashval_t hash = htab_hash_string (rent->use_name);
5051 tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
5052 INSERT);
5053 if (*slot == NULL)
5054 {
5055 gfc_symtree *st;
5056
5057 st = gfc_find_symtree (ns->sym_root,
5058 rent->local_name[0]
5059 ? rent->local_name : rent->use_name);
5060
5061 /* The following can happen if a derived type is renamed. */
5062 if (!st)
5063 {
5064 char *name;
5065 name = xstrdup (rent->local_name[0]
5066 ? rent->local_name : rent->use_name);
5067 name[0] = (char) TOUPPER ((unsigned char) name[0]);
5068 st = gfc_find_symtree (ns->sym_root, name);
5069 free (name);
5070 gcc_assert (st);
5071 }
5072
5073 /* Sometimes, generic interfaces wind up being over-ruled by a
5074 local symbol (see PR41062). */
5075 if (!st->n.sym->attr.use_assoc)
5076 continue;
5077
5078 if (st->n.sym->backend_decl
5079 && DECL_P (st->n.sym->backend_decl)
5080 && st->n.sym->module
5081 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
5082 {
5083 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
5084 || !VAR_P (st->n.sym->backend_decl));
5085 decl = copy_node (st->n.sym->backend_decl);
5086 DECL_CONTEXT (decl) = entry->namespace_decl;
5087 DECL_EXTERNAL (decl) = 1;
5088 DECL_IGNORED_P (decl) = 0;
5089 DECL_INITIAL (decl) = NULL_TREE;
5090 }
5091 else if (st->n.sym->attr.flavor == FL_NAMELIST
5092 && st->n.sym->attr.use_only
5093 && st->n.sym->module
5094 && strcmp (st->n.sym->module, use_stmt->module_name)
5095 == 0)
5096 {
5097 decl = generate_namelist_decl (st->n.sym);
5098 DECL_CONTEXT (decl) = entry->namespace_decl;
5099 DECL_EXTERNAL (decl) = 1;
5100 DECL_IGNORED_P (decl) = 0;
5101 DECL_INITIAL (decl) = NULL_TREE;
5102 }
5103 else
5104 {
5105 *slot = error_mark_node;
5106 entry->decls->clear_slot (slot);
5107 continue;
5108 }
5109 *slot = decl;
5110 }
5111 decl = (tree) *slot;
5112 if (rent->local_name[0])
5113 local_name = get_identifier (rent->local_name);
5114 else
5115 local_name = NULL_TREE;
5116 gfc_set_backend_locus (&rent->where);
5117 (*debug_hooks->imported_module_or_decl) (decl, local_name,
5118 ns->proc_name->backend_decl,
5119 !use_stmt->only_flag,
5120 false);
5121 }
5122 }
5123 }
5124
5125
5126 /* Return true if expr is a constant initializer that gfc_conv_initializer
5127 will handle. */
5128
5129 static bool
5130 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
5131 bool pointer)
5132 {
5133 gfc_constructor *c;
5134 gfc_component *cm;
5135
5136 if (pointer)
5137 return true;
5138 else if (array)
5139 {
5140 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
5141 return true;
5142 else if (expr->expr_type == EXPR_STRUCTURE)
5143 return check_constant_initializer (expr, ts, false, false);
5144 else if (expr->expr_type != EXPR_ARRAY)
5145 return false;
5146 for (c = gfc_constructor_first (expr->value.constructor);
5147 c; c = gfc_constructor_next (c))
5148 {
5149 if (c->iterator)
5150 return false;
5151 if (c->expr->expr_type == EXPR_STRUCTURE)
5152 {
5153 if (!check_constant_initializer (c->expr, ts, false, false))
5154 return false;
5155 }
5156 else if (c->expr->expr_type != EXPR_CONSTANT)
5157 return false;
5158 }
5159 return true;
5160 }
5161 else switch (ts->type)
5162 {
5163 case_bt_struct:
5164 if (expr->expr_type != EXPR_STRUCTURE)
5165 return false;
5166 cm = expr->ts.u.derived->components;
5167 for (c = gfc_constructor_first (expr->value.constructor);
5168 c; c = gfc_constructor_next (c), cm = cm->next)
5169 {
5170 if (!c->expr || cm->attr.allocatable)
5171 continue;
5172 if (!check_constant_initializer (c->expr, &cm->ts,
5173 cm->attr.dimension,
5174 cm->attr.pointer))
5175 return false;
5176 }
5177 return true;
5178 default:
5179 return expr->expr_type == EXPR_CONSTANT;
5180 }
5181 }
5182
5183 /* Emit debug info for parameters and unreferenced variables with
5184 initializers. */
5185
5186 static void
5187 gfc_emit_parameter_debug_info (gfc_symbol *sym)
5188 {
5189 tree decl;
5190
5191 if (sym->attr.flavor != FL_PARAMETER
5192 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5193 return;
5194
5195 if (sym->backend_decl != NULL
5196 || sym->value == NULL
5197 || sym->attr.use_assoc
5198 || sym->attr.dummy
5199 || sym->attr.result
5200 || sym->attr.function
5201 || sym->attr.intrinsic
5202 || sym->attr.pointer
5203 || sym->attr.allocatable
5204 || sym->attr.cray_pointee
5205 || sym->attr.threadprivate
5206 || sym->attr.is_bind_c
5207 || sym->attr.subref_array_pointer
5208 || sym->attr.assign)
5209 return;
5210
5211 if (sym->ts.type == BT_CHARACTER)
5212 {
5213 gfc_conv_const_charlen (sym->ts.u.cl);
5214 if (sym->ts.u.cl->backend_decl == NULL
5215 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5216 return;
5217 }
5218 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5219 return;
5220
5221 if (sym->as)
5222 {
5223 int n;
5224
5225 if (sym->as->type != AS_EXPLICIT)
5226 return;
5227 for (n = 0; n < sym->as->rank; n++)
5228 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5229 || sym->as->upper[n] == NULL
5230 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5231 return;
5232 }
5233
5234 if (!check_constant_initializer (sym->value, &sym->ts,
5235 sym->attr.dimension, false))
5236 return;
5237
5238 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5239 return;
5240
5241 /* Create the decl for the variable or constant. */
5242 decl = build_decl (input_location,
5243 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5244 gfc_sym_identifier (sym), gfc_sym_type (sym));
5245 if (sym->attr.flavor == FL_PARAMETER)
5246 TREE_READONLY (decl) = 1;
5247 gfc_set_decl_location (decl, &sym->declared_at);
5248 if (sym->attr.dimension)
5249 GFC_DECL_PACKED_ARRAY (decl) = 1;
5250 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5251 TREE_STATIC (decl) = 1;
5252 TREE_USED (decl) = 1;
5253 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5254 TREE_PUBLIC (decl) = 1;
5255 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5256 TREE_TYPE (decl),
5257 sym->attr.dimension,
5258 false, false);
5259 debug_hooks->early_global_decl (decl);
5260 }
5261
5262
5263 static void
5264 generate_coarray_sym_init (gfc_symbol *sym)
5265 {
5266 tree tmp, size, decl, token, desc;
5267 bool is_lock_type, is_event_type;
5268 int reg_type;
5269 gfc_se se;
5270 symbol_attribute attr;
5271
5272 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5273 || sym->attr.use_assoc || !sym->attr.referenced
5274 || sym->attr.select_type_temporary)
5275 return;
5276
5277 decl = sym->backend_decl;
5278 TREE_USED(decl) = 1;
5279 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5280
5281 is_lock_type = sym->ts.type == BT_DERIVED
5282 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5283 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5284
5285 is_event_type = sym->ts.type == BT_DERIVED
5286 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5287 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5288
5289 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5290 to make sure the variable is not optimized away. */
5291 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5292
5293 /* For lock types, we pass the array size as only the library knows the
5294 size of the variable. */
5295 if (is_lock_type || is_event_type)
5296 size = gfc_index_one_node;
5297 else
5298 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5299
5300 /* Ensure that we do not have size=0 for zero-sized arrays. */
5301 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5302 fold_convert (size_type_node, size),
5303 build_int_cst (size_type_node, 1));
5304
5305 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5306 {
5307 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5308 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5309 fold_convert (size_type_node, tmp), size);
5310 }
5311
5312 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5313 token = gfc_build_addr_expr (ppvoid_type_node,
5314 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5315 if (is_lock_type)
5316 reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5317 else if (is_event_type)
5318 reg_type = GFC_CAF_EVENT_STATIC;
5319 else
5320 reg_type = GFC_CAF_COARRAY_STATIC;
5321
5322 /* Compile the symbol attribute. */
5323 if (sym->ts.type == BT_CLASS)
5324 {
5325 attr = CLASS_DATA (sym)->attr;
5326 /* The pointer attribute is always set on classes, overwrite it with the
5327 class_pointer attribute, which denotes the pointer for classes. */
5328 attr.pointer = attr.class_pointer;
5329 }
5330 else
5331 attr = sym->attr;
5332 gfc_init_se (&se, NULL);
5333 desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5334 gfc_add_block_to_block (&caf_init_block, &se.pre);
5335
5336 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5337 build_int_cst (integer_type_node, reg_type),
5338 token, gfc_build_addr_expr (pvoid_type_node, desc),
5339 null_pointer_node, /* stat. */
5340 null_pointer_node, /* errgmsg. */
5341 build_zero_cst (size_type_node)); /* errmsg_len. */
5342 gfc_add_expr_to_block (&caf_init_block, tmp);
5343 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5344 gfc_conv_descriptor_data_get (desc)));
5345
5346 /* Handle "static" initializer. */
5347 if (sym->value)
5348 {
5349 sym->attr.pointer = 1;
5350 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5351 true, false);
5352 sym->attr.pointer = 0;
5353 gfc_add_expr_to_block (&caf_init_block, tmp);
5354 }
5355 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5356 {
5357 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5358 ? sym->as->rank : 0,
5359 GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5360 gfc_add_expr_to_block (&caf_init_block, tmp);
5361 }
5362 }
5363
5364
5365 /* Generate constructor function to initialize static, nonallocatable
5366 coarrays. */
5367
5368 static void
5369 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5370 {
5371 tree fndecl, tmp, decl, save_fn_decl;
5372
5373 save_fn_decl = current_function_decl;
5374 push_function_context ();
5375
5376 tmp = build_function_type_list (void_type_node, NULL_TREE);
5377 fndecl = build_decl (input_location, FUNCTION_DECL,
5378 create_tmp_var_name ("_caf_init"), tmp);
5379
5380 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5381 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5382
5383 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5384 DECL_ARTIFICIAL (decl) = 1;
5385 DECL_IGNORED_P (decl) = 1;
5386 DECL_CONTEXT (decl) = fndecl;
5387 DECL_RESULT (fndecl) = decl;
5388
5389 pushdecl (fndecl);
5390 current_function_decl = fndecl;
5391 announce_function (fndecl);
5392
5393 rest_of_decl_compilation (fndecl, 0, 0);
5394 make_decl_rtl (fndecl);
5395 allocate_struct_function (fndecl, false);
5396
5397 pushlevel ();
5398 gfc_init_block (&caf_init_block);
5399
5400 gfc_traverse_ns (ns, generate_coarray_sym_init);
5401
5402 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5403 decl = getdecls ();
5404
5405 poplevel (1, 1);
5406 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5407
5408 DECL_SAVED_TREE (fndecl)
5409 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5410 DECL_INITIAL (fndecl));
5411 dump_function (TDI_original, fndecl);
5412
5413 cfun->function_end_locus = input_location;
5414 set_cfun (NULL);
5415
5416 if (decl_function_context (fndecl))
5417 (void) cgraph_node::create (fndecl);
5418 else
5419 cgraph_node::finalize_function (fndecl, true);
5420
5421 pop_function_context ();
5422 current_function_decl = save_fn_decl;
5423 }
5424
5425
5426 static void
5427 create_module_nml_decl (gfc_symbol *sym)
5428 {
5429 if (sym->attr.flavor == FL_NAMELIST)
5430 {
5431 tree decl = generate_namelist_decl (sym);
5432 pushdecl (decl);
5433 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5434 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5435 rest_of_decl_compilation (decl, 1, 0);
5436 gfc_module_add_decl (cur_module, decl);
5437 }
5438 }
5439
5440
5441 /* Generate all the required code for module variables. */
5442
5443 void
5444 gfc_generate_module_vars (gfc_namespace * ns)
5445 {
5446 module_namespace = ns;
5447 cur_module = gfc_find_module (ns->proc_name->name);
5448
5449 /* Check if the frontend left the namespace in a reasonable state. */
5450 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5451
5452 /* Generate COMMON blocks. */
5453 gfc_trans_common (ns);
5454
5455 has_coarray_vars = false;
5456
5457 /* Create decls for all the module variables. */
5458 gfc_traverse_ns (ns, gfc_create_module_variable);
5459 gfc_traverse_ns (ns, create_module_nml_decl);
5460
5461 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5462 generate_coarray_init (ns);
5463
5464 cur_module = NULL;
5465
5466 gfc_trans_use_stmts (ns);
5467 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5468 }
5469
5470
5471 static void
5472 gfc_generate_contained_functions (gfc_namespace * parent)
5473 {
5474 gfc_namespace *ns;
5475
5476 /* We create all the prototypes before generating any code. */
5477 for (ns = parent->contained; ns; ns = ns->sibling)
5478 {
5479 /* Skip namespaces from used modules. */
5480 if (ns->parent != parent)
5481 continue;
5482
5483 gfc_create_function_decl (ns, false);
5484 }
5485
5486 for (ns = parent->contained; ns; ns = ns->sibling)
5487 {
5488 /* Skip namespaces from used modules. */
5489 if (ns->parent != parent)
5490 continue;
5491
5492 gfc_generate_function_code (ns);
5493 }
5494 }
5495
5496
5497 /* Drill down through expressions for the array specification bounds and
5498 character length calling generate_local_decl for all those variables
5499 that have not already been declared. */
5500
5501 static void
5502 generate_local_decl (gfc_symbol *);
5503
5504 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5505
5506 static bool
5507 expr_decls (gfc_expr *e, gfc_symbol *sym,
5508 int *f ATTRIBUTE_UNUSED)
5509 {
5510 if (e->expr_type != EXPR_VARIABLE
5511 || sym == e->symtree->n.sym
5512 || e->symtree->n.sym->mark
5513 || e->symtree->n.sym->ns != sym->ns)
5514 return false;
5515
5516 generate_local_decl (e->symtree->n.sym);
5517 return false;
5518 }
5519
5520 static void
5521 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
5522 {
5523 gfc_traverse_expr (e, sym, expr_decls, 0);
5524 }
5525
5526
5527 /* Check for dependencies in the character length and array spec. */
5528
5529 static void
5530 generate_dependency_declarations (gfc_symbol *sym)
5531 {
5532 int i;
5533
5534 if (sym->ts.type == BT_CHARACTER
5535 && sym->ts.u.cl
5536 && sym->ts.u.cl->length
5537 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5538 generate_expr_decls (sym, sym->ts.u.cl->length);
5539
5540 if (sym->as && sym->as->rank)
5541 {
5542 for (i = 0; i < sym->as->rank; i++)
5543 {
5544 generate_expr_decls (sym, sym->as->lower[i]);
5545 generate_expr_decls (sym, sym->as->upper[i]);
5546 }
5547 }
5548 }
5549
5550
5551 /* Generate decls for all local variables. We do this to ensure correct
5552 handling of expressions which only appear in the specification of
5553 other functions. */
5554
5555 static void
5556 generate_local_decl (gfc_symbol * sym)
5557 {
5558 if (sym->attr.flavor == FL_VARIABLE)
5559 {
5560 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5561 && sym->attr.referenced && !sym->attr.use_assoc)
5562 has_coarray_vars = true;
5563
5564 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
5565 generate_dependency_declarations (sym);
5566
5567 if (sym->attr.referenced)
5568 gfc_get_symbol_decl (sym);
5569
5570 /* Warnings for unused dummy arguments. */
5571 else if (sym->attr.dummy && !sym->attr.in_namelist)
5572 {
5573 /* INTENT(out) dummy arguments are likely meant to be set. */
5574 if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
5575 {
5576 if (sym->ts.type != BT_DERIVED)
5577 gfc_warning (OPT_Wunused_dummy_argument,
5578 "Dummy argument %qs at %L was declared "
5579 "INTENT(OUT) but was not set", sym->name,
5580 &sym->declared_at);
5581 else if (!gfc_has_default_initializer (sym->ts.u.derived)
5582 && !sym->ts.u.derived->attr.zero_comp)
5583 gfc_warning (OPT_Wunused_dummy_argument,
5584 "Derived-type dummy argument %qs at %L was "
5585 "declared INTENT(OUT) but was not set and "
5586 "does not have a default initializer",
5587 sym->name, &sym->declared_at);
5588 if (sym->backend_decl != NULL_TREE)
5589 TREE_NO_WARNING(sym->backend_decl) = 1;
5590 }
5591 else if (warn_unused_dummy_argument)
5592 {
5593 gfc_warning (OPT_Wunused_dummy_argument,
5594 "Unused dummy argument %qs at %L", sym->name,
5595 &sym->declared_at);
5596 if (sym->backend_decl != NULL_TREE)
5597 TREE_NO_WARNING(sym->backend_decl) = 1;
5598 }
5599 }
5600
5601 /* Warn for unused variables, but not if they're inside a common
5602 block or a namelist. */
5603 else if (warn_unused_variable
5604 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
5605 {
5606 if (sym->attr.use_only)
5607 {
5608 gfc_warning (OPT_Wunused_variable,
5609 "Unused module variable %qs which has been "
5610 "explicitly imported at %L", sym->name,
5611 &sym->declared_at);
5612 if (sym->backend_decl != NULL_TREE)
5613 TREE_NO_WARNING(sym->backend_decl) = 1;
5614 }
5615 else if (!sym->attr.use_assoc)
5616 {
5617 /* Corner case: the symbol may be an entry point. At this point,
5618 it may appear to be an unused variable. Suppress warning. */
5619 bool enter = false;
5620 gfc_entry_list *el;
5621
5622 for (el = sym->ns->entries; el; el=el->next)
5623 if (strcmp(sym->name, el->sym->name) == 0)
5624 enter = true;
5625
5626 if (!enter)
5627 gfc_warning (OPT_Wunused_variable,
5628 "Unused variable %qs declared at %L",
5629 sym->name, &sym->declared_at);
5630 if (sym->backend_decl != NULL_TREE)
5631 TREE_NO_WARNING(sym->backend_decl) = 1;
5632 }
5633 }
5634
5635 /* For variable length CHARACTER parameters, the PARM_DECL already
5636 references the length variable, so force gfc_get_symbol_decl
5637 even when not referenced. If optimize > 0, it will be optimized
5638 away anyway. But do this only after emitting -Wunused-parameter
5639 warning if requested. */
5640 if (sym->attr.dummy && !sym->attr.referenced
5641 && sym->ts.type == BT_CHARACTER
5642 && sym->ts.u.cl->backend_decl != NULL
5643 && VAR_P (sym->ts.u.cl->backend_decl))
5644 {
5645 sym->attr.referenced = 1;
5646 gfc_get_symbol_decl (sym);
5647 }
5648
5649 /* INTENT(out) dummy arguments and result variables with allocatable
5650 components are reset by default and need to be set referenced to
5651 generate the code for nullification and automatic lengths. */
5652 if (!sym->attr.referenced
5653 && sym->ts.type == BT_DERIVED
5654 && sym->ts.u.derived->attr.alloc_comp
5655 && !sym->attr.pointer
5656 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
5657 ||
5658 (sym->attr.result && sym != sym->result)))
5659 {
5660 sym->attr.referenced = 1;
5661 gfc_get_symbol_decl (sym);
5662 }
5663
5664 /* Check for dependencies in the array specification and string
5665 length, adding the necessary declarations to the function. We
5666 mark the symbol now, as well as in traverse_ns, to prevent
5667 getting stuck in a circular dependency. */
5668 sym->mark = 1;
5669 }
5670 else if (sym->attr.flavor == FL_PARAMETER)
5671 {
5672 if (warn_unused_parameter
5673 && !sym->attr.referenced)
5674 {
5675 if (!sym->attr.use_assoc)
5676 gfc_warning (OPT_Wunused_parameter,
5677 "Unused parameter %qs declared at %L", sym->name,
5678 &sym->declared_at);
5679 else if (sym->attr.use_only)
5680 gfc_warning (OPT_Wunused_parameter,
5681 "Unused parameter %qs which has been explicitly "
5682 "imported at %L", sym->name, &sym->declared_at);
5683 }
5684
5685 if (sym->ns
5686 && sym->ns->parent
5687 && sym->ns->parent->code
5688 && sym->ns->parent->code->op == EXEC_BLOCK)
5689 {
5690 if (sym->attr.referenced)
5691 gfc_get_symbol_decl (sym);
5692 sym->mark = 1;
5693 }
5694 }
5695 else if (sym->attr.flavor == FL_PROCEDURE)
5696 {
5697 /* TODO: move to the appropriate place in resolve.c. */
5698 if (warn_return_type > 0
5699 && sym->attr.function
5700 && sym->result
5701 && sym != sym->result
5702 && !sym->result->attr.referenced
5703 && !sym->attr.use_assoc
5704 && sym->attr.if_source != IFSRC_IFBODY)
5705 {
5706 gfc_warning (OPT_Wreturn_type,
5707 "Return value %qs of function %qs declared at "
5708 "%L not set", sym->result->name, sym->name,
5709 &sym->result->declared_at);
5710
5711 /* Prevents "Unused variable" warning for RESULT variables. */
5712 sym->result->mark = 1;
5713 }
5714 }
5715
5716 if (sym->attr.dummy == 1)
5717 {
5718 /* Modify the tree type for scalar character dummy arguments of bind(c)
5719 procedures if they are passed by value. The tree type for them will
5720 be promoted to INTEGER_TYPE for the middle end, which appears to be
5721 what C would do with characters passed by-value. The value attribute
5722 implies the dummy is a scalar. */
5723 if (sym->attr.value == 1 && sym->backend_decl != NULL
5724 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
5725 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
5726 gfc_conv_scalar_char_value (sym, NULL, NULL);
5727
5728 /* Unused procedure passed as dummy argument. */
5729 if (sym->attr.flavor == FL_PROCEDURE)
5730 {
5731 if (!sym->attr.referenced)
5732 {
5733 if (warn_unused_dummy_argument)
5734 gfc_warning (OPT_Wunused_dummy_argument,
5735 "Unused dummy argument %qs at %L", sym->name,
5736 &sym->declared_at);
5737 }
5738
5739 /* Silence bogus "unused parameter" warnings from the
5740 middle end. */
5741 if (sym->backend_decl != NULL_TREE)
5742 TREE_NO_WARNING (sym->backend_decl) = 1;
5743 }
5744 }
5745
5746 /* Make sure we convert the types of the derived types from iso_c_binding
5747 into (void *). */
5748 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5749 && sym->ts.type == BT_DERIVED)
5750 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5751 }
5752
5753
5754 static void
5755 generate_local_nml_decl (gfc_symbol * sym)
5756 {
5757 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
5758 {
5759 tree decl = generate_namelist_decl (sym);
5760 pushdecl (decl);
5761 }
5762 }
5763
5764
5765 static void
5766 generate_local_vars (gfc_namespace * ns)
5767 {
5768 gfc_traverse_ns (ns, generate_local_decl);
5769 gfc_traverse_ns (ns, generate_local_nml_decl);
5770 }
5771
5772
5773 /* Generate a switch statement to jump to the correct entry point. Also
5774 creates the label decls for the entry points. */
5775
5776 static tree
5777 gfc_trans_entry_master_switch (gfc_entry_list * el)
5778 {
5779 stmtblock_t block;
5780 tree label;
5781 tree tmp;
5782 tree val;
5783
5784 gfc_init_block (&block);
5785 for (; el; el = el->next)
5786 {
5787 /* Add the case label. */
5788 label = gfc_build_label_decl (NULL_TREE);
5789 val = build_int_cst (gfc_array_index_type, el->id);
5790 tmp = build_case_label (val, NULL_TREE, label);
5791 gfc_add_expr_to_block (&block, tmp);
5792
5793 /* And jump to the actual entry point. */
5794 label = gfc_build_label_decl (NULL_TREE);
5795 tmp = build1_v (GOTO_EXPR, label);
5796 gfc_add_expr_to_block (&block, tmp);
5797
5798 /* Save the label decl. */
5799 el->label = label;
5800 }
5801 tmp = gfc_finish_block (&block);
5802 /* The first argument selects the entry point. */
5803 val = DECL_ARGUMENTS (current_function_decl);
5804 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp);
5805 return tmp;
5806 }
5807
5808
5809 /* Add code to string lengths of actual arguments passed to a function against
5810 the expected lengths of the dummy arguments. */
5811
5812 static void
5813 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
5814 {
5815 gfc_formal_arglist *formal;
5816
5817 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
5818 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
5819 && !formal->sym->ts.deferred)
5820 {
5821 enum tree_code comparison;
5822 tree cond;
5823 tree argname;
5824 gfc_symbol *fsym;
5825 gfc_charlen *cl;
5826 const char *message;
5827
5828 fsym = formal->sym;
5829 cl = fsym->ts.u.cl;
5830
5831 gcc_assert (cl);
5832 gcc_assert (cl->passed_length != NULL_TREE);
5833 gcc_assert (cl->backend_decl != NULL_TREE);
5834
5835 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5836 string lengths must match exactly. Otherwise, it is only required
5837 that the actual string length is *at least* the expected one.
5838 Sequence association allows for a mismatch of the string length
5839 if the actual argument is (part of) an array, but only if the
5840 dummy argument is an array. (See "Sequence association" in
5841 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5842 if (fsym->attr.pointer || fsym->attr.allocatable
5843 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
5844 || fsym->as->type == AS_ASSUMED_RANK)))
5845 {
5846 comparison = NE_EXPR;
5847 message = _("Actual string length does not match the declared one"
5848 " for dummy argument '%s' (%ld/%ld)");
5849 }
5850 else if (fsym->as && fsym->as->rank != 0)
5851 continue;
5852 else
5853 {
5854 comparison = LT_EXPR;
5855 message = _("Actual string length is shorter than the declared one"
5856 " for dummy argument '%s' (%ld/%ld)");
5857 }
5858
5859 /* Build the condition. For optional arguments, an actual length
5860 of 0 is also acceptable if the associated string is NULL, which
5861 means the argument was not passed. */
5862 cond = fold_build2_loc (input_location, comparison, logical_type_node,
5863 cl->passed_length, cl->backend_decl);
5864 if (fsym->attr.optional)
5865 {
5866 tree not_absent;
5867 tree not_0length;
5868 tree absent_failed;
5869
5870 not_0length = fold_build2_loc (input_location, NE_EXPR,
5871 logical_type_node,
5872 cl->passed_length,
5873 build_zero_cst
5874 (TREE_TYPE (cl->passed_length)));
5875 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5876 fsym->attr.referenced = 1;
5877 not_absent = gfc_conv_expr_present (fsym);
5878
5879 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5880 logical_type_node, not_0length,
5881 not_absent);
5882
5883 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5884 logical_type_node, cond, absent_failed);
5885 }
5886
5887 /* Build the runtime check. */
5888 argname = gfc_build_cstring_const (fsym->name);
5889 argname = gfc_build_addr_expr (pchar_type_node, argname);
5890 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
5891 message, argname,
5892 fold_convert (long_integer_type_node,
5893 cl->passed_length),
5894 fold_convert (long_integer_type_node,
5895 cl->backend_decl));
5896 }
5897 }
5898
5899
5900 static void
5901 create_main_function (tree fndecl)
5902 {
5903 tree old_context;
5904 tree ftn_main;
5905 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
5906 stmtblock_t body;
5907
5908 old_context = current_function_decl;
5909
5910 if (old_context)
5911 {
5912 push_function_context ();
5913 saved_parent_function_decls = saved_function_decls;
5914 saved_function_decls = NULL_TREE;
5915 }
5916
5917 /* main() function must be declared with global scope. */
5918 gcc_assert (current_function_decl == NULL_TREE);
5919
5920 /* Declare the function. */
5921 tmp = build_function_type_list (integer_type_node, integer_type_node,
5922 build_pointer_type (pchar_type_node),
5923 NULL_TREE);
5924 main_identifier_node = get_identifier ("main");
5925 ftn_main = build_decl (input_location, FUNCTION_DECL,
5926 main_identifier_node, tmp);
5927 DECL_EXTERNAL (ftn_main) = 0;
5928 TREE_PUBLIC (ftn_main) = 1;
5929 TREE_STATIC (ftn_main) = 1;
5930 DECL_ATTRIBUTES (ftn_main)
5931 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
5932
5933 /* Setup the result declaration (for "return 0"). */
5934 result_decl = build_decl (input_location,
5935 RESULT_DECL, NULL_TREE, integer_type_node);
5936 DECL_ARTIFICIAL (result_decl) = 1;
5937 DECL_IGNORED_P (result_decl) = 1;
5938 DECL_CONTEXT (result_decl) = ftn_main;
5939 DECL_RESULT (ftn_main) = result_decl;
5940
5941 pushdecl (ftn_main);
5942
5943 /* Get the arguments. */
5944
5945 arglist = NULL_TREE;
5946 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
5947
5948 tmp = TREE_VALUE (typelist);
5949 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
5950 DECL_CONTEXT (argc) = ftn_main;
5951 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
5952 TREE_READONLY (argc) = 1;
5953 gfc_finish_decl (argc);
5954 arglist = chainon (arglist, argc);
5955
5956 typelist = TREE_CHAIN (typelist);
5957 tmp = TREE_VALUE (typelist);
5958 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5959 DECL_CONTEXT (argv) = ftn_main;
5960 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5961 TREE_READONLY (argv) = 1;
5962 DECL_BY_REFERENCE (argv) = 1;
5963 gfc_finish_decl (argv);
5964 arglist = chainon (arglist, argv);
5965
5966 DECL_ARGUMENTS (ftn_main) = arglist;
5967 current_function_decl = ftn_main;
5968 announce_function (ftn_main);
5969
5970 rest_of_decl_compilation (ftn_main, 1, 0);
5971 make_decl_rtl (ftn_main);
5972 allocate_struct_function (ftn_main, false);
5973 pushlevel ();
5974
5975 gfc_init_block (&body);
5976
5977 /* Call some libgfortran initialization routines, call then MAIN__(). */
5978
5979 /* Call _gfortran_caf_init (*argc, ***argv). */
5980 if (flag_coarray == GFC_FCOARRAY_LIB)
5981 {
5982 tree pint_type, pppchar_type;
5983 pint_type = build_pointer_type (integer_type_node);
5984 pppchar_type
5985 = build_pointer_type (build_pointer_type (pchar_type_node));
5986
5987 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
5988 gfc_build_addr_expr (pint_type, argc),
5989 gfc_build_addr_expr (pppchar_type, argv));
5990 gfc_add_expr_to_block (&body, tmp);
5991 }
5992
5993 /* Call _gfortran_set_args (argc, argv). */
5994 TREE_USED (argc) = 1;
5995 TREE_USED (argv) = 1;
5996 tmp = build_call_expr_loc (input_location,
5997 gfor_fndecl_set_args, 2, argc, argv);
5998 gfc_add_expr_to_block (&body, tmp);
5999
6000 /* Add a call to set_options to set up the runtime library Fortran
6001 language standard parameters. */
6002 {
6003 tree array_type, array, var;
6004 vec<constructor_elt, va_gc> *v = NULL;
6005 static const int noptions = 7;
6006
6007 /* Passing a new option to the library requires three modifications:
6008 + add it to the tree_cons list below
6009 + change the noptions variable above
6010 + modify the library (runtime/compile_options.c)! */
6011
6012 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6013 build_int_cst (integer_type_node,
6014 gfc_option.warn_std));
6015 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6016 build_int_cst (integer_type_node,
6017 gfc_option.allow_std));
6018 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6019 build_int_cst (integer_type_node, pedantic));
6020 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6021 build_int_cst (integer_type_node, flag_backtrace));
6022 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6023 build_int_cst (integer_type_node, flag_sign_zero));
6024 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6025 build_int_cst (integer_type_node,
6026 (gfc_option.rtcheck
6027 & GFC_RTCHECK_BOUNDS)));
6028 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
6029 build_int_cst (integer_type_node,
6030 gfc_option.fpe_summary));
6031
6032 array_type = build_array_type_nelts (integer_type_node, noptions);
6033 array = build_constructor (array_type, v);
6034 TREE_CONSTANT (array) = 1;
6035 TREE_STATIC (array) = 1;
6036
6037 /* Create a static variable to hold the jump table. */
6038 var = build_decl (input_location, VAR_DECL,
6039 create_tmp_var_name ("options"), array_type);
6040 DECL_ARTIFICIAL (var) = 1;
6041 DECL_IGNORED_P (var) = 1;
6042 TREE_CONSTANT (var) = 1;
6043 TREE_STATIC (var) = 1;
6044 TREE_READONLY (var) = 1;
6045 DECL_INITIAL (var) = array;
6046 pushdecl (var);
6047 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
6048
6049 tmp = build_call_expr_loc (input_location,
6050 gfor_fndecl_set_options, 2,
6051 build_int_cst (integer_type_node, noptions), var);
6052 gfc_add_expr_to_block (&body, tmp);
6053 }
6054
6055 /* If -ffpe-trap option was provided, add a call to set_fpe so that
6056 the library will raise a FPE when needed. */
6057 if (gfc_option.fpe != 0)
6058 {
6059 tmp = build_call_expr_loc (input_location,
6060 gfor_fndecl_set_fpe, 1,
6061 build_int_cst (integer_type_node,
6062 gfc_option.fpe));
6063 gfc_add_expr_to_block (&body, tmp);
6064 }
6065
6066 /* If this is the main program and an -fconvert option was provided,
6067 add a call to set_convert. */
6068
6069 if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
6070 {
6071 tmp = build_call_expr_loc (input_location,
6072 gfor_fndecl_set_convert, 1,
6073 build_int_cst (integer_type_node, flag_convert));
6074 gfc_add_expr_to_block (&body, tmp);
6075 }
6076
6077 /* If this is the main program and an -frecord-marker option was provided,
6078 add a call to set_record_marker. */
6079
6080 if (flag_record_marker != 0)
6081 {
6082 tmp = build_call_expr_loc (input_location,
6083 gfor_fndecl_set_record_marker, 1,
6084 build_int_cst (integer_type_node,
6085 flag_record_marker));
6086 gfc_add_expr_to_block (&body, tmp);
6087 }
6088
6089 if (flag_max_subrecord_length != 0)
6090 {
6091 tmp = build_call_expr_loc (input_location,
6092 gfor_fndecl_set_max_subrecord_length, 1,
6093 build_int_cst (integer_type_node,
6094 flag_max_subrecord_length));
6095 gfc_add_expr_to_block (&body, tmp);
6096 }
6097
6098 /* Call MAIN__(). */
6099 tmp = build_call_expr_loc (input_location,
6100 fndecl, 0);
6101 gfc_add_expr_to_block (&body, tmp);
6102
6103 /* Mark MAIN__ as used. */
6104 TREE_USED (fndecl) = 1;
6105
6106 /* Coarray: Call _gfortran_caf_finalize(void). */
6107 if (flag_coarray == GFC_FCOARRAY_LIB)
6108 {
6109 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
6110 gfc_add_expr_to_block (&body, tmp);
6111 }
6112
6113 /* "return 0". */
6114 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
6115 DECL_RESULT (ftn_main),
6116 build_int_cst (integer_type_node, 0));
6117 tmp = build1_v (RETURN_EXPR, tmp);
6118 gfc_add_expr_to_block (&body, tmp);
6119
6120
6121 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
6122 decl = getdecls ();
6123
6124 /* Finish off this function and send it for code generation. */
6125 poplevel (1, 1);
6126 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
6127
6128 DECL_SAVED_TREE (ftn_main)
6129 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
6130 DECL_INITIAL (ftn_main));
6131
6132 /* Output the GENERIC tree. */
6133 dump_function (TDI_original, ftn_main);
6134
6135 cgraph_node::finalize_function (ftn_main, true);
6136
6137 if (old_context)
6138 {
6139 pop_function_context ();
6140 saved_function_decls = saved_parent_function_decls;
6141 }
6142 current_function_decl = old_context;
6143 }
6144
6145
6146 /* Generate an appropriate return-statement for a procedure. */
6147
6148 tree
6149 gfc_generate_return (void)
6150 {
6151 gfc_symbol* sym;
6152 tree result;
6153 tree fndecl;
6154
6155 sym = current_procedure_symbol;
6156 fndecl = sym->backend_decl;
6157
6158 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
6159 result = NULL_TREE;
6160 else
6161 {
6162 result = get_proc_result (sym);
6163
6164 /* Set the return value to the dummy result variable. The
6165 types may be different for scalar default REAL functions
6166 with -ff2c, therefore we have to convert. */
6167 if (result != NULL_TREE)
6168 {
6169 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
6170 result = fold_build2_loc (input_location, MODIFY_EXPR,
6171 TREE_TYPE (result), DECL_RESULT (fndecl),
6172 result);
6173 }
6174 }
6175
6176 return build1_v (RETURN_EXPR, result);
6177 }
6178
6179
6180 static void
6181 is_from_ieee_module (gfc_symbol *sym)
6182 {
6183 if (sym->from_intmod == INTMOD_IEEE_FEATURES
6184 || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6185 || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6186 seen_ieee_symbol = 1;
6187 }
6188
6189
6190 static int
6191 is_ieee_module_used (gfc_namespace *ns)
6192 {
6193 seen_ieee_symbol = 0;
6194 gfc_traverse_ns (ns, is_from_ieee_module);
6195 return seen_ieee_symbol;
6196 }
6197
6198
6199 static gfc_omp_clauses *module_oacc_clauses;
6200
6201
6202 static void
6203 add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6204 {
6205 gfc_omp_namelist *n;
6206
6207 n = gfc_get_omp_namelist ();
6208 n->sym = sym;
6209 n->u.map_op = map_op;
6210
6211 if (!module_oacc_clauses)
6212 module_oacc_clauses = gfc_get_omp_clauses ();
6213
6214 if (module_oacc_clauses->lists[OMP_LIST_MAP])
6215 n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6216
6217 module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6218 }
6219
6220
6221 static void
6222 find_module_oacc_declare_clauses (gfc_symbol *sym)
6223 {
6224 if (sym->attr.use_assoc)
6225 {
6226 gfc_omp_map_op map_op;
6227
6228 if (sym->attr.oacc_declare_create)
6229 map_op = OMP_MAP_FORCE_ALLOC;
6230
6231 if (sym->attr.oacc_declare_copyin)
6232 map_op = OMP_MAP_FORCE_TO;
6233
6234 if (sym->attr.oacc_declare_deviceptr)
6235 map_op = OMP_MAP_FORCE_DEVICEPTR;
6236
6237 if (sym->attr.oacc_declare_device_resident)
6238 map_op = OMP_MAP_DEVICE_RESIDENT;
6239
6240 if (sym->attr.oacc_declare_create
6241 || sym->attr.oacc_declare_copyin
6242 || sym->attr.oacc_declare_deviceptr
6243 || sym->attr.oacc_declare_device_resident)
6244 {
6245 sym->attr.referenced = 1;
6246 add_clause (sym, map_op);
6247 }
6248 }
6249 }
6250
6251
6252 void
6253 finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6254 {
6255 gfc_code *code;
6256 gfc_oacc_declare *oc;
6257 locus where = gfc_current_locus;
6258 gfc_omp_clauses *omp_clauses = NULL;
6259 gfc_omp_namelist *n, *p;
6260
6261 gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6262
6263 if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6264 {
6265 gfc_oacc_declare *new_oc;
6266
6267 new_oc = gfc_get_oacc_declare ();
6268 new_oc->next = ns->oacc_declare;
6269 new_oc->clauses = module_oacc_clauses;
6270
6271 ns->oacc_declare = new_oc;
6272 module_oacc_clauses = NULL;
6273 }
6274
6275 if (!ns->oacc_declare)
6276 return;
6277
6278 for (oc = ns->oacc_declare; oc; oc = oc->next)
6279 {
6280 if (oc->module_var)
6281 continue;
6282
6283 if (block)
6284 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6285 "in BLOCK construct", &oc->loc);
6286
6287
6288 if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6289 {
6290 if (omp_clauses == NULL)
6291 {
6292 omp_clauses = oc->clauses;
6293 continue;
6294 }
6295
6296 for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6297 ;
6298
6299 gcc_assert (p->next == NULL);
6300
6301 p->next = omp_clauses->lists[OMP_LIST_MAP];
6302 omp_clauses = oc->clauses;
6303 }
6304 }
6305
6306 if (!omp_clauses)
6307 return;
6308
6309 for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6310 {
6311 switch (n->u.map_op)
6312 {
6313 case OMP_MAP_DEVICE_RESIDENT:
6314 n->u.map_op = OMP_MAP_FORCE_ALLOC;
6315 break;
6316
6317 default:
6318 break;
6319 }
6320 }
6321
6322 code = XCNEW (gfc_code);
6323 code->op = EXEC_OACC_DECLARE;
6324 code->loc = where;
6325
6326 code->ext.oacc_declare = gfc_get_oacc_declare ();
6327 code->ext.oacc_declare->clauses = omp_clauses;
6328
6329 code->block = XCNEW (gfc_code);
6330 code->block->op = EXEC_OACC_DECLARE;
6331 code->block->loc = where;
6332
6333 if (ns->code)
6334 code->block->next = ns->code;
6335
6336 ns->code = code;
6337
6338 return;
6339 }
6340
6341
6342 /* Generate code for a function. */
6343
6344 void
6345 gfc_generate_function_code (gfc_namespace * ns)
6346 {
6347 tree fndecl;
6348 tree old_context;
6349 tree decl;
6350 tree tmp;
6351 tree fpstate = NULL_TREE;
6352 stmtblock_t init, cleanup;
6353 stmtblock_t body;
6354 gfc_wrapped_block try_block;
6355 tree recurcheckvar = NULL_TREE;
6356 gfc_symbol *sym;
6357 gfc_symbol *previous_procedure_symbol;
6358 int rank, ieee;
6359 bool is_recursive;
6360
6361 sym = ns->proc_name;
6362 previous_procedure_symbol = current_procedure_symbol;
6363 current_procedure_symbol = sym;
6364
6365 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
6366 lost or worse. */
6367 sym->tlink = sym;
6368
6369 /* Create the declaration for functions with global scope. */
6370 if (!sym->backend_decl)
6371 gfc_create_function_decl (ns, false);
6372
6373 fndecl = sym->backend_decl;
6374 old_context = current_function_decl;
6375
6376 if (old_context)
6377 {
6378 push_function_context ();
6379 saved_parent_function_decls = saved_function_decls;
6380 saved_function_decls = NULL_TREE;
6381 }
6382
6383 trans_function_start (sym);
6384
6385 gfc_init_block (&init);
6386
6387 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
6388 {
6389 /* Copy length backend_decls to all entry point result
6390 symbols. */
6391 gfc_entry_list *el;
6392 tree backend_decl;
6393
6394 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
6395 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
6396 for (el = ns->entries; el; el = el->next)
6397 el->sym->result->ts.u.cl->backend_decl = backend_decl;
6398 }
6399
6400 /* Translate COMMON blocks. */
6401 gfc_trans_common (ns);
6402
6403 /* Null the parent fake result declaration if this namespace is
6404 a module function or an external procedures. */
6405 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6406 || ns->parent == NULL)
6407 parent_fake_result_decl = NULL_TREE;
6408
6409 gfc_generate_contained_functions (ns);
6410
6411 has_coarray_vars = false;
6412 generate_local_vars (ns);
6413
6414 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6415 generate_coarray_init (ns);
6416
6417 /* Keep the parent fake result declaration in module functions
6418 or external procedures. */
6419 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6420 || ns->parent == NULL)
6421 current_fake_result_decl = parent_fake_result_decl;
6422 else
6423 current_fake_result_decl = NULL_TREE;
6424
6425 is_recursive = sym->attr.recursive
6426 || (sym->attr.entry_master
6427 && sym->ns->entries->sym->attr.recursive);
6428 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6429 && !is_recursive && !flag_recursive)
6430 {
6431 char * msg;
6432
6433 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
6434 sym->name);
6435 recurcheckvar = gfc_create_var (logical_type_node, "is_recursive");
6436 TREE_STATIC (recurcheckvar) = 1;
6437 DECL_INITIAL (recurcheckvar) = logical_false_node;
6438 gfc_add_expr_to_block (&init, recurcheckvar);
6439 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
6440 &sym->declared_at, msg);
6441 gfc_add_modify (&init, recurcheckvar, logical_true_node);
6442 free (msg);
6443 }
6444
6445 /* Check if an IEEE module is used in the procedure. If so, save
6446 the floating point state. */
6447 ieee = is_ieee_module_used (ns);
6448 if (ieee)
6449 fpstate = gfc_save_fp_state (&init);
6450
6451 /* Now generate the code for the body of this function. */
6452 gfc_init_block (&body);
6453
6454 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6455 && sym->attr.subroutine)
6456 {
6457 tree alternate_return;
6458 alternate_return = gfc_get_fake_result_decl (sym, 0);
6459 gfc_add_modify (&body, alternate_return, integer_zero_node);
6460 }
6461
6462 if (ns->entries)
6463 {
6464 /* Jump to the correct entry point. */
6465 tmp = gfc_trans_entry_master_switch (ns->entries);
6466 gfc_add_expr_to_block (&body, tmp);
6467 }
6468
6469 /* If bounds-checking is enabled, generate code to check passed in actual
6470 arguments against the expected dummy argument attributes (e.g. string
6471 lengths). */
6472 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
6473 add_argument_checking (&body, sym);
6474
6475 finish_oacc_declare (ns, sym, false);
6476
6477 tmp = gfc_trans_code (ns->code);
6478 gfc_add_expr_to_block (&body, tmp);
6479
6480 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6481 || (sym->result && sym->result != sym
6482 && sym->result->ts.type == BT_DERIVED
6483 && sym->result->ts.u.derived->attr.alloc_comp))
6484 {
6485 bool artificial_result_decl = false;
6486 tree result = get_proc_result (sym);
6487 gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
6488
6489 /* Make sure that a function returning an object with
6490 alloc/pointer_components always has a result, where at least
6491 the allocatable/pointer components are set to zero. */
6492 if (result == NULL_TREE && sym->attr.function
6493 && ((sym->result->ts.type == BT_DERIVED
6494 && (sym->attr.allocatable
6495 || sym->attr.pointer
6496 || sym->result->ts.u.derived->attr.alloc_comp
6497 || sym->result->ts.u.derived->attr.pointer_comp))
6498 || (sym->result->ts.type == BT_CLASS
6499 && (CLASS_DATA (sym)->attr.allocatable
6500 || CLASS_DATA (sym)->attr.class_pointer
6501 || CLASS_DATA (sym->result)->attr.alloc_comp
6502 || CLASS_DATA (sym->result)->attr.pointer_comp))))
6503 {
6504 artificial_result_decl = true;
6505 result = gfc_get_fake_result_decl (sym, 0);
6506 }
6507
6508 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
6509 {
6510 if (sym->attr.allocatable && sym->attr.dimension == 0
6511 && sym->result == sym)
6512 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
6513 null_pointer_node));
6514 else if (sym->ts.type == BT_CLASS
6515 && CLASS_DATA (sym)->attr.allocatable
6516 && CLASS_DATA (sym)->attr.dimension == 0
6517 && sym->result == sym)
6518 {
6519 tmp = CLASS_DATA (sym)->backend_decl;
6520 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6521 TREE_TYPE (tmp), result, tmp, NULL_TREE);
6522 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
6523 null_pointer_node));
6524 }
6525 else if (sym->ts.type == BT_DERIVED
6526 && !sym->attr.allocatable)
6527 {
6528 gfc_expr *init_exp;
6529 /* Arrays are not initialized using the default initializer of
6530 their elements. Therefore only check if a default
6531 initializer is available when the result is scalar. */
6532 init_exp = rsym->as ? NULL
6533 : gfc_generate_initializer (&rsym->ts, true);
6534 if (init_exp)
6535 {
6536 tmp = gfc_trans_structure_assign (result, init_exp, 0);
6537 gfc_free_expr (init_exp);
6538 gfc_add_expr_to_block (&init, tmp);
6539 }
6540 else if (rsym->ts.u.derived->attr.alloc_comp)
6541 {
6542 rank = rsym->as ? rsym->as->rank : 0;
6543 tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
6544 rank);
6545 gfc_prepend_expr_to_block (&body, tmp);
6546 }
6547 }
6548 }
6549
6550 if (result == NULL_TREE || artificial_result_decl)
6551 {
6552 /* TODO: move to the appropriate place in resolve.c. */
6553 if (warn_return_type > 0 && sym == sym->result)
6554 gfc_warning (OPT_Wreturn_type,
6555 "Return value of function %qs at %L not set",
6556 sym->name, &sym->declared_at);
6557 if (warn_return_type > 0)
6558 TREE_NO_WARNING(sym->backend_decl) = 1;
6559 }
6560 if (result != NULL_TREE)
6561 gfc_add_expr_to_block (&body, gfc_generate_return ());
6562 }
6563
6564 gfc_init_block (&cleanup);
6565
6566 /* Reset recursion-check variable. */
6567 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6568 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
6569 {
6570 gfc_add_modify (&cleanup, recurcheckvar, logical_false_node);
6571 recurcheckvar = NULL;
6572 }
6573
6574 /* If IEEE modules are loaded, restore the floating-point state. */
6575 if (ieee)
6576 gfc_restore_fp_state (&cleanup, fpstate);
6577
6578 /* Finish the function body and add init and cleanup code. */
6579 tmp = gfc_finish_block (&body);
6580 gfc_start_wrapped_block (&try_block, tmp);
6581 /* Add code to create and cleanup arrays. */
6582 gfc_trans_deferred_vars (sym, &try_block);
6583 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
6584 gfc_finish_block (&cleanup));
6585
6586 /* Add all the decls we created during processing. */
6587 decl = nreverse (saved_function_decls);
6588 while (decl)
6589 {
6590 tree next;
6591
6592 next = DECL_CHAIN (decl);
6593 DECL_CHAIN (decl) = NULL_TREE;
6594 pushdecl (decl);
6595 decl = next;
6596 }
6597 saved_function_decls = NULL_TREE;
6598
6599 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
6600 decl = getdecls ();
6601
6602 /* Finish off this function and send it for code generation. */
6603 poplevel (1, 1);
6604 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6605
6606 DECL_SAVED_TREE (fndecl)
6607 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6608 DECL_INITIAL (fndecl));
6609
6610 /* Output the GENERIC tree. */
6611 dump_function (TDI_original, fndecl);
6612
6613 /* Store the end of the function, so that we get good line number
6614 info for the epilogue. */
6615 cfun->function_end_locus = input_location;
6616
6617 /* We're leaving the context of this function, so zap cfun.
6618 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6619 tree_rest_of_compilation. */
6620 set_cfun (NULL);
6621
6622 if (old_context)
6623 {
6624 pop_function_context ();
6625 saved_function_decls = saved_parent_function_decls;
6626 }
6627 current_function_decl = old_context;
6628
6629 if (decl_function_context (fndecl))
6630 {
6631 /* Register this function with cgraph just far enough to get it
6632 added to our parent's nested function list.
6633 If there are static coarrays in this function, the nested _caf_init
6634 function has already called cgraph_create_node, which also created
6635 the cgraph node for this function. */
6636 if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
6637 (void) cgraph_node::get_create (fndecl);
6638 }
6639 else
6640 cgraph_node::finalize_function (fndecl, true);
6641
6642 gfc_trans_use_stmts (ns);
6643 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
6644
6645 if (sym->attr.is_main_program)
6646 create_main_function (fndecl);
6647
6648 current_procedure_symbol = previous_procedure_symbol;
6649 }
6650
6651
6652 void
6653 gfc_generate_constructors (void)
6654 {
6655 gcc_assert (gfc_static_ctors == NULL_TREE);
6656 #if 0
6657 tree fnname;
6658 tree type;
6659 tree fndecl;
6660 tree decl;
6661 tree tmp;
6662
6663 if (gfc_static_ctors == NULL_TREE)
6664 return;
6665
6666 fnname = get_file_function_name ("I");
6667 type = build_function_type_list (void_type_node, NULL_TREE);
6668
6669 fndecl = build_decl (input_location,
6670 FUNCTION_DECL, fnname, type);
6671 TREE_PUBLIC (fndecl) = 1;
6672
6673 decl = build_decl (input_location,
6674 RESULT_DECL, NULL_TREE, void_type_node);
6675 DECL_ARTIFICIAL (decl) = 1;
6676 DECL_IGNORED_P (decl) = 1;
6677 DECL_CONTEXT (decl) = fndecl;
6678 DECL_RESULT (fndecl) = decl;
6679
6680 pushdecl (fndecl);
6681
6682 current_function_decl = fndecl;
6683
6684 rest_of_decl_compilation (fndecl, 1, 0);
6685
6686 make_decl_rtl (fndecl);
6687
6688 allocate_struct_function (fndecl, false);
6689
6690 pushlevel ();
6691
6692 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
6693 {
6694 tmp = build_call_expr_loc (input_location,
6695 TREE_VALUE (gfc_static_ctors), 0);
6696 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
6697 }
6698
6699 decl = getdecls ();
6700 poplevel (1, 1);
6701
6702 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6703 DECL_SAVED_TREE (fndecl)
6704 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6705 DECL_INITIAL (fndecl));
6706
6707 free_after_parsing (cfun);
6708 free_after_compilation (cfun);
6709
6710 tree_rest_of_compilation (fndecl);
6711
6712 current_function_decl = NULL_TREE;
6713 #endif
6714 }
6715
6716 /* Translates a BLOCK DATA program unit. This means emitting the
6717 commons contained therein plus their initializations. We also emit
6718 a globally visible symbol to make sure that each BLOCK DATA program
6719 unit remains unique. */
6720
6721 void
6722 gfc_generate_block_data (gfc_namespace * ns)
6723 {
6724 tree decl;
6725 tree id;
6726
6727 /* Tell the backend the source location of the block data. */
6728 if (ns->proc_name)
6729 gfc_set_backend_locus (&ns->proc_name->declared_at);
6730 else
6731 gfc_set_backend_locus (&gfc_current_locus);
6732
6733 /* Process the DATA statements. */
6734 gfc_trans_common (ns);
6735
6736 /* Create a global symbol with the mane of the block data. This is to
6737 generate linker errors if the same name is used twice. It is never
6738 really used. */
6739 if (ns->proc_name)
6740 id = gfc_sym_mangled_function_id (ns->proc_name);
6741 else
6742 id = get_identifier ("__BLOCK_DATA__");
6743
6744 decl = build_decl (input_location,
6745 VAR_DECL, id, gfc_array_index_type);
6746 TREE_PUBLIC (decl) = 1;
6747 TREE_STATIC (decl) = 1;
6748 DECL_IGNORED_P (decl) = 1;
6749
6750 pushdecl (decl);
6751 rest_of_decl_compilation (decl, 1, 0);
6752 }
6753
6754
6755 /* Process the local variables of a BLOCK construct. */
6756
6757 void
6758 gfc_process_block_locals (gfc_namespace* ns)
6759 {
6760 tree decl;
6761
6762 saved_local_decls = NULL_TREE;
6763 has_coarray_vars = false;
6764
6765 generate_local_vars (ns);
6766
6767 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6768 generate_coarray_init (ns);
6769
6770 decl = nreverse (saved_local_decls);
6771 while (decl)
6772 {
6773 tree next;
6774
6775 next = DECL_CHAIN (decl);
6776 DECL_CHAIN (decl) = NULL_TREE;
6777 pushdecl (decl);
6778 decl = next;
6779 }
6780 saved_local_decls = NULL_TREE;
6781 }
6782
6783
6784 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org