?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2017-09-15 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-decl.c
blobd227d519c63c66fab01a9a319a5c43300c47cf64
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.save == SAVE_NONE
4346 && !sym->attr.use_assoc
4347 && !sym->attr.host_assoc
4348 && !sym->attr.dummy
4349 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
4350 {
4351 gfc_init_block (&tmpblock);
4352 gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
4353 build_int_cst (gfc_array_index_type, 0));
4354 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4355 NULL_TREE);
4356 }
4357
4358 if (sym->ts.type == BT_CLASS
4359 && (sym->attr.save || flag_max_stack_var_size == 0)
4360 && CLASS_DATA (sym)->attr.allocatable)
4361 {
4362 tree vptr;
4363
4364 if (UNLIMITED_POLY (sym))
4365 vptr = null_pointer_node;
4366 else
4367 {
4368 gfc_symbol *vsym;
4369 vsym = gfc_find_derived_vtab (sym->ts.u.derived);
4370 vptr = gfc_get_symbol_decl (vsym);
4371 vptr = gfc_build_addr_expr (NULL, vptr);
4372 }
4373
4374 if (CLASS_DATA (sym)->attr.dimension
4375 || (CLASS_DATA (sym)->attr.codimension
4376 && flag_coarray != GFC_FCOARRAY_LIB))
4377 {
4378 tmp = gfc_class_data_get (sym->backend_decl);
4379 tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
4380 }
4381 else
4382 tmp = null_pointer_node;
4383
4384 DECL_INITIAL (sym->backend_decl)
4385 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
4386 TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
4387 }
4388 else if ((sym->attr.dimension || sym->attr.codimension
4389 || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
4390 {
4391 bool is_classarray = IS_CLASS_ARRAY (sym);
4392 symbol_attribute *array_attr;
4393 gfc_array_spec *as;
4394 array_type type_of_array;
4395
4396 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
4397 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
4398 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4399 type_of_array = as->type;
4400 if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
4401 type_of_array = AS_EXPLICIT;
4402 switch (type_of_array)
4403 {
4404 case AS_EXPLICIT:
4405 if (sym->attr.dummy || sym->attr.result)
4406 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4407 /* Allocatable and pointer arrays need to processed
4408 explicitly. */
4409 else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
4410 || (sym->ts.type == BT_CLASS
4411 && CLASS_DATA (sym)->attr.class_pointer)
4412 || array_attr->allocatable)
4413 {
4414 if (TREE_STATIC (sym->backend_decl))
4415 {
4416 gfc_save_backend_locus (&loc);
4417 gfc_set_backend_locus (&sym->declared_at);
4418 gfc_trans_static_array_pointer (sym);
4419 gfc_restore_backend_locus (&loc);
4420 }
4421 else
4422 {
4423 seen_trans_deferred_array = true;
4424 gfc_trans_deferred_array (sym, block);
4425 }
4426 }
4427 else if (sym->attr.codimension
4428 && TREE_STATIC (sym->backend_decl))
4429 {
4430 gfc_init_block (&tmpblock);
4431 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
4432 &tmpblock, sym);
4433 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4434 NULL_TREE);
4435 continue;
4436 }
4437 else
4438 {
4439 gfc_save_backend_locus (&loc);
4440 gfc_set_backend_locus (&sym->declared_at);
4441
4442 if (alloc_comp_or_fini)
4443 {
4444 seen_trans_deferred_array = true;
4445 gfc_trans_deferred_array (sym, block);
4446 }
4447 else if (sym->ts.type == BT_DERIVED
4448 && sym->value
4449 && !sym->attr.data
4450 && sym->attr.save == SAVE_NONE)
4451 {
4452 gfc_start_block (&tmpblock);
4453 gfc_init_default_dt (sym, &tmpblock, false);
4454 gfc_add_init_cleanup (block,
4455 gfc_finish_block (&tmpblock),
4456 NULL_TREE);
4457 }
4458
4459 gfc_trans_auto_array_allocation (sym->backend_decl,
4460 sym, block);
4461 gfc_restore_backend_locus (&loc);
4462 }
4463 break;
4464
4465 case AS_ASSUMED_SIZE:
4466 /* Must be a dummy parameter. */
4467 gcc_assert (sym->attr.dummy || as->cp_was_assumed);
4468
4469 /* We should always pass assumed size arrays the g77 way. */
4470 if (sym->attr.dummy)
4471 gfc_trans_g77_array (sym, block);
4472 break;
4473
4474 case AS_ASSUMED_SHAPE:
4475 /* Must be a dummy parameter. */
4476 gcc_assert (sym->attr.dummy);
4477
4478 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
4479 break;
4480
4481 case AS_ASSUMED_RANK:
4482 case AS_DEFERRED:
4483 seen_trans_deferred_array = true;
4484 gfc_trans_deferred_array (sym, block);
4485 if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
4486 && sym->attr.result)
4487 {
4488 gfc_start_block (&init);
4489 gfc_save_backend_locus (&loc);
4490 gfc_set_backend_locus (&sym->declared_at);
4491 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4492 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4493 }
4494 break;
4495
4496 default:
4497 gcc_unreachable ();
4498 }
4499 if (alloc_comp_or_fini && !seen_trans_deferred_array)
4500 gfc_trans_deferred_array (sym, block);
4501 }
4502 else if ((!sym->attr.dummy || sym->ts.deferred)
4503 && (sym->ts.type == BT_CLASS
4504 && CLASS_DATA (sym)->attr.class_pointer))
4505 continue;
4506 else if ((!sym->attr.dummy || sym->ts.deferred)
4507 && (sym->attr.allocatable
4508 || (sym->attr.pointer && sym->attr.result)
4509 || (sym->ts.type == BT_CLASS
4510 && CLASS_DATA (sym)->attr.allocatable)))
4511 {
4512 if (!sym->attr.save && flag_max_stack_var_size != 0)
4513 {
4514 tree descriptor = NULL_TREE;
4515
4516 gfc_save_backend_locus (&loc);
4517 gfc_set_backend_locus (&sym->declared_at);
4518 gfc_start_block (&init);
4519
4520 if (!sym->attr.pointer)
4521 {
4522 /* Nullify and automatic deallocation of allocatable
4523 scalars. */
4524 e = gfc_lval_expr_from_sym (sym);
4525 if (sym->ts.type == BT_CLASS)
4526 gfc_add_data_component (e);
4527
4528 gfc_init_se (&se, NULL);
4529 if (sym->ts.type != BT_CLASS
4530 || sym->ts.u.derived->attr.dimension
4531 || sym->ts.u.derived->attr.codimension)
4532 {
4533 se.want_pointer = 1;
4534 gfc_conv_expr (&se, e);
4535 }
4536 else if (sym->ts.type == BT_CLASS
4537 && !CLASS_DATA (sym)->attr.dimension
4538 && !CLASS_DATA (sym)->attr.codimension)
4539 {
4540 se.want_pointer = 1;
4541 gfc_conv_expr (&se, e);
4542 }
4543 else
4544 {
4545 se.descriptor_only = 1;
4546 gfc_conv_expr (&se, e);
4547 descriptor = se.expr;
4548 se.expr = gfc_conv_descriptor_data_addr (se.expr);
4549 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
4550 }
4551 gfc_free_expr (e);
4552
4553 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
4554 {
4555 /* Nullify when entering the scope. */
4556 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4557 TREE_TYPE (se.expr), se.expr,
4558 fold_convert (TREE_TYPE (se.expr),
4559 null_pointer_node));
4560 if (sym->attr.optional)
4561 {
4562 tree present = gfc_conv_expr_present (sym);
4563 tmp = build3_loc (input_location, COND_EXPR,
4564 void_type_node, present, tmp,
4565 build_empty_stmt (input_location));
4566 }
4567 gfc_add_expr_to_block (&init, tmp);
4568 }
4569 }
4570
4571 if ((sym->attr.dummy || sym->attr.result)
4572 && sym->ts.type == BT_CHARACTER
4573 && sym->ts.deferred
4574 && sym->ts.u.cl->passed_length)
4575 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4576 else
4577 gfc_restore_backend_locus (&loc);
4578
4579 /* Deallocate when leaving the scope. Nullifying is not
4580 needed. */
4581 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
4582 && !sym->ns->proc_name->attr.is_main_program)
4583 {
4584 if (sym->ts.type == BT_CLASS
4585 && CLASS_DATA (sym)->attr.codimension)
4586 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
4587 NULL_TREE, NULL_TREE,
4588 NULL_TREE, true, NULL,
4589 GFC_CAF_COARRAY_ANALYZE);
4590 else
4591 {
4592 gfc_expr *expr = gfc_lval_expr_from_sym (sym);
4593 tmp = gfc_deallocate_scalar_with_status (se.expr,
4594 NULL_TREE,
4595 NULL_TREE,
4596 true, expr,
4597 sym->ts);
4598 gfc_free_expr (expr);
4599 }
4600 }
4601
4602 if (sym->ts.type == BT_CLASS)
4603 {
4604 /* Initialize _vptr to declared type. */
4605 gfc_symbol *vtab;
4606 tree rhs;
4607
4608 gfc_save_backend_locus (&loc);
4609 gfc_set_backend_locus (&sym->declared_at);
4610 e = gfc_lval_expr_from_sym (sym);
4611 gfc_add_vptr_component (e);
4612 gfc_init_se (&se, NULL);
4613 se.want_pointer = 1;
4614 gfc_conv_expr (&se, e);
4615 gfc_free_expr (e);
4616 if (UNLIMITED_POLY (sym))
4617 rhs = build_int_cst (TREE_TYPE (se.expr), 0);
4618 else
4619 {
4620 vtab = gfc_find_derived_vtab (sym->ts.u.derived);
4621 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
4622 gfc_get_symbol_decl (vtab));
4623 }
4624 gfc_add_modify (&init, se.expr, rhs);
4625 gfc_restore_backend_locus (&loc);
4626 }
4627
4628 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4629 }
4630 }
4631 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
4632 {
4633 tree tmp = NULL;
4634 stmtblock_t init;
4635
4636 /* If we get to here, all that should be left are pointers. */
4637 gcc_assert (sym->attr.pointer);
4638
4639 if (sym->attr.dummy)
4640 {
4641 gfc_start_block (&init);
4642 gfc_save_backend_locus (&loc);
4643 gfc_set_backend_locus (&sym->declared_at);
4644 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4645 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4646 }
4647 }
4648 else if (sym->ts.deferred)
4649 gfc_fatal_error ("Deferred type parameter not yet supported");
4650 else if (alloc_comp_or_fini)
4651 gfc_trans_deferred_array (sym, block);
4652 else if (sym->ts.type == BT_CHARACTER)
4653 {
4654 gfc_save_backend_locus (&loc);
4655 gfc_set_backend_locus (&sym->declared_at);
4656 if (sym->attr.dummy || sym->attr.result)
4657 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
4658 else
4659 gfc_trans_auto_character_variable (sym, block);
4660 gfc_restore_backend_locus (&loc);
4661 }
4662 else if (sym->attr.assign)
4663 {
4664 gfc_save_backend_locus (&loc);
4665 gfc_set_backend_locus (&sym->declared_at);
4666 gfc_trans_assign_aux_var (sym, block);
4667 gfc_restore_backend_locus (&loc);
4668 }
4669 else if (sym->ts.type == BT_DERIVED
4670 && sym->value
4671 && !sym->attr.data
4672 && sym->attr.save == SAVE_NONE)
4673 {
4674 gfc_start_block (&tmpblock);
4675 gfc_init_default_dt (sym, &tmpblock, false);
4676 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4677 NULL_TREE);
4678 }
4679 else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
4680 gcc_unreachable ();
4681 }
4682
4683 gfc_init_block (&tmpblock);
4684
4685 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4686 {
4687 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
4688 {
4689 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
4690 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
4691 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
4692 }
4693 }
4694
4695 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
4696 && current_fake_result_decl != NULL)
4697 {
4698 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
4699 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
4700 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
4701 }
4702
4703 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
4704 }
4705
4706
4707 struct module_hasher : ggc_ptr_hash<module_htab_entry>
4708 {
4709 typedef const char *compare_type;
4710
4711 static hashval_t hash (module_htab_entry *s) { return htab_hash_string (s); }
4712 static bool
4713 equal (module_htab_entry *a, const char *b)
4714 {
4715 return !strcmp (a->name, b);
4716 }
4717 };
4718
4719 static GTY (()) hash_table<module_hasher> *module_htab;
4720
4721 /* Hash and equality functions for module_htab's decls. */
4722
4723 hashval_t
4724 module_decl_hasher::hash (tree t)
4725 {
4726 const_tree n = DECL_NAME (t);
4727 if (n == NULL_TREE)
4728 n = TYPE_NAME (TREE_TYPE (t));
4729 return htab_hash_string (IDENTIFIER_POINTER (n));
4730 }
4731
4732 bool
4733 module_decl_hasher::equal (tree t1, const char *x2)
4734 {
4735 const_tree n1 = DECL_NAME (t1);
4736 if (n1 == NULL_TREE)
4737 n1 = TYPE_NAME (TREE_TYPE (t1));
4738 return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
4739 }
4740
4741 struct module_htab_entry *
4742 gfc_find_module (const char *name)
4743 {
4744 if (! module_htab)
4745 module_htab = hash_table<module_hasher>::create_ggc (10);
4746
4747 module_htab_entry **slot
4748 = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT);
4749 if (*slot == NULL)
4750 {
4751 module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
4752
4753 entry->name = gfc_get_string ("%s", name);
4754 entry->decls = hash_table<module_decl_hasher>::create_ggc (10);
4755 *slot = entry;
4756 }
4757 return *slot;
4758 }
4759
4760 void
4761 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
4762 {
4763 const char *name;
4764
4765 if (DECL_NAME (decl))
4766 name = IDENTIFIER_POINTER (DECL_NAME (decl));
4767 else
4768 {
4769 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
4770 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
4771 }
4772 tree *slot
4773 = entry->decls->find_slot_with_hash (name, htab_hash_string (name),
4774 INSERT);
4775 if (*slot == NULL)
4776 *slot = decl;
4777 }
4778
4779
4780 /* Generate debugging symbols for namelists. This function must come after
4781 generate_local_decl to ensure that the variables in the namelist are
4782 already declared. */
4783
4784 static tree
4785 generate_namelist_decl (gfc_symbol * sym)
4786 {
4787 gfc_namelist *nml;
4788 tree decl;
4789 vec<constructor_elt, va_gc> *nml_decls = NULL;
4790
4791 gcc_assert (sym->attr.flavor == FL_NAMELIST);
4792 for (nml = sym->namelist; nml; nml = nml->next)
4793 {
4794 if (nml->sym->backend_decl == NULL_TREE)
4795 {
4796 nml->sym->attr.referenced = 1;
4797 nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
4798 }
4799 DECL_IGNORED_P (nml->sym->backend_decl) = 0;
4800 CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
4801 }
4802
4803 decl = make_node (NAMELIST_DECL);
4804 TREE_TYPE (decl) = void_type_node;
4805 NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
4806 DECL_NAME (decl) = get_identifier (sym->name);
4807 return decl;
4808 }
4809
4810
4811 /* Output an initialized decl for a module variable. */
4812
4813 static void
4814 gfc_create_module_variable (gfc_symbol * sym)
4815 {
4816 tree decl;
4817
4818 /* Module functions with alternate entries are dealt with later and
4819 would get caught by the next condition. */
4820 if (sym->attr.entry)
4821 return;
4822
4823 /* Make sure we convert the types of the derived types from iso_c_binding
4824 into (void *). */
4825 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4826 && sym->ts.type == BT_DERIVED)
4827 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4828
4829 if (gfc_fl_struct (sym->attr.flavor)
4830 && sym->backend_decl
4831 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4832 {
4833 decl = sym->backend_decl;
4834 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4835
4836 if (!sym->attr.use_assoc && !sym->attr.used_in_submodule)
4837 {
4838 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4839 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4840 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4841 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4842 == sym->ns->proc_name->backend_decl);
4843 }
4844 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4845 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4846 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4847 }
4848
4849 /* Only output variables, procedure pointers and array valued,
4850 or derived type, parameters. */
4851 if (sym->attr.flavor != FL_VARIABLE
4852 && !(sym->attr.flavor == FL_PARAMETER
4853 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4854 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4855 return;
4856
4857 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4858 {
4859 decl = sym->backend_decl;
4860 gcc_assert (DECL_FILE_SCOPE_P (decl));
4861 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4862 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4863 gfc_module_add_decl (cur_module, decl);
4864 }
4865
4866 /* Don't generate variables from other modules. Variables from
4867 COMMONs and Cray pointees will already have been generated. */
4868 if (sym->attr.use_assoc || sym->attr.used_in_submodule
4869 || sym->attr.in_common || sym->attr.cray_pointee)
4870 return;
4871
4872 /* Equivalenced variables arrive here after creation. */
4873 if (sym->backend_decl
4874 && (sym->equiv_built || sym->attr.in_equivalence))
4875 return;
4876
4877 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4878 gfc_internal_error ("backend decl for module variable %qs already exists",
4879 sym->name);
4880
4881 if (sym->module && !sym->attr.result && !sym->attr.dummy
4882 && (sym->attr.access == ACCESS_UNKNOWN
4883 && (sym->ns->default_access == ACCESS_PRIVATE
4884 || (sym->ns->default_access == ACCESS_UNKNOWN
4885 && flag_module_private))))
4886 sym->attr.access = ACCESS_PRIVATE;
4887
4888 if (warn_unused_variable && !sym->attr.referenced
4889 && sym->attr.access == ACCESS_PRIVATE)
4890 gfc_warning (OPT_Wunused_value,
4891 "Unused PRIVATE module variable %qs declared at %L",
4892 sym->name, &sym->declared_at);
4893
4894 /* We always want module variables to be created. */
4895 sym->attr.referenced = 1;
4896 /* Create the decl. */
4897 decl = gfc_get_symbol_decl (sym);
4898
4899 /* Create the variable. */
4900 pushdecl (decl);
4901 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE
4902 || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE
4903 && sym->fn_result_spec));
4904 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4905 rest_of_decl_compilation (decl, 1, 0);
4906 gfc_module_add_decl (cur_module, decl);
4907
4908 /* Also add length of strings. */
4909 if (sym->ts.type == BT_CHARACTER)
4910 {
4911 tree length;
4912
4913 length = sym->ts.u.cl->backend_decl;
4914 gcc_assert (length || sym->attr.proc_pointer);
4915 if (length && !INTEGER_CST_P (length))
4916 {
4917 pushdecl (length);
4918 rest_of_decl_compilation (length, 1, 0);
4919 }
4920 }
4921
4922 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4923 && sym->attr.referenced && !sym->attr.use_assoc)
4924 has_coarray_vars = true;
4925 }
4926
4927 /* Emit debug information for USE statements. */
4928
4929 static void
4930 gfc_trans_use_stmts (gfc_namespace * ns)
4931 {
4932 gfc_use_list *use_stmt;
4933 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4934 {
4935 struct module_htab_entry *entry
4936 = gfc_find_module (use_stmt->module_name);
4937 gfc_use_rename *rent;
4938
4939 if (entry->namespace_decl == NULL)
4940 {
4941 entry->namespace_decl
4942 = build_decl (input_location,
4943 NAMESPACE_DECL,
4944 get_identifier (use_stmt->module_name),
4945 void_type_node);
4946 DECL_EXTERNAL (entry->namespace_decl) = 1;
4947 }
4948 gfc_set_backend_locus (&use_stmt->where);
4949 if (!use_stmt->only_flag)
4950 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4951 NULL_TREE,
4952 ns->proc_name->backend_decl,
4953 false, false);
4954 for (rent = use_stmt->rename; rent; rent = rent->next)
4955 {
4956 tree decl, local_name;
4957
4958 if (rent->op != INTRINSIC_NONE)
4959 continue;
4960
4961 hashval_t hash = htab_hash_string (rent->use_name);
4962 tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
4963 INSERT);
4964 if (*slot == NULL)
4965 {
4966 gfc_symtree *st;
4967
4968 st = gfc_find_symtree (ns->sym_root,
4969 rent->local_name[0]
4970 ? rent->local_name : rent->use_name);
4971
4972 /* The following can happen if a derived type is renamed. */
4973 if (!st)
4974 {
4975 char *name;
4976 name = xstrdup (rent->local_name[0]
4977 ? rent->local_name : rent->use_name);
4978 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4979 st = gfc_find_symtree (ns->sym_root, name);
4980 free (name);
4981 gcc_assert (st);
4982 }
4983
4984 /* Sometimes, generic interfaces wind up being over-ruled by a
4985 local symbol (see PR41062). */
4986 if (!st->n.sym->attr.use_assoc)
4987 continue;
4988
4989 if (st->n.sym->backend_decl
4990 && DECL_P (st->n.sym->backend_decl)
4991 && st->n.sym->module
4992 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4993 {
4994 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4995 || !VAR_P (st->n.sym->backend_decl));
4996 decl = copy_node (st->n.sym->backend_decl);
4997 DECL_CONTEXT (decl) = entry->namespace_decl;
4998 DECL_EXTERNAL (decl) = 1;
4999 DECL_IGNORED_P (decl) = 0;
5000 DECL_INITIAL (decl) = NULL_TREE;
5001 }
5002 else if (st->n.sym->attr.flavor == FL_NAMELIST
5003 && st->n.sym->attr.use_only
5004 && st->n.sym->module
5005 && strcmp (st->n.sym->module, use_stmt->module_name)
5006 == 0)
5007 {
5008 decl = generate_namelist_decl (st->n.sym);
5009 DECL_CONTEXT (decl) = entry->namespace_decl;
5010 DECL_EXTERNAL (decl) = 1;
5011 DECL_IGNORED_P (decl) = 0;
5012 DECL_INITIAL (decl) = NULL_TREE;
5013 }
5014 else
5015 {
5016 *slot = error_mark_node;
5017 entry->decls->clear_slot (slot);
5018 continue;
5019 }
5020 *slot = decl;
5021 }
5022 decl = (tree) *slot;
5023 if (rent->local_name[0])
5024 local_name = get_identifier (rent->local_name);
5025 else
5026 local_name = NULL_TREE;
5027 gfc_set_backend_locus (&rent->where);
5028 (*debug_hooks->imported_module_or_decl) (decl, local_name,
5029 ns->proc_name->backend_decl,
5030 !use_stmt->only_flag,
5031 false);
5032 }
5033 }
5034 }
5035
5036
5037 /* Return true if expr is a constant initializer that gfc_conv_initializer
5038 will handle. */
5039
5040 static bool
5041 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
5042 bool pointer)
5043 {
5044 gfc_constructor *c;
5045 gfc_component *cm;
5046
5047 if (pointer)
5048 return true;
5049 else if (array)
5050 {
5051 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
5052 return true;
5053 else if (expr->expr_type == EXPR_STRUCTURE)
5054 return check_constant_initializer (expr, ts, false, false);
5055 else if (expr->expr_type != EXPR_ARRAY)
5056 return false;
5057 for (c = gfc_constructor_first (expr->value.constructor);
5058 c; c = gfc_constructor_next (c))
5059 {
5060 if (c->iterator)
5061 return false;
5062 if (c->expr->expr_type == EXPR_STRUCTURE)
5063 {
5064 if (!check_constant_initializer (c->expr, ts, false, false))
5065 return false;
5066 }
5067 else if (c->expr->expr_type != EXPR_CONSTANT)
5068 return false;
5069 }
5070 return true;
5071 }
5072 else switch (ts->type)
5073 {
5074 case_bt_struct:
5075 if (expr->expr_type != EXPR_STRUCTURE)
5076 return false;
5077 cm = expr->ts.u.derived->components;
5078 for (c = gfc_constructor_first (expr->value.constructor);
5079 c; c = gfc_constructor_next (c), cm = cm->next)
5080 {
5081 if (!c->expr || cm->attr.allocatable)
5082 continue;
5083 if (!check_constant_initializer (c->expr, &cm->ts,
5084 cm->attr.dimension,
5085 cm->attr.pointer))
5086 return false;
5087 }
5088 return true;
5089 default:
5090 return expr->expr_type == EXPR_CONSTANT;
5091 }
5092 }
5093
5094 /* Emit debug info for parameters and unreferenced variables with
5095 initializers. */
5096
5097 static void
5098 gfc_emit_parameter_debug_info (gfc_symbol *sym)
5099 {
5100 tree decl;
5101
5102 if (sym->attr.flavor != FL_PARAMETER
5103 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
5104 return;
5105
5106 if (sym->backend_decl != NULL
5107 || sym->value == NULL
5108 || sym->attr.use_assoc
5109 || sym->attr.dummy
5110 || sym->attr.result
5111 || sym->attr.function
5112 || sym->attr.intrinsic
5113 || sym->attr.pointer
5114 || sym->attr.allocatable
5115 || sym->attr.cray_pointee
5116 || sym->attr.threadprivate
5117 || sym->attr.is_bind_c
5118 || sym->attr.subref_array_pointer
5119 || sym->attr.assign)
5120 return;
5121
5122 if (sym->ts.type == BT_CHARACTER)
5123 {
5124 gfc_conv_const_charlen (sym->ts.u.cl);
5125 if (sym->ts.u.cl->backend_decl == NULL
5126 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
5127 return;
5128 }
5129 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
5130 return;
5131
5132 if (sym->as)
5133 {
5134 int n;
5135
5136 if (sym->as->type != AS_EXPLICIT)
5137 return;
5138 for (n = 0; n < sym->as->rank; n++)
5139 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
5140 || sym->as->upper[n] == NULL
5141 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
5142 return;
5143 }
5144
5145 if (!check_constant_initializer (sym->value, &sym->ts,
5146 sym->attr.dimension, false))
5147 return;
5148
5149 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
5150 return;
5151
5152 /* Create the decl for the variable or constant. */
5153 decl = build_decl (input_location,
5154 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
5155 gfc_sym_identifier (sym), gfc_sym_type (sym));
5156 if (sym->attr.flavor == FL_PARAMETER)
5157 TREE_READONLY (decl) = 1;
5158 gfc_set_decl_location (decl, &sym->declared_at);
5159 if (sym->attr.dimension)
5160 GFC_DECL_PACKED_ARRAY (decl) = 1;
5161 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5162 TREE_STATIC (decl) = 1;
5163 TREE_USED (decl) = 1;
5164 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
5165 TREE_PUBLIC (decl) = 1;
5166 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
5167 TREE_TYPE (decl),
5168 sym->attr.dimension,
5169 false, false);
5170 debug_hooks->early_global_decl (decl);
5171 }
5172
5173
5174 static void
5175 generate_coarray_sym_init (gfc_symbol *sym)
5176 {
5177 tree tmp, size, decl, token, desc;
5178 bool is_lock_type, is_event_type;
5179 int reg_type;
5180 gfc_se se;
5181 symbol_attribute attr;
5182
5183 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
5184 || sym->attr.use_assoc || !sym->attr.referenced
5185 || sym->attr.select_type_temporary)
5186 return;
5187
5188 decl = sym->backend_decl;
5189 TREE_USED(decl) = 1;
5190 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
5191
5192 is_lock_type = sym->ts.type == BT_DERIVED
5193 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5194 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
5195
5196 is_event_type = sym->ts.type == BT_DERIVED
5197 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
5198 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
5199
5200 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
5201 to make sure the variable is not optimized away. */
5202 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
5203
5204 /* For lock types, we pass the array size as only the library knows the
5205 size of the variable. */
5206 if (is_lock_type || is_event_type)
5207 size = gfc_index_one_node;
5208 else
5209 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
5210
5211 /* Ensure that we do not have size=0 for zero-sized arrays. */
5212 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
5213 fold_convert (size_type_node, size),
5214 build_int_cst (size_type_node, 1));
5215
5216 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
5217 {
5218 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
5219 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
5220 fold_convert (size_type_node, tmp), size);
5221 }
5222
5223 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
5224 token = gfc_build_addr_expr (ppvoid_type_node,
5225 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
5226 if (is_lock_type)
5227 reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
5228 else if (is_event_type)
5229 reg_type = GFC_CAF_EVENT_STATIC;
5230 else
5231 reg_type = GFC_CAF_COARRAY_STATIC;
5232
5233 /* Compile the symbol attribute. */
5234 if (sym->ts.type == BT_CLASS)
5235 {
5236 attr = CLASS_DATA (sym)->attr;
5237 /* The pointer attribute is always set on classes, overwrite it with the
5238 class_pointer attribute, which denotes the pointer for classes. */
5239 attr.pointer = attr.class_pointer;
5240 }
5241 else
5242 attr = sym->attr;
5243 gfc_init_se (&se, NULL);
5244 desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
5245 gfc_add_block_to_block (&caf_init_block, &se.pre);
5246
5247 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5248 build_int_cst (integer_type_node, reg_type),
5249 token, gfc_build_addr_expr (pvoid_type_node, desc),
5250 null_pointer_node, /* stat. */
5251 null_pointer_node, /* errgmsg. */
5252 integer_zero_node); /* errmsg_len. */
5253 gfc_add_expr_to_block (&caf_init_block, tmp);
5254 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5255 gfc_conv_descriptor_data_get (desc)));
5256
5257 /* Handle "static" initializer. */
5258 if (sym->value)
5259 {
5260 sym->attr.pointer = 1;
5261 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
5262 true, false);
5263 sym->attr.pointer = 0;
5264 gfc_add_expr_to_block (&caf_init_block, tmp);
5265 }
5266 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
5267 {
5268 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
5269 ? sym->as->rank : 0,
5270 GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
5271 gfc_add_expr_to_block (&caf_init_block, tmp);
5272 }
5273 }
5274
5275
5276 /* Generate constructor function to initialize static, nonallocatable
5277 coarrays. */
5278
5279 static void
5280 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
5281 {
5282 tree fndecl, tmp, decl, save_fn_decl;
5283
5284 save_fn_decl = current_function_decl;
5285 push_function_context ();
5286
5287 tmp = build_function_type_list (void_type_node, NULL_TREE);
5288 fndecl = build_decl (input_location, FUNCTION_DECL,
5289 create_tmp_var_name ("_caf_init"), tmp);
5290
5291 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
5292 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
5293
5294 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
5295 DECL_ARTIFICIAL (decl) = 1;
5296 DECL_IGNORED_P (decl) = 1;
5297 DECL_CONTEXT (decl) = fndecl;
5298 DECL_RESULT (fndecl) = decl;
5299
5300 pushdecl (fndecl);
5301 current_function_decl = fndecl;
5302 announce_function (fndecl);
5303
5304 rest_of_decl_compilation (fndecl, 0, 0);
5305 make_decl_rtl (fndecl);
5306 allocate_struct_function (fndecl, false);
5307
5308 pushlevel ();
5309 gfc_init_block (&caf_init_block);
5310
5311 gfc_traverse_ns (ns, generate_coarray_sym_init);
5312
5313 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
5314 decl = getdecls ();
5315
5316 poplevel (1, 1);
5317 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5318
5319 DECL_SAVED_TREE (fndecl)
5320 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5321 DECL_INITIAL (fndecl));
5322 dump_function (TDI_original, fndecl);
5323
5324 cfun->function_end_locus = input_location;
5325 set_cfun (NULL);
5326
5327 if (decl_function_context (fndecl))
5328 (void) cgraph_node::create (fndecl);
5329 else
5330 cgraph_node::finalize_function (fndecl, true);
5331
5332 pop_function_context ();
5333 current_function_decl = save_fn_decl;
5334 }
5335
5336
5337 static void
5338 create_module_nml_decl (gfc_symbol *sym)
5339 {
5340 if (sym->attr.flavor == FL_NAMELIST)
5341 {
5342 tree decl = generate_namelist_decl (sym);
5343 pushdecl (decl);
5344 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
5345 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
5346 rest_of_decl_compilation (decl, 1, 0);
5347 gfc_module_add_decl (cur_module, decl);
5348 }
5349 }
5350
5351
5352 /* Generate all the required code for module variables. */
5353
5354 void
5355 gfc_generate_module_vars (gfc_namespace * ns)
5356 {
5357 module_namespace = ns;
5358 cur_module = gfc_find_module (ns->proc_name->name);
5359
5360 /* Check if the frontend left the namespace in a reasonable state. */
5361 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
5362
5363 /* Generate COMMON blocks. */
5364 gfc_trans_common (ns);
5365
5366 has_coarray_vars = false;
5367
5368 /* Create decls for all the module variables. */
5369 gfc_traverse_ns (ns, gfc_create_module_variable);
5370 gfc_traverse_ns (ns, create_module_nml_decl);
5371
5372 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5373 generate_coarray_init (ns);
5374
5375 cur_module = NULL;
5376
5377 gfc_trans_use_stmts (ns);
5378 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5379 }
5380
5381
5382 static void
5383 gfc_generate_contained_functions (gfc_namespace * parent)
5384 {
5385 gfc_namespace *ns;
5386
5387 /* We create all the prototypes before generating any code. */
5388 for (ns = parent->contained; ns; ns = ns->sibling)
5389 {
5390 /* Skip namespaces from used modules. */
5391 if (ns->parent != parent)
5392 continue;
5393
5394 gfc_create_function_decl (ns, false);
5395 }
5396
5397 for (ns = parent->contained; ns; ns = ns->sibling)
5398 {
5399 /* Skip namespaces from used modules. */
5400 if (ns->parent != parent)
5401 continue;
5402
5403 gfc_generate_function_code (ns);
5404 }
5405 }
5406
5407
5408 /* Drill down through expressions for the array specification bounds and
5409 character length calling generate_local_decl for all those variables
5410 that have not already been declared. */
5411
5412 static void
5413 generate_local_decl (gfc_symbol *);
5414
5415 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5416
5417 static bool
5418 expr_decls (gfc_expr *e, gfc_symbol *sym,
5419 int *f ATTRIBUTE_UNUSED)
5420 {
5421 if (e->expr_type != EXPR_VARIABLE
5422 || sym == e->symtree->n.sym
5423 || e->symtree->n.sym->mark
5424 || e->symtree->n.sym->ns != sym->ns)
5425 return false;
5426
5427 generate_local_decl (e->symtree->n.sym);
5428 return false;
5429 }
5430
5431 static void
5432 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
5433 {
5434 gfc_traverse_expr (e, sym, expr_decls, 0);
5435 }
5436
5437
5438 /* Check for dependencies in the character length and array spec. */
5439
5440 static void
5441 generate_dependency_declarations (gfc_symbol *sym)
5442 {
5443 int i;
5444
5445 if (sym->ts.type == BT_CHARACTER
5446 && sym->ts.u.cl
5447 && sym->ts.u.cl->length
5448 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5449 generate_expr_decls (sym, sym->ts.u.cl->length);
5450
5451 if (sym->as && sym->as->rank)
5452 {
5453 for (i = 0; i < sym->as->rank; i++)
5454 {
5455 generate_expr_decls (sym, sym->as->lower[i]);
5456 generate_expr_decls (sym, sym->as->upper[i]);
5457 }
5458 }
5459 }
5460
5461
5462 /* Generate decls for all local variables. We do this to ensure correct
5463 handling of expressions which only appear in the specification of
5464 other functions. */
5465
5466 static void
5467 generate_local_decl (gfc_symbol * sym)
5468 {
5469 if (sym->attr.flavor == FL_VARIABLE)
5470 {
5471 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
5472 && sym->attr.referenced && !sym->attr.use_assoc)
5473 has_coarray_vars = true;
5474
5475 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
5476 generate_dependency_declarations (sym);
5477
5478 if (sym->attr.referenced)
5479 gfc_get_symbol_decl (sym);
5480
5481 /* Warnings for unused dummy arguments. */
5482 else if (sym->attr.dummy && !sym->attr.in_namelist)
5483 {
5484 /* INTENT(out) dummy arguments are likely meant to be set. */
5485 if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
5486 {
5487 if (sym->ts.type != BT_DERIVED)
5488 gfc_warning (OPT_Wunused_dummy_argument,
5489 "Dummy argument %qs at %L was declared "
5490 "INTENT(OUT) but was not set", sym->name,
5491 &sym->declared_at);
5492 else if (!gfc_has_default_initializer (sym->ts.u.derived)
5493 && !sym->ts.u.derived->attr.zero_comp)
5494 gfc_warning (OPT_Wunused_dummy_argument,
5495 "Derived-type dummy argument %qs at %L was "
5496 "declared INTENT(OUT) but was not set and "
5497 "does not have a default initializer",
5498 sym->name, &sym->declared_at);
5499 if (sym->backend_decl != NULL_TREE)
5500 TREE_NO_WARNING(sym->backend_decl) = 1;
5501 }
5502 else if (warn_unused_dummy_argument)
5503 {
5504 gfc_warning (OPT_Wunused_dummy_argument,
5505 "Unused dummy argument %qs at %L", sym->name,
5506 &sym->declared_at);
5507 if (sym->backend_decl != NULL_TREE)
5508 TREE_NO_WARNING(sym->backend_decl) = 1;
5509 }
5510 }
5511
5512 /* Warn for unused variables, but not if they're inside a common
5513 block or a namelist. */
5514 else if (warn_unused_variable
5515 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
5516 {
5517 if (sym->attr.use_only)
5518 {
5519 gfc_warning (OPT_Wunused_variable,
5520 "Unused module variable %qs which has been "
5521 "explicitly imported at %L", sym->name,
5522 &sym->declared_at);
5523 if (sym->backend_decl != NULL_TREE)
5524 TREE_NO_WARNING(sym->backend_decl) = 1;
5525 }
5526 else if (!sym->attr.use_assoc)
5527 {
5528 /* Corner case: the symbol may be an entry point. At this point,
5529 it may appear to be an unused variable. Suppress warning. */
5530 bool enter = false;
5531 gfc_entry_list *el;
5532
5533 for (el = sym->ns->entries; el; el=el->next)
5534 if (strcmp(sym->name, el->sym->name) == 0)
5535 enter = true;
5536
5537 if (!enter)
5538 gfc_warning (OPT_Wunused_variable,
5539 "Unused variable %qs declared at %L",
5540 sym->name, &sym->declared_at);
5541 if (sym->backend_decl != NULL_TREE)
5542 TREE_NO_WARNING(sym->backend_decl) = 1;
5543 }
5544 }
5545
5546 /* For variable length CHARACTER parameters, the PARM_DECL already
5547 references the length variable, so force gfc_get_symbol_decl
5548 even when not referenced. If optimize > 0, it will be optimized
5549 away anyway. But do this only after emitting -Wunused-parameter
5550 warning if requested. */
5551 if (sym->attr.dummy && !sym->attr.referenced
5552 && sym->ts.type == BT_CHARACTER
5553 && sym->ts.u.cl->backend_decl != NULL
5554 && VAR_P (sym->ts.u.cl->backend_decl))
5555 {
5556 sym->attr.referenced = 1;
5557 gfc_get_symbol_decl (sym);
5558 }
5559
5560 /* INTENT(out) dummy arguments and result variables with allocatable
5561 components are reset by default and need to be set referenced to
5562 generate the code for nullification and automatic lengths. */
5563 if (!sym->attr.referenced
5564 && sym->ts.type == BT_DERIVED
5565 && sym->ts.u.derived->attr.alloc_comp
5566 && !sym->attr.pointer
5567 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
5568 ||
5569 (sym->attr.result && sym != sym->result)))
5570 {
5571 sym->attr.referenced = 1;
5572 gfc_get_symbol_decl (sym);
5573 }
5574
5575 /* Check for dependencies in the array specification and string
5576 length, adding the necessary declarations to the function. We
5577 mark the symbol now, as well as in traverse_ns, to prevent
5578 getting stuck in a circular dependency. */
5579 sym->mark = 1;
5580 }
5581 else if (sym->attr.flavor == FL_PARAMETER)
5582 {
5583 if (warn_unused_parameter
5584 && !sym->attr.referenced)
5585 {
5586 if (!sym->attr.use_assoc)
5587 gfc_warning (OPT_Wunused_parameter,
5588 "Unused parameter %qs declared at %L", sym->name,
5589 &sym->declared_at);
5590 else if (sym->attr.use_only)
5591 gfc_warning (OPT_Wunused_parameter,
5592 "Unused parameter %qs which has been explicitly "
5593 "imported at %L", sym->name, &sym->declared_at);
5594 }
5595
5596 if (sym->ns
5597 && sym->ns->parent
5598 && sym->ns->parent->code
5599 && sym->ns->parent->code->op == EXEC_BLOCK)
5600 {
5601 if (sym->attr.referenced)
5602 gfc_get_symbol_decl (sym);
5603 sym->mark = 1;
5604 }
5605 }
5606 else if (sym->attr.flavor == FL_PROCEDURE)
5607 {
5608 /* TODO: move to the appropriate place in resolve.c. */
5609 if (warn_return_type
5610 && sym->attr.function
5611 && sym->result
5612 && sym != sym->result
5613 && !sym->result->attr.referenced
5614 && !sym->attr.use_assoc
5615 && sym->attr.if_source != IFSRC_IFBODY)
5616 {
5617 gfc_warning (OPT_Wreturn_type,
5618 "Return value %qs of function %qs declared at "
5619 "%L not set", sym->result->name, sym->name,
5620 &sym->result->declared_at);
5621
5622 /* Prevents "Unused variable" warning for RESULT variables. */
5623 sym->result->mark = 1;
5624 }
5625 }
5626
5627 if (sym->attr.dummy == 1)
5628 {
5629 /* Modify the tree type for scalar character dummy arguments of bind(c)
5630 procedures if they are passed by value. The tree type for them will
5631 be promoted to INTEGER_TYPE for the middle end, which appears to be
5632 what C would do with characters passed by-value. The value attribute
5633 implies the dummy is a scalar. */
5634 if (sym->attr.value == 1 && sym->backend_decl != NULL
5635 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
5636 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
5637 gfc_conv_scalar_char_value (sym, NULL, NULL);
5638
5639 /* Unused procedure passed as dummy argument. */
5640 if (sym->attr.flavor == FL_PROCEDURE)
5641 {
5642 if (!sym->attr.referenced)
5643 {
5644 if (warn_unused_dummy_argument)
5645 gfc_warning (OPT_Wunused_dummy_argument,
5646 "Unused dummy argument %qs at %L", sym->name,
5647 &sym->declared_at);
5648 }
5649
5650 /* Silence bogus "unused parameter" warnings from the
5651 middle end. */
5652 if (sym->backend_decl != NULL_TREE)
5653 TREE_NO_WARNING (sym->backend_decl) = 1;
5654 }
5655 }
5656
5657 /* Make sure we convert the types of the derived types from iso_c_binding
5658 into (void *). */
5659 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5660 && sym->ts.type == BT_DERIVED)
5661 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5662 }
5663
5664
5665 static void
5666 generate_local_nml_decl (gfc_symbol * sym)
5667 {
5668 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
5669 {
5670 tree decl = generate_namelist_decl (sym);
5671 pushdecl (decl);
5672 }
5673 }
5674
5675
5676 static void
5677 generate_local_vars (gfc_namespace * ns)
5678 {
5679 gfc_traverse_ns (ns, generate_local_decl);
5680 gfc_traverse_ns (ns, generate_local_nml_decl);
5681 }
5682
5683
5684 /* Generate a switch statement to jump to the correct entry point. Also
5685 creates the label decls for the entry points. */
5686
5687 static tree
5688 gfc_trans_entry_master_switch (gfc_entry_list * el)
5689 {
5690 stmtblock_t block;
5691 tree label;
5692 tree tmp;
5693 tree val;
5694
5695 gfc_init_block (&block);
5696 for (; el; el = el->next)
5697 {
5698 /* Add the case label. */
5699 label = gfc_build_label_decl (NULL_TREE);
5700 val = build_int_cst (gfc_array_index_type, el->id);
5701 tmp = build_case_label (val, NULL_TREE, label);
5702 gfc_add_expr_to_block (&block, tmp);
5703
5704 /* And jump to the actual entry point. */
5705 label = gfc_build_label_decl (NULL_TREE);
5706 tmp = build1_v (GOTO_EXPR, label);
5707 gfc_add_expr_to_block (&block, tmp);
5708
5709 /* Save the label decl. */
5710 el->label = label;
5711 }
5712 tmp = gfc_finish_block (&block);
5713 /* The first argument selects the entry point. */
5714 val = DECL_ARGUMENTS (current_function_decl);
5715 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
5716 val, tmp, NULL_TREE);
5717 return tmp;
5718 }
5719
5720
5721 /* Add code to string lengths of actual arguments passed to a function against
5722 the expected lengths of the dummy arguments. */
5723
5724 static void
5725 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
5726 {
5727 gfc_formal_arglist *formal;
5728
5729 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
5730 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
5731 && !formal->sym->ts.deferred)
5732 {
5733 enum tree_code comparison;
5734 tree cond;
5735 tree argname;
5736 gfc_symbol *fsym;
5737 gfc_charlen *cl;
5738 const char *message;
5739
5740 fsym = formal->sym;
5741 cl = fsym->ts.u.cl;
5742
5743 gcc_assert (cl);
5744 gcc_assert (cl->passed_length != NULL_TREE);
5745 gcc_assert (cl->backend_decl != NULL_TREE);
5746
5747 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5748 string lengths must match exactly. Otherwise, it is only required
5749 that the actual string length is *at least* the expected one.
5750 Sequence association allows for a mismatch of the string length
5751 if the actual argument is (part of) an array, but only if the
5752 dummy argument is an array. (See "Sequence association" in
5753 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5754 if (fsym->attr.pointer || fsym->attr.allocatable
5755 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
5756 || fsym->as->type == AS_ASSUMED_RANK)))
5757 {
5758 comparison = NE_EXPR;
5759 message = _("Actual string length does not match the declared one"
5760 " for dummy argument '%s' (%ld/%ld)");
5761 }
5762 else if (fsym->as && fsym->as->rank != 0)
5763 continue;
5764 else
5765 {
5766 comparison = LT_EXPR;
5767 message = _("Actual string length is shorter than the declared one"
5768 " for dummy argument '%s' (%ld/%ld)");
5769 }
5770
5771 /* Build the condition. For optional arguments, an actual length
5772 of 0 is also acceptable if the associated string is NULL, which
5773 means the argument was not passed. */
5774 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
5775 cl->passed_length, cl->backend_decl);
5776 if (fsym->attr.optional)
5777 {
5778 tree not_absent;
5779 tree not_0length;
5780 tree absent_failed;
5781
5782 not_0length = fold_build2_loc (input_location, NE_EXPR,
5783 boolean_type_node,
5784 cl->passed_length,
5785 build_zero_cst (gfc_charlen_type_node));
5786 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5787 fsym->attr.referenced = 1;
5788 not_absent = gfc_conv_expr_present (fsym);
5789
5790 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5791 boolean_type_node, not_0length,
5792 not_absent);
5793
5794 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5795 boolean_type_node, cond, absent_failed);
5796 }
5797
5798 /* Build the runtime check. */
5799 argname = gfc_build_cstring_const (fsym->name);
5800 argname = gfc_build_addr_expr (pchar_type_node, argname);
5801 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
5802 message, argname,
5803 fold_convert (long_integer_type_node,
5804 cl->passed_length),
5805 fold_convert (long_integer_type_node,
5806 cl->backend_decl));
5807 }
5808 }
5809
5810
5811 static void
5812 create_main_function (tree fndecl)
5813 {
5814 tree old_context;
5815 tree ftn_main;
5816 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
5817 stmtblock_t body;
5818
5819 old_context = current_function_decl;
5820
5821 if (old_context)
5822 {
5823 push_function_context ();
5824 saved_parent_function_decls = saved_function_decls;
5825 saved_function_decls = NULL_TREE;
5826 }
5827
5828 /* main() function must be declared with global scope. */
5829 gcc_assert (current_function_decl == NULL_TREE);
5830
5831 /* Declare the function. */
5832 tmp = build_function_type_list (integer_type_node, integer_type_node,
5833 build_pointer_type (pchar_type_node),
5834 NULL_TREE);
5835 main_identifier_node = get_identifier ("main");
5836 ftn_main = build_decl (input_location, FUNCTION_DECL,
5837 main_identifier_node, tmp);
5838 DECL_EXTERNAL (ftn_main) = 0;
5839 TREE_PUBLIC (ftn_main) = 1;
5840 TREE_STATIC (ftn_main) = 1;
5841 DECL_ATTRIBUTES (ftn_main)
5842 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
5843
5844 /* Setup the result declaration (for "return 0"). */
5845 result_decl = build_decl (input_location,
5846 RESULT_DECL, NULL_TREE, integer_type_node);
5847 DECL_ARTIFICIAL (result_decl) = 1;
5848 DECL_IGNORED_P (result_decl) = 1;
5849 DECL_CONTEXT (result_decl) = ftn_main;
5850 DECL_RESULT (ftn_main) = result_decl;
5851
5852 pushdecl (ftn_main);
5853
5854 /* Get the arguments. */
5855
5856 arglist = NULL_TREE;
5857 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
5858
5859 tmp = TREE_VALUE (typelist);
5860 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
5861 DECL_CONTEXT (argc) = ftn_main;
5862 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
5863 TREE_READONLY (argc) = 1;
5864 gfc_finish_decl (argc);
5865 arglist = chainon (arglist, argc);
5866
5867 typelist = TREE_CHAIN (typelist);
5868 tmp = TREE_VALUE (typelist);
5869 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5870 DECL_CONTEXT (argv) = ftn_main;
5871 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5872 TREE_READONLY (argv) = 1;
5873 DECL_BY_REFERENCE (argv) = 1;
5874 gfc_finish_decl (argv);
5875 arglist = chainon (arglist, argv);
5876
5877 DECL_ARGUMENTS (ftn_main) = arglist;
5878 current_function_decl = ftn_main;
5879 announce_function (ftn_main);
5880
5881 rest_of_decl_compilation (ftn_main, 1, 0);
5882 make_decl_rtl (ftn_main);
5883 allocate_struct_function (ftn_main, false);
5884 pushlevel ();
5885
5886 gfc_init_block (&body);
5887
5888 /* Call some libgfortran initialization routines, call then MAIN__(). */
5889
5890 /* Call _gfortran_caf_init (*argc, ***argv). */
5891 if (flag_coarray == GFC_FCOARRAY_LIB)
5892 {
5893 tree pint_type, pppchar_type;
5894 pint_type = build_pointer_type (integer_type_node);
5895 pppchar_type
5896 = build_pointer_type (build_pointer_type (pchar_type_node));
5897
5898 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
5899 gfc_build_addr_expr (pint_type, argc),
5900 gfc_build_addr_expr (pppchar_type, argv));
5901 gfc_add_expr_to_block (&body, tmp);
5902 }
5903
5904 /* Call _gfortran_set_args (argc, argv). */
5905 TREE_USED (argc) = 1;
5906 TREE_USED (argv) = 1;
5907 tmp = build_call_expr_loc (input_location,
5908 gfor_fndecl_set_args, 2, argc, argv);
5909 gfc_add_expr_to_block (&body, tmp);
5910
5911 /* Add a call to set_options to set up the runtime library Fortran
5912 language standard parameters. */
5913 {
5914 tree array_type, array, var;
5915 vec<constructor_elt, va_gc> *v = NULL;
5916 static const int noptions = 7;
5917
5918 /* Passing a new option to the library requires three modifications:
5919 + add it to the tree_cons list below
5920 + change the noptions variable above
5921 + modify the library (runtime/compile_options.c)! */
5922
5923 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5924 build_int_cst (integer_type_node,
5925 gfc_option.warn_std));
5926 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5927 build_int_cst (integer_type_node,
5928 gfc_option.allow_std));
5929 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5930 build_int_cst (integer_type_node, pedantic));
5931 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5932 build_int_cst (integer_type_node, flag_backtrace));
5933 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5934 build_int_cst (integer_type_node, flag_sign_zero));
5935 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5936 build_int_cst (integer_type_node,
5937 (gfc_option.rtcheck
5938 & GFC_RTCHECK_BOUNDS)));
5939 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5940 build_int_cst (integer_type_node,
5941 gfc_option.fpe_summary));
5942
5943 array_type = build_array_type_nelts (integer_type_node, noptions);
5944 array = build_constructor (array_type, v);
5945 TREE_CONSTANT (array) = 1;
5946 TREE_STATIC (array) = 1;
5947
5948 /* Create a static variable to hold the jump table. */
5949 var = build_decl (input_location, VAR_DECL,
5950 create_tmp_var_name ("options"), array_type);
5951 DECL_ARTIFICIAL (var) = 1;
5952 DECL_IGNORED_P (var) = 1;
5953 TREE_CONSTANT (var) = 1;
5954 TREE_STATIC (var) = 1;
5955 TREE_READONLY (var) = 1;
5956 DECL_INITIAL (var) = array;
5957 pushdecl (var);
5958 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5959
5960 tmp = build_call_expr_loc (input_location,
5961 gfor_fndecl_set_options, 2,
5962 build_int_cst (integer_type_node, noptions), var);
5963 gfc_add_expr_to_block (&body, tmp);
5964 }
5965
5966 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5967 the library will raise a FPE when needed. */
5968 if (gfc_option.fpe != 0)
5969 {
5970 tmp = build_call_expr_loc (input_location,
5971 gfor_fndecl_set_fpe, 1,
5972 build_int_cst (integer_type_node,
5973 gfc_option.fpe));
5974 gfc_add_expr_to_block (&body, tmp);
5975 }
5976
5977 /* If this is the main program and an -fconvert option was provided,
5978 add a call to set_convert. */
5979
5980 if (flag_convert != GFC_FLAG_CONVERT_NATIVE)
5981 {
5982 tmp = build_call_expr_loc (input_location,
5983 gfor_fndecl_set_convert, 1,
5984 build_int_cst (integer_type_node, flag_convert));
5985 gfc_add_expr_to_block (&body, tmp);
5986 }
5987
5988 /* If this is the main program and an -frecord-marker option was provided,
5989 add a call to set_record_marker. */
5990
5991 if (flag_record_marker != 0)
5992 {
5993 tmp = build_call_expr_loc (input_location,
5994 gfor_fndecl_set_record_marker, 1,
5995 build_int_cst (integer_type_node,
5996 flag_record_marker));
5997 gfc_add_expr_to_block (&body, tmp);
5998 }
5999
6000 if (flag_max_subrecord_length != 0)
6001 {
6002 tmp = build_call_expr_loc (input_location,
6003 gfor_fndecl_set_max_subrecord_length, 1,
6004 build_int_cst (integer_type_node,
6005 flag_max_subrecord_length));
6006 gfc_add_expr_to_block (&body, tmp);
6007 }
6008
6009 /* Call MAIN__(). */
6010 tmp = build_call_expr_loc (input_location,
6011 fndecl, 0);
6012 gfc_add_expr_to_block (&body, tmp);
6013
6014 /* Mark MAIN__ as used. */
6015 TREE_USED (fndecl) = 1;
6016
6017 /* Coarray: Call _gfortran_caf_finalize(void). */
6018 if (flag_coarray == GFC_FCOARRAY_LIB)
6019 {
6020 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
6021 gfc_add_expr_to_block (&body, tmp);
6022 }
6023
6024 /* "return 0". */
6025 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
6026 DECL_RESULT (ftn_main),
6027 build_int_cst (integer_type_node, 0));
6028 tmp = build1_v (RETURN_EXPR, tmp);
6029 gfc_add_expr_to_block (&body, tmp);
6030
6031
6032 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
6033 decl = getdecls ();
6034
6035 /* Finish off this function and send it for code generation. */
6036 poplevel (1, 1);
6037 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
6038
6039 DECL_SAVED_TREE (ftn_main)
6040 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
6041 DECL_INITIAL (ftn_main));
6042
6043 /* Output the GENERIC tree. */
6044 dump_function (TDI_original, ftn_main);
6045
6046 cgraph_node::finalize_function (ftn_main, true);
6047
6048 if (old_context)
6049 {
6050 pop_function_context ();
6051 saved_function_decls = saved_parent_function_decls;
6052 }
6053 current_function_decl = old_context;
6054 }
6055
6056
6057 /* Get the result expression for a procedure. */
6058
6059 static tree
6060 get_proc_result (gfc_symbol* sym)
6061 {
6062 if (sym->attr.subroutine || sym == sym->result)
6063 {
6064 if (current_fake_result_decl != NULL)
6065 return TREE_VALUE (current_fake_result_decl);
6066
6067 return NULL_TREE;
6068 }
6069
6070 return sym->result->backend_decl;
6071 }
6072
6073
6074 /* Generate an appropriate return-statement for a procedure. */
6075
6076 tree
6077 gfc_generate_return (void)
6078 {
6079 gfc_symbol* sym;
6080 tree result;
6081 tree fndecl;
6082
6083 sym = current_procedure_symbol;
6084 fndecl = sym->backend_decl;
6085
6086 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
6087 result = NULL_TREE;
6088 else
6089 {
6090 result = get_proc_result (sym);
6091
6092 /* Set the return value to the dummy result variable. The
6093 types may be different for scalar default REAL functions
6094 with -ff2c, therefore we have to convert. */
6095 if (result != NULL_TREE)
6096 {
6097 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
6098 result = fold_build2_loc (input_location, MODIFY_EXPR,
6099 TREE_TYPE (result), DECL_RESULT (fndecl),
6100 result);
6101 }
6102 }
6103
6104 return build1_v (RETURN_EXPR, result);
6105 }
6106
6107
6108 static void
6109 is_from_ieee_module (gfc_symbol *sym)
6110 {
6111 if (sym->from_intmod == INTMOD_IEEE_FEATURES
6112 || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS
6113 || sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6114 seen_ieee_symbol = 1;
6115 }
6116
6117
6118 static int
6119 is_ieee_module_used (gfc_namespace *ns)
6120 {
6121 seen_ieee_symbol = 0;
6122 gfc_traverse_ns (ns, is_from_ieee_module);
6123 return seen_ieee_symbol;
6124 }
6125
6126
6127 static gfc_omp_clauses *module_oacc_clauses;
6128
6129
6130 static void
6131 add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
6132 {
6133 gfc_omp_namelist *n;
6134
6135 n = gfc_get_omp_namelist ();
6136 n->sym = sym;
6137 n->u.map_op = map_op;
6138
6139 if (!module_oacc_clauses)
6140 module_oacc_clauses = gfc_get_omp_clauses ();
6141
6142 if (module_oacc_clauses->lists[OMP_LIST_MAP])
6143 n->next = module_oacc_clauses->lists[OMP_LIST_MAP];
6144
6145 module_oacc_clauses->lists[OMP_LIST_MAP] = n;
6146 }
6147
6148
6149 static void
6150 find_module_oacc_declare_clauses (gfc_symbol *sym)
6151 {
6152 if (sym->attr.use_assoc)
6153 {
6154 gfc_omp_map_op map_op;
6155
6156 if (sym->attr.oacc_declare_create)
6157 map_op = OMP_MAP_FORCE_ALLOC;
6158
6159 if (sym->attr.oacc_declare_copyin)
6160 map_op = OMP_MAP_FORCE_TO;
6161
6162 if (sym->attr.oacc_declare_deviceptr)
6163 map_op = OMP_MAP_FORCE_DEVICEPTR;
6164
6165 if (sym->attr.oacc_declare_device_resident)
6166 map_op = OMP_MAP_DEVICE_RESIDENT;
6167
6168 if (sym->attr.oacc_declare_create
6169 || sym->attr.oacc_declare_copyin
6170 || sym->attr.oacc_declare_deviceptr
6171 || sym->attr.oacc_declare_device_resident)
6172 {
6173 sym->attr.referenced = 1;
6174 add_clause (sym, map_op);
6175 }
6176 }
6177 }
6178
6179
6180 void
6181 finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
6182 {
6183 gfc_code *code;
6184 gfc_oacc_declare *oc;
6185 locus where = gfc_current_locus;
6186 gfc_omp_clauses *omp_clauses = NULL;
6187 gfc_omp_namelist *n, *p;
6188
6189 gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
6190
6191 if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
6192 {
6193 gfc_oacc_declare *new_oc;
6194
6195 new_oc = gfc_get_oacc_declare ();
6196 new_oc->next = ns->oacc_declare;
6197 new_oc->clauses = module_oacc_clauses;
6198
6199 ns->oacc_declare = new_oc;
6200 module_oacc_clauses = NULL;
6201 }
6202
6203 if (!ns->oacc_declare)
6204 return;
6205
6206 for (oc = ns->oacc_declare; oc; oc = oc->next)
6207 {
6208 if (oc->module_var)
6209 continue;
6210
6211 if (block)
6212 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed "
6213 "in BLOCK construct", &oc->loc);
6214
6215
6216 if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP])
6217 {
6218 if (omp_clauses == NULL)
6219 {
6220 omp_clauses = oc->clauses;
6221 continue;
6222 }
6223
6224 for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next)
6225 ;
6226
6227 gcc_assert (p->next == NULL);
6228
6229 p->next = omp_clauses->lists[OMP_LIST_MAP];
6230 omp_clauses = oc->clauses;
6231 }
6232 }
6233
6234 if (!omp_clauses)
6235 return;
6236
6237 for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next)
6238 {
6239 switch (n->u.map_op)
6240 {
6241 case OMP_MAP_DEVICE_RESIDENT:
6242 n->u.map_op = OMP_MAP_FORCE_ALLOC;
6243 break;
6244
6245 default:
6246 break;
6247 }
6248 }
6249
6250 code = XCNEW (gfc_code);
6251 code->op = EXEC_OACC_DECLARE;
6252 code->loc = where;
6253
6254 code->ext.oacc_declare = gfc_get_oacc_declare ();
6255 code->ext.oacc_declare->clauses = omp_clauses;
6256
6257 code->block = XCNEW (gfc_code);
6258 code->block->op = EXEC_OACC_DECLARE;
6259 code->block->loc = where;
6260
6261 if (ns->code)
6262 code->block->next = ns->code;
6263
6264 ns->code = code;
6265
6266 return;
6267 }
6268
6269
6270 /* Generate code for a function. */
6271
6272 void
6273 gfc_generate_function_code (gfc_namespace * ns)
6274 {
6275 tree fndecl;
6276 tree old_context;
6277 tree decl;
6278 tree tmp;
6279 tree fpstate = NULL_TREE;
6280 stmtblock_t init, cleanup;
6281 stmtblock_t body;
6282 gfc_wrapped_block try_block;
6283 tree recurcheckvar = NULL_TREE;
6284 gfc_symbol *sym;
6285 gfc_symbol *previous_procedure_symbol;
6286 int rank, ieee;
6287 bool is_recursive;
6288
6289 sym = ns->proc_name;
6290 previous_procedure_symbol = current_procedure_symbol;
6291 current_procedure_symbol = sym;
6292
6293 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get
6294 lost or worse. */
6295 sym->tlink = sym;
6296
6297 /* Create the declaration for functions with global scope. */
6298 if (!sym->backend_decl)
6299 gfc_create_function_decl (ns, false);
6300
6301 fndecl = sym->backend_decl;
6302 old_context = current_function_decl;
6303
6304 if (old_context)
6305 {
6306 push_function_context ();
6307 saved_parent_function_decls = saved_function_decls;
6308 saved_function_decls = NULL_TREE;
6309 }
6310
6311 trans_function_start (sym);
6312
6313 gfc_init_block (&init);
6314
6315 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
6316 {
6317 /* Copy length backend_decls to all entry point result
6318 symbols. */
6319 gfc_entry_list *el;
6320 tree backend_decl;
6321
6322 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
6323 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
6324 for (el = ns->entries; el; el = el->next)
6325 el->sym->result->ts.u.cl->backend_decl = backend_decl;
6326 }
6327
6328 /* Translate COMMON blocks. */
6329 gfc_trans_common (ns);
6330
6331 /* Null the parent fake result declaration if this namespace is
6332 a module function or an external procedures. */
6333 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6334 || ns->parent == NULL)
6335 parent_fake_result_decl = NULL_TREE;
6336
6337 gfc_generate_contained_functions (ns);
6338
6339 nonlocal_dummy_decls = NULL;
6340 nonlocal_dummy_decl_pset = NULL;
6341
6342 has_coarray_vars = false;
6343 generate_local_vars (ns);
6344
6345 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6346 generate_coarray_init (ns);
6347
6348 /* Keep the parent fake result declaration in module functions
6349 or external procedures. */
6350 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
6351 || ns->parent == NULL)
6352 current_fake_result_decl = parent_fake_result_decl;
6353 else
6354 current_fake_result_decl = NULL_TREE;
6355
6356 is_recursive = sym->attr.recursive
6357 || (sym->attr.entry_master
6358 && sym->ns->entries->sym->attr.recursive);
6359 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6360 && !is_recursive && !flag_recursive)
6361 {
6362 char * msg;
6363
6364 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
6365 sym->name);
6366 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
6367 TREE_STATIC (recurcheckvar) = 1;
6368 DECL_INITIAL (recurcheckvar) = boolean_false_node;
6369 gfc_add_expr_to_block (&init, recurcheckvar);
6370 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
6371 &sym->declared_at, msg);
6372 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
6373 free (msg);
6374 }
6375
6376 /* Check if an IEEE module is used in the procedure. If so, save
6377 the floating point state. */
6378 ieee = is_ieee_module_used (ns);
6379 if (ieee)
6380 fpstate = gfc_save_fp_state (&init);
6381
6382 /* Now generate the code for the body of this function. */
6383 gfc_init_block (&body);
6384
6385 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6386 && sym->attr.subroutine)
6387 {
6388 tree alternate_return;
6389 alternate_return = gfc_get_fake_result_decl (sym, 0);
6390 gfc_add_modify (&body, alternate_return, integer_zero_node);
6391 }
6392
6393 if (ns->entries)
6394 {
6395 /* Jump to the correct entry point. */
6396 tmp = gfc_trans_entry_master_switch (ns->entries);
6397 gfc_add_expr_to_block (&body, tmp);
6398 }
6399
6400 /* If bounds-checking is enabled, generate code to check passed in actual
6401 arguments against the expected dummy argument attributes (e.g. string
6402 lengths). */
6403 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
6404 add_argument_checking (&body, sym);
6405
6406 finish_oacc_declare (ns, sym, false);
6407
6408 tmp = gfc_trans_code (ns->code);
6409 gfc_add_expr_to_block (&body, tmp);
6410
6411 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
6412 || (sym->result && sym->result != sym
6413 && sym->result->ts.type == BT_DERIVED
6414 && sym->result->ts.u.derived->attr.alloc_comp))
6415 {
6416 bool artificial_result_decl = false;
6417 tree result = get_proc_result (sym);
6418 gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
6419
6420 /* Make sure that a function returning an object with
6421 alloc/pointer_components always has a result, where at least
6422 the allocatable/pointer components are set to zero. */
6423 if (result == NULL_TREE && sym->attr.function
6424 && ((sym->result->ts.type == BT_DERIVED
6425 && (sym->attr.allocatable
6426 || sym->attr.pointer
6427 || sym->result->ts.u.derived->attr.alloc_comp
6428 || sym->result->ts.u.derived->attr.pointer_comp))
6429 || (sym->result->ts.type == BT_CLASS
6430 && (CLASS_DATA (sym)->attr.allocatable
6431 || CLASS_DATA (sym)->attr.class_pointer
6432 || CLASS_DATA (sym->result)->attr.alloc_comp
6433 || CLASS_DATA (sym->result)->attr.pointer_comp))))
6434 {
6435 artificial_result_decl = true;
6436 result = gfc_get_fake_result_decl (sym, 0);
6437 }
6438
6439 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
6440 {
6441 if (sym->attr.allocatable && sym->attr.dimension == 0
6442 && sym->result == sym)
6443 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
6444 null_pointer_node));
6445 else if (sym->ts.type == BT_CLASS
6446 && CLASS_DATA (sym)->attr.allocatable
6447 && CLASS_DATA (sym)->attr.dimension == 0
6448 && sym->result == sym)
6449 {
6450 tmp = CLASS_DATA (sym)->backend_decl;
6451 tmp = fold_build3_loc (input_location, COMPONENT_REF,
6452 TREE_TYPE (tmp), result, tmp, NULL_TREE);
6453 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
6454 null_pointer_node));
6455 }
6456 else if (sym->ts.type == BT_DERIVED
6457 && !sym->attr.allocatable)
6458 {
6459 gfc_expr *init_exp;
6460 /* Arrays are not initialized using the default initializer of
6461 their elements. Therefore only check if a default
6462 initializer is available when the result is scalar. */
6463 init_exp = rsym->as ? NULL
6464 : gfc_generate_initializer (&rsym->ts, true);
6465 if (init_exp)
6466 {
6467 tmp = gfc_trans_structure_assign (result, init_exp, 0);
6468 gfc_free_expr (init_exp);
6469 gfc_add_expr_to_block (&init, tmp);
6470 }
6471 else if (rsym->ts.u.derived->attr.alloc_comp)
6472 {
6473 rank = rsym->as ? rsym->as->rank : 0;
6474 tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
6475 rank);
6476 gfc_prepend_expr_to_block (&body, tmp);
6477 }
6478 }
6479 }
6480
6481 if (result == NULL_TREE || artificial_result_decl)
6482 {
6483 /* TODO: move to the appropriate place in resolve.c. */
6484 if (warn_return_type && sym == sym->result)
6485 gfc_warning (OPT_Wreturn_type,
6486 "Return value of function %qs at %L not set",
6487 sym->name, &sym->declared_at);
6488 if (warn_return_type)
6489 TREE_NO_WARNING(sym->backend_decl) = 1;
6490 }
6491 if (result != NULL_TREE)
6492 gfc_add_expr_to_block (&body, gfc_generate_return ());
6493 }
6494
6495 gfc_init_block (&cleanup);
6496
6497 /* Reset recursion-check variable. */
6498 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6499 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
6500 {
6501 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
6502 recurcheckvar = NULL;
6503 }
6504
6505 /* If IEEE modules are loaded, restore the floating-point state. */
6506 if (ieee)
6507 gfc_restore_fp_state (&cleanup, fpstate);
6508
6509 /* Finish the function body and add init and cleanup code. */
6510 tmp = gfc_finish_block (&body);
6511 gfc_start_wrapped_block (&try_block, tmp);
6512 /* Add code to create and cleanup arrays. */
6513 gfc_trans_deferred_vars (sym, &try_block);
6514 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
6515 gfc_finish_block (&cleanup));
6516
6517 /* Add all the decls we created during processing. */
6518 decl = nreverse (saved_function_decls);
6519 while (decl)
6520 {
6521 tree next;
6522
6523 next = DECL_CHAIN (decl);
6524 DECL_CHAIN (decl) = NULL_TREE;
6525 pushdecl (decl);
6526 decl = next;
6527 }
6528 saved_function_decls = NULL_TREE;
6529
6530 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
6531 decl = getdecls ();
6532
6533 /* Finish off this function and send it for code generation. */
6534 poplevel (1, 1);
6535 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6536
6537 DECL_SAVED_TREE (fndecl)
6538 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6539 DECL_INITIAL (fndecl));
6540
6541 if (nonlocal_dummy_decls)
6542 {
6543 BLOCK_VARS (DECL_INITIAL (fndecl))
6544 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
6545 delete nonlocal_dummy_decl_pset;
6546 nonlocal_dummy_decls = NULL;
6547 nonlocal_dummy_decl_pset = NULL;
6548 }
6549
6550 /* Output the GENERIC tree. */
6551 dump_function (TDI_original, fndecl);
6552
6553 /* Store the end of the function, so that we get good line number
6554 info for the epilogue. */
6555 cfun->function_end_locus = input_location;
6556
6557 /* We're leaving the context of this function, so zap cfun.
6558 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6559 tree_rest_of_compilation. */
6560 set_cfun (NULL);
6561
6562 if (old_context)
6563 {
6564 pop_function_context ();
6565 saved_function_decls = saved_parent_function_decls;
6566 }
6567 current_function_decl = old_context;
6568
6569 if (decl_function_context (fndecl))
6570 {
6571 /* Register this function with cgraph just far enough to get it
6572 added to our parent's nested function list.
6573 If there are static coarrays in this function, the nested _caf_init
6574 function has already called cgraph_create_node, which also created
6575 the cgraph node for this function. */
6576 if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB)
6577 (void) cgraph_node::get_create (fndecl);
6578 }
6579 else
6580 cgraph_node::finalize_function (fndecl, true);
6581
6582 gfc_trans_use_stmts (ns);
6583 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
6584
6585 if (sym->attr.is_main_program)
6586 create_main_function (fndecl);
6587
6588 current_procedure_symbol = previous_procedure_symbol;
6589 }
6590
6591
6592 void
6593 gfc_generate_constructors (void)
6594 {
6595 gcc_assert (gfc_static_ctors == NULL_TREE);
6596 #if 0
6597 tree fnname;
6598 tree type;
6599 tree fndecl;
6600 tree decl;
6601 tree tmp;
6602
6603 if (gfc_static_ctors == NULL_TREE)
6604 return;
6605
6606 fnname = get_file_function_name ("I");
6607 type = build_function_type_list (void_type_node, NULL_TREE);
6608
6609 fndecl = build_decl (input_location,
6610 FUNCTION_DECL, fnname, type);
6611 TREE_PUBLIC (fndecl) = 1;
6612
6613 decl = build_decl (input_location,
6614 RESULT_DECL, NULL_TREE, void_type_node);
6615 DECL_ARTIFICIAL (decl) = 1;
6616 DECL_IGNORED_P (decl) = 1;
6617 DECL_CONTEXT (decl) = fndecl;
6618 DECL_RESULT (fndecl) = decl;
6619
6620 pushdecl (fndecl);
6621
6622 current_function_decl = fndecl;
6623
6624 rest_of_decl_compilation (fndecl, 1, 0);
6625
6626 make_decl_rtl (fndecl);
6627
6628 allocate_struct_function (fndecl, false);
6629
6630 pushlevel ();
6631
6632 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
6633 {
6634 tmp = build_call_expr_loc (input_location,
6635 TREE_VALUE (gfc_static_ctors), 0);
6636 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
6637 }
6638
6639 decl = getdecls ();
6640 poplevel (1, 1);
6641
6642 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
6643 DECL_SAVED_TREE (fndecl)
6644 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6645 DECL_INITIAL (fndecl));
6646
6647 free_after_parsing (cfun);
6648 free_after_compilation (cfun);
6649
6650 tree_rest_of_compilation (fndecl);
6651
6652 current_function_decl = NULL_TREE;
6653 #endif
6654 }
6655
6656 /* Translates a BLOCK DATA program unit. This means emitting the
6657 commons contained therein plus their initializations. We also emit
6658 a globally visible symbol to make sure that each BLOCK DATA program
6659 unit remains unique. */
6660
6661 void
6662 gfc_generate_block_data (gfc_namespace * ns)
6663 {
6664 tree decl;
6665 tree id;
6666
6667 /* Tell the backend the source location of the block data. */
6668 if (ns->proc_name)
6669 gfc_set_backend_locus (&ns->proc_name->declared_at);
6670 else
6671 gfc_set_backend_locus (&gfc_current_locus);
6672
6673 /* Process the DATA statements. */
6674 gfc_trans_common (ns);
6675
6676 /* Create a global symbol with the mane of the block data. This is to
6677 generate linker errors if the same name is used twice. It is never
6678 really used. */
6679 if (ns->proc_name)
6680 id = gfc_sym_mangled_function_id (ns->proc_name);
6681 else
6682 id = get_identifier ("__BLOCK_DATA__");
6683
6684 decl = build_decl (input_location,
6685 VAR_DECL, id, gfc_array_index_type);
6686 TREE_PUBLIC (decl) = 1;
6687 TREE_STATIC (decl) = 1;
6688 DECL_IGNORED_P (decl) = 1;
6689
6690 pushdecl (decl);
6691 rest_of_decl_compilation (decl, 1, 0);
6692 }
6693
6694
6695 /* Process the local variables of a BLOCK construct. */
6696
6697 void
6698 gfc_process_block_locals (gfc_namespace* ns)
6699 {
6700 tree decl;
6701
6702 gcc_assert (saved_local_decls == NULL_TREE);
6703 has_coarray_vars = false;
6704
6705 generate_local_vars (ns);
6706
6707 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6708 generate_coarray_init (ns);
6709
6710 decl = nreverse (saved_local_decls);
6711 while (decl)
6712 {
6713 tree next;
6714
6715 next = DECL_CHAIN (decl);
6716 DECL_CHAIN (decl) = NULL_TREE;
6717 pushdecl (decl);
6718 decl = next;
6719 }
6720 saved_local_decls = NULL_TREE;
6721 }
6722
6723
6724 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org