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