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