]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blob
? search:


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