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