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