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