1 /* Backend function setup
2 Copyright (C) 2002-2016 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
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
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
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/>. */
21 /* trans-decl.c -- Handling of backend function and variable decls, etc */
25 #include "coretypes.h"
30 #include "gimple-expr.h" /* For create_tmp_var_raw. */
32 #include "stringpool.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
38 #include "tree-dump.h"
39 #include "toplev.h" /* For announce_function. */
41 #include "constructor.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
47 #include "gomp-constants.h"
50 #define MAX_LABEL_VALUE 99999
53 /* Holds the result of the function if no result variable specified. */
55 static GTY(()) tree current_fake_result_decl
;
56 static GTY(()) tree parent_fake_result_decl
;
59 /* Holds the variable DECLs for the current function. */
61 static GTY(()) tree saved_function_decls
;
62 static GTY(()) tree saved_parent_function_decls
;
64 static hash_set
<tree
> *nonlocal_dummy_decl_pset
;
65 static GTY(()) tree nonlocal_dummy_decls
;
67 /* Holds the variable DECLs that are locals. */
69 static GTY(()) tree saved_local_decls
;
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
74 static gfc_namespace
*module_namespace
;
76 /* The currently processed procedure symbol. */
77 static gfc_symbol
* current_procedure_symbol
= NULL
;
79 /* The currently processed module. */
80 static struct module_htab_entry
*cur_module
;
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
;
88 /* List of static constructor functions. */
90 tree gfc_static_ctors
;
93 /* Whether we've seen a symbol from an IEEE module in the namespace. */
94 static int seen_ieee_symbol
;
96 /* Function declarations for builtin library functions. */
98 tree gfor_fndecl_pause_numeric
;
99 tree gfor_fndecl_pause_string
;
100 tree gfor_fndecl_stop_numeric
;
101 tree gfor_fndecl_stop_numeric_f08
;
102 tree gfor_fndecl_stop_string
;
103 tree gfor_fndecl_error_stop_numeric
;
104 tree gfor_fndecl_error_stop_string
;
105 tree gfor_fndecl_runtime_error
;
106 tree gfor_fndecl_runtime_error_at
;
107 tree gfor_fndecl_runtime_warning_at
;
108 tree gfor_fndecl_os_error
;
109 tree gfor_fndecl_generate_error
;
110 tree gfor_fndecl_set_args
;
111 tree gfor_fndecl_set_fpe
;
112 tree gfor_fndecl_set_options
;
113 tree gfor_fndecl_set_convert
;
114 tree gfor_fndecl_set_record_marker
;
115 tree gfor_fndecl_set_max_subrecord_length
;
116 tree gfor_fndecl_ctime
;
117 tree gfor_fndecl_fdate
;
118 tree gfor_fndecl_ttynam
;
119 tree gfor_fndecl_in_pack
;
120 tree gfor_fndecl_in_unpack
;
121 tree gfor_fndecl_associated
;
122 tree gfor_fndecl_system_clock4
;
123 tree gfor_fndecl_system_clock8
;
124 tree gfor_fndecl_ieee_procedure_entry
;
125 tree gfor_fndecl_ieee_procedure_exit
;
128 /* Coarray run-time library function decls. */
129 tree gfor_fndecl_caf_init
;
130 tree gfor_fndecl_caf_finalize
;
131 tree gfor_fndecl_caf_this_image
;
132 tree gfor_fndecl_caf_num_images
;
133 tree gfor_fndecl_caf_register
;
134 tree gfor_fndecl_caf_deregister
;
135 tree gfor_fndecl_caf_get
;
136 tree gfor_fndecl_caf_send
;
137 tree gfor_fndecl_caf_sendget
;
138 tree gfor_fndecl_caf_sync_all
;
139 tree gfor_fndecl_caf_sync_memory
;
140 tree gfor_fndecl_caf_sync_images
;
141 tree gfor_fndecl_caf_stop_str
;
142 tree gfor_fndecl_caf_stop_numeric
;
143 tree gfor_fndecl_caf_error_stop
;
144 tree gfor_fndecl_caf_error_stop_str
;
145 tree gfor_fndecl_caf_atomic_def
;
146 tree gfor_fndecl_caf_atomic_ref
;
147 tree gfor_fndecl_caf_atomic_cas
;
148 tree gfor_fndecl_caf_atomic_op
;
149 tree gfor_fndecl_caf_lock
;
150 tree gfor_fndecl_caf_unlock
;
151 tree gfor_fndecl_caf_event_post
;
152 tree gfor_fndecl_caf_event_wait
;
153 tree gfor_fndecl_caf_event_query
;
154 tree gfor_fndecl_co_broadcast
;
155 tree gfor_fndecl_co_max
;
156 tree gfor_fndecl_co_min
;
157 tree gfor_fndecl_co_reduce
;
158 tree gfor_fndecl_co_sum
;
161 /* Math functions. Many other math functions are handled in
162 trans-intrinsic.c. */
164 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
165 tree gfor_fndecl_math_ishftc4
;
166 tree gfor_fndecl_math_ishftc8
;
167 tree gfor_fndecl_math_ishftc16
;
170 /* String functions. */
172 tree gfor_fndecl_compare_string
;
173 tree gfor_fndecl_concat_string
;
174 tree gfor_fndecl_string_len_trim
;
175 tree gfor_fndecl_string_index
;
176 tree gfor_fndecl_string_scan
;
177 tree gfor_fndecl_string_verify
;
178 tree gfor_fndecl_string_trim
;
179 tree gfor_fndecl_string_minmax
;
180 tree gfor_fndecl_adjustl
;
181 tree gfor_fndecl_adjustr
;
182 tree gfor_fndecl_select_string
;
183 tree gfor_fndecl_compare_string_char4
;
184 tree gfor_fndecl_concat_string_char4
;
185 tree gfor_fndecl_string_len_trim_char4
;
186 tree gfor_fndecl_string_index_char4
;
187 tree gfor_fndecl_string_scan_char4
;
188 tree gfor_fndecl_string_verify_char4
;
189 tree gfor_fndecl_string_trim_char4
;
190 tree gfor_fndecl_string_minmax_char4
;
191 tree gfor_fndecl_adjustl_char4
;
192 tree gfor_fndecl_adjustr_char4
;
193 tree gfor_fndecl_select_string_char4
;
196 /* Conversion between character kinds. */
197 tree gfor_fndecl_convert_char1_to_char4
;
198 tree gfor_fndecl_convert_char4_to_char1
;
201 /* Other misc. runtime library functions. */
202 tree gfor_fndecl_size0
;
203 tree gfor_fndecl_size1
;
204 tree gfor_fndecl_iargc
;
206 /* Intrinsic functions implemented in Fortran. */
207 tree gfor_fndecl_sc_kind
;
208 tree gfor_fndecl_si_kind
;
209 tree gfor_fndecl_sr_kind
;
211 /* BLAS gemm functions. */
212 tree gfor_fndecl_sgemm
;
213 tree gfor_fndecl_dgemm
;
214 tree gfor_fndecl_cgemm
;
215 tree gfor_fndecl_zgemm
;
219 gfc_add_decl_to_parent_function (tree decl
)
222 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
223 DECL_NONLOCAL (decl
) = 1;
224 DECL_CHAIN (decl
) = saved_parent_function_decls
;
225 saved_parent_function_decls
= decl
;
229 gfc_add_decl_to_function (tree decl
)
232 TREE_USED (decl
) = 1;
233 DECL_CONTEXT (decl
) = current_function_decl
;
234 DECL_CHAIN (decl
) = saved_function_decls
;
235 saved_function_decls
= decl
;
239 add_decl_as_local (tree decl
)
242 TREE_USED (decl
) = 1;
243 DECL_CONTEXT (decl
) = current_function_decl
;
244 DECL_CHAIN (decl
) = saved_local_decls
;
245 saved_local_decls
= decl
;
249 /* Build a backend label declaration. Set TREE_USED for named labels.
250 The context of the label is always the current_function_decl. All
251 labels are marked artificial. */
254 gfc_build_label_decl (tree label_id
)
256 /* 2^32 temporaries should be enough. */
257 static unsigned int tmp_num
= 1;
261 if (label_id
== NULL_TREE
)
263 /* Build an internal label name. */
264 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
265 label_id
= get_identifier (label_name
);
270 /* Build the LABEL_DECL node. Labels have no type. */
271 label_decl
= build_decl (input_location
,
272 LABEL_DECL
, label_id
, void_type_node
);
273 DECL_CONTEXT (label_decl
) = current_function_decl
;
274 DECL_MODE (label_decl
) = VOIDmode
;
276 /* We always define the label as used, even if the original source
277 file never references the label. We don't want all kinds of
278 spurious warnings for old-style Fortran code with too many
280 TREE_USED (label_decl
) = 1;
282 DECL_ARTIFICIAL (label_decl
) = 1;
287 /* Set the backend source location of a decl. */
290 gfc_set_decl_location (tree decl
, locus
* loc
)
292 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
296 /* Return the backend label declaration for a given label structure,
297 or create it if it doesn't exist yet. */
300 gfc_get_label_decl (gfc_st_label
* lp
)
302 if (lp
->backend_decl
)
303 return lp
->backend_decl
;
306 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
309 /* Validate the label declaration from the front end. */
310 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
312 /* Build a mangled name for the label. */
313 sprintf (label_name
, "__label_%.6d", lp
->value
);
315 /* Build the LABEL_DECL node. */
316 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
318 /* Tell the debugger where the label came from. */
319 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
320 gfc_set_decl_location (label_decl
, &lp
->where
);
322 DECL_ARTIFICIAL (label_decl
) = 1;
324 /* Store the label in the label list and return the LABEL_DECL. */
325 lp
->backend_decl
= label_decl
;
331 /* Convert a gfc_symbol to an identifier of the same name. */
334 gfc_sym_identifier (gfc_symbol
* sym
)
336 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
337 return (get_identifier ("MAIN__"));
339 return (get_identifier (sym
->name
));
343 /* Construct mangled name from symbol name. */
346 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
348 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
350 /* Prevent the mangling of identifiers that have an assigned
351 binding label (mainly those that are bind(c)). */
352 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
353 return get_identifier (sym
->binding_label
);
355 if (sym
->module
== NULL
)
356 return gfc_sym_identifier (sym
);
359 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
360 return get_identifier (name
);
365 /* Construct mangled function name from symbol name. */
368 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
371 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
373 /* It may be possible to simply use the binding label if it's
374 provided, and remove the other checks. Then we could use it
375 for other things if we wished. */
376 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
378 /* use the binding label rather than the mangled name */
379 return get_identifier (sym
->binding_label
);
381 if ((sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
382 || (sym
->module
!= NULL
&& (sym
->attr
.external
383 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
384 && !sym
->attr
.module_procedure
)
386 /* Main program is mangled into MAIN__. */
387 if (sym
->attr
.is_main_program
)
388 return get_identifier ("MAIN__");
390 /* Intrinsic procedures are never mangled. */
391 if (sym
->attr
.proc
== PROC_INTRINSIC
)
392 return get_identifier (sym
->name
);
394 if (flag_underscoring
)
396 has_underscore
= strchr (sym
->name
, '_') != 0;
397 if (flag_second_underscore
&& has_underscore
)
398 snprintf (name
, sizeof name
, "%s__", sym
->name
);
400 snprintf (name
, sizeof name
, "%s_", sym
->name
);
401 return get_identifier (name
);
404 return get_identifier (sym
->name
);
408 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
409 return get_identifier (name
);
415 gfc_set_decl_assembler_name (tree decl
, tree name
)
417 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
418 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
422 /* Returns true if a variable of specified size should go on the stack. */
425 gfc_can_put_var_on_stack (tree size
)
427 unsigned HOST_WIDE_INT low
;
429 if (!INTEGER_CST_P (size
))
432 if (flag_max_stack_var_size
< 0)
435 if (!tree_fits_uhwi_p (size
))
438 low
= TREE_INT_CST_LOW (size
);
439 if (low
> (unsigned HOST_WIDE_INT
) flag_max_stack_var_size
)
442 /* TODO: Set a per-function stack size limit. */
448 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
449 an expression involving its corresponding pointer. There are
450 2 cases; one for variable size arrays, and one for everything else,
451 because variable-sized arrays require one fewer level of
455 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
457 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
460 /* Parameters need to be dereferenced. */
461 if (sym
->cp_pointer
->attr
.dummy
)
462 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
465 /* Check to see if we're dealing with a variable-sized array. */
466 if (sym
->attr
.dimension
467 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
469 /* These decls will be dereferenced later, so we don't dereference
471 value
= convert (TREE_TYPE (decl
), ptr_decl
);
475 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
477 value
= build_fold_indirect_ref_loc (input_location
,
481 SET_DECL_VALUE_EXPR (decl
, value
);
482 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
483 GFC_DECL_CRAY_POINTEE (decl
) = 1;
487 /* Finish processing of a declaration without an initial value. */
490 gfc_finish_decl (tree decl
)
492 gcc_assert (TREE_CODE (decl
) == PARM_DECL
493 || DECL_INITIAL (decl
) == NULL_TREE
);
495 if (TREE_CODE (decl
) != VAR_DECL
)
498 if (DECL_SIZE (decl
) == NULL_TREE
499 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
500 layout_decl (decl
, 0);
502 /* A few consistency checks. */
503 /* A static variable with an incomplete type is an error if it is
504 initialized. Also if it is not file scope. Otherwise, let it
505 through, but if it is not `extern' then it may cause an error
507 /* An automatic variable with an incomplete type is an error. */
509 /* We should know the storage size. */
510 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
511 || (TREE_STATIC (decl
)
512 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
513 : DECL_EXTERNAL (decl
)));
515 /* The storage size should be constant. */
516 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
518 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
522 /* Handle setting of GFC_DECL_SCALAR* on DECL. */
525 gfc_finish_decl_attrs (tree decl
, symbol_attribute
*attr
)
527 if (!attr
->dimension
&& !attr
->codimension
)
529 /* Handle scalar allocatable variables. */
530 if (attr
->allocatable
)
532 gfc_allocate_lang_decl (decl
);
533 GFC_DECL_SCALAR_ALLOCATABLE (decl
) = 1;
535 /* Handle scalar pointer variables. */
538 gfc_allocate_lang_decl (decl
);
539 GFC_DECL_SCALAR_POINTER (decl
) = 1;
545 /* Apply symbol attributes to a variable, and add it to the function scope. */
548 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
552 /* Set DECL_VALUE_EXPR for Cray Pointees. */
553 if (sym
->attr
.cray_pointee
)
554 gfc_finish_cray_pointee (decl
, sym
);
556 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
557 This is the equivalent of the TARGET variables.
558 We also need to set this if the variable is passed by reference in a
560 if (sym
->attr
.target
)
561 TREE_ADDRESSABLE (decl
) = 1;
563 /* If it wasn't used we wouldn't be getting it. */
564 TREE_USED (decl
) = 1;
566 if (sym
->attr
.flavor
== FL_PARAMETER
567 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
568 TREE_READONLY (decl
) = 1;
570 /* Chain this decl to the pending declarations. Don't do pushdecl()
571 because this would add them to the current scope rather than the
573 if (current_function_decl
!= NULL_TREE
)
575 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
576 || sym
->result
== sym
)
577 gfc_add_decl_to_function (decl
);
578 else if (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
579 /* This is a BLOCK construct. */
580 add_decl_as_local (decl
);
582 gfc_add_decl_to_parent_function (decl
);
585 if (sym
->attr
.cray_pointee
)
588 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
590 /* We need to put variables that are bind(c) into the common
591 segment of the object file, because this is what C would do.
592 gfortran would typically put them in either the BSS or
593 initialized data segments, and only mark them as common if
594 they were part of common blocks. However, if they are not put
595 into common space, then C cannot initialize global Fortran
596 variables that it interoperates with and the draft says that
597 either Fortran or C should be able to initialize it (but not
598 both, of course.) (J3/04-007, section 15.3). */
599 TREE_PUBLIC(decl
) = 1;
600 DECL_COMMON(decl
) = 1;
601 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
603 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
604 DECL_VISIBILITY_SPECIFIED (decl
) = true;
608 /* If a variable is USE associated, it's always external. */
609 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
611 DECL_EXTERNAL (decl
) = 1;
612 TREE_PUBLIC (decl
) = 1;
614 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
616 /* TODO: Don't set sym->module for result or dummy variables. */
617 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
619 TREE_PUBLIC (decl
) = 1;
620 TREE_STATIC (decl
) = 1;
621 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
623 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
624 DECL_VISIBILITY_SPECIFIED (decl
) = true;
628 /* Derived types are a bit peculiar because of the possibility of
629 a default initializer; this must be applied each time the variable
630 comes into scope it therefore need not be static. These variables
631 are SAVE_NONE but have an initializer. Otherwise explicitly
632 initialized variables are SAVE_IMPLICIT and explicitly saved are
634 if (!sym
->attr
.use_assoc
635 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
636 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
637 || (flag_coarray
== GFC_FCOARRAY_LIB
638 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
639 TREE_STATIC (decl
) = 1;
641 if (sym
->attr
.volatile_
)
643 TREE_THIS_VOLATILE (decl
) = 1;
644 TREE_SIDE_EFFECTS (decl
) = 1;
645 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
646 TREE_TYPE (decl
) = new_type
;
649 /* Keep variables larger than max-stack-var-size off stack. */
650 if (!sym
->ns
->proc_name
->attr
.recursive
651 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
652 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
653 /* Put variable length auto array pointers always into stack. */
654 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
655 || sym
->attr
.dimension
== 0
656 || sym
->as
->type
!= AS_EXPLICIT
658 || sym
->attr
.allocatable
)
659 && !DECL_ARTIFICIAL (decl
))
660 TREE_STATIC (decl
) = 1;
662 /* Handle threadprivate variables. */
663 if (sym
->attr
.threadprivate
664 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
665 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
667 gfc_finish_decl_attrs (decl
, &sym
->attr
);
671 /* Allocate the lang-specific part of a decl. */
674 gfc_allocate_lang_decl (tree decl
)
676 if (DECL_LANG_SPECIFIC (decl
) == NULL
)
677 DECL_LANG_SPECIFIC (decl
) = ggc_cleared_alloc
<struct lang_decl
> ();
680 /* Remember a symbol to generate initialization/cleanup code at function
684 gfc_defer_symbol_init (gfc_symbol
* sym
)
690 /* Don't add a symbol twice. */
694 last
= head
= sym
->ns
->proc_name
;
697 /* Make sure that setup code for dummy variables which are used in the
698 setup of other variables is generated first. */
701 /* Find the first dummy arg seen after us, or the first non-dummy arg.
702 This is a circular list, so don't go past the head. */
704 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
710 /* Insert in between last and p. */
716 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
717 backend_decl for a module symbol, if it all ready exists. If the
718 module gsymbol does not exist, it is created. If the symbol does
719 not exist, it is added to the gsymbol namespace. Returns true if
720 an existing backend_decl is found. */
723 gfc_get_module_backend_decl (gfc_symbol
*sym
)
729 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
731 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
736 /* Check for a symbol with the same name. */
738 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
744 gsym
= gfc_get_gsymbol (sym
->module
);
745 gsym
->type
= GSYM_MODULE
;
746 gsym
->ns
= gfc_get_namespace (NULL
, 0);
749 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
753 else if (gfc_fl_struct (sym
->attr
.flavor
))
755 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
758 gcc_assert (s
->attr
.generic
);
759 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
760 if (gfc_fl_struct (intr
->sym
->attr
.flavor
))
767 /* Normally we can assume that s is a derived-type symbol since it
768 shares a name with the derived-type sym. However if sym is a
769 STRUCTURE, it may in fact share a name with any other basic type
770 variable. If s is in fact of derived type then we can continue
771 looking for a duplicate type declaration. */
772 if (sym
->attr
.flavor
== FL_STRUCT
&& s
->ts
.type
== BT_DERIVED
)
777 if (gfc_fl_struct (s
->attr
.flavor
) && !s
->backend_decl
)
779 if (s
->attr
.flavor
== FL_UNION
)
780 s
->backend_decl
= gfc_get_union_type (s
);
782 s
->backend_decl
= gfc_get_derived_type (s
);
784 gfc_copy_dt_decls_ifequal (s
, sym
, true);
787 else if (s
->backend_decl
)
789 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
790 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
792 else if (sym
->ts
.type
== BT_CHARACTER
)
793 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
794 sym
->backend_decl
= s
->backend_decl
;
802 /* Create an array index type variable with function scope. */
805 create_index_var (const char * pfx
, int nest
)
809 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
811 gfc_add_decl_to_parent_function (decl
);
813 gfc_add_decl_to_function (decl
);
818 /* Create variables to hold all the non-constant bits of info for a
819 descriptorless array. Remember these in the lang-specific part of the
823 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
828 gfc_namespace
* procns
;
829 symbol_attribute
*array_attr
;
831 bool is_classarray
= IS_CLASS_ARRAY (sym
);
833 type
= TREE_TYPE (decl
);
834 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
835 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
837 /* We just use the descriptor, if there is one. */
838 if (GFC_DESCRIPTOR_TYPE_P (type
))
841 gcc_assert (GFC_ARRAY_TYPE_P (type
));
842 procns
= gfc_find_proc_namespace (sym
->ns
);
843 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
844 && !sym
->attr
.contained
;
846 if (array_attr
->codimension
&& flag_coarray
== GFC_FCOARRAY_LIB
847 && as
->type
!= AS_ASSUMED_SHAPE
848 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
851 tree token_type
= build_qualified_type (pvoid_type_node
,
854 if (sym
->module
&& (sym
->attr
.use_assoc
855 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
858 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"),
859 IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym
))));
860 token
= build_decl (DECL_SOURCE_LOCATION (decl
), VAR_DECL
, token_name
,
862 if (sym
->attr
.use_assoc
)
863 DECL_EXTERNAL (token
) = 1;
865 TREE_STATIC (token
) = 1;
867 TREE_PUBLIC (token
) = 1;
869 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
871 DECL_VISIBILITY (token
) = VISIBILITY_HIDDEN
;
872 DECL_VISIBILITY_SPECIFIED (token
) = true;
877 token
= gfc_create_var_np (token_type
, "caf_token");
878 TREE_STATIC (token
) = 1;
881 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
882 DECL_ARTIFICIAL (token
) = 1;
883 DECL_NONALIASED (token
) = 1;
885 if (sym
->module
&& !sym
->attr
.use_assoc
)
888 DECL_CONTEXT (token
) = sym
->ns
->proc_name
->backend_decl
;
889 gfc_module_add_decl (cur_module
, token
);
892 gfc_add_decl_to_function (token
);
895 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
897 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
899 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
900 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
902 /* Don't try to use the unknown bound for assumed shape arrays. */
903 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
904 && (as
->type
!= AS_ASSUMED_SIZE
905 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
907 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
908 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
911 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
913 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
914 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
917 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
918 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
920 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
922 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
923 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
925 /* Don't try to use the unknown ubound for the last coarray dimension. */
926 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
927 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
929 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
930 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
933 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
935 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
937 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
940 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
942 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
945 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
946 && as
->type
!= AS_ASSUMED_SIZE
)
948 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
949 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
952 if (POINTER_TYPE_P (type
))
954 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
955 gcc_assert (TYPE_LANG_SPECIFIC (type
)
956 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
957 type
= TREE_TYPE (type
);
960 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
964 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
965 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
966 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
968 TYPE_DOMAIN (type
) = range
;
972 if (TYPE_NAME (type
) != NULL_TREE
973 && GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1) != NULL_TREE
974 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type
, as
->rank
- 1)) == VAR_DECL
)
976 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
978 for (dim
= 0; dim
< as
->rank
- 1; dim
++)
980 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
981 gtype
= TREE_TYPE (gtype
);
983 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
984 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
985 TYPE_NAME (type
) = NULL_TREE
;
988 if (TYPE_NAME (type
) == NULL_TREE
)
990 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
992 for (dim
= as
->rank
- 1; dim
>= 0; dim
--)
995 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
996 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
997 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
998 gtype
= build_array_type (gtype
, rtype
);
999 /* Ensure the bound variables aren't optimized out at -O0.
1000 For -O1 and above they often will be optimized out, but
1001 can be tracked by VTA. Also set DECL_NAMELESS, so that
1002 the artificial lbound.N or ubound.N DECL_NAME doesn't
1003 end up in debug info. */
1004 if (lbound
&& TREE_CODE (lbound
) == VAR_DECL
1005 && DECL_ARTIFICIAL (lbound
) && DECL_IGNORED_P (lbound
))
1007 if (DECL_NAME (lbound
)
1008 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
1010 DECL_NAMELESS (lbound
) = 1;
1011 DECL_IGNORED_P (lbound
) = 0;
1013 if (ubound
&& TREE_CODE (ubound
) == VAR_DECL
1014 && DECL_ARTIFICIAL (ubound
) && DECL_IGNORED_P (ubound
))
1016 if (DECL_NAME (ubound
)
1017 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
1019 DECL_NAMELESS (ubound
) = 1;
1020 DECL_IGNORED_P (ubound
) = 0;
1023 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
1024 TYPE_DECL
, NULL
, gtype
);
1025 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
1030 /* For some dummy arguments we don't use the actual argument directly.
1031 Instead we create a local decl and use that. This allows us to perform
1032 initialization, and construct full type information. */
1035 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
1040 symbol_attribute
*array_attr
;
1045 bool is_classarray
= IS_CLASS_ARRAY (sym
);
1047 /* Use the array as and attr. */
1048 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
1049 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
1051 /* The dummy is returned for pointer, allocatable or assumed rank arrays.
1052 For class arrays the information if sym is an allocatable or pointer
1053 object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
1054 too many reasons to be of use here). */
1055 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
1056 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
)
1057 || array_attr
->allocatable
1058 || (as
&& as
->type
== AS_ASSUMED_RANK
))
1061 /* Add to list of variables if not a fake result variable.
1062 These symbols are set on the symbol only, not on the class component. */
1063 if (sym
->attr
.result
|| sym
->attr
.dummy
)
1064 gfc_defer_symbol_init (sym
);
1066 /* For a class array the array descriptor is in the _data component, while
1067 for a regular array the TREE_TYPE of the dummy is a pointer to the
1069 type
= TREE_TYPE (is_classarray
? gfc_class_data_get (dummy
)
1070 : TREE_TYPE (dummy
));
1071 /* type now is the array descriptor w/o any indirection. */
1072 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
1073 && POINTER_TYPE_P (TREE_TYPE (dummy
)));
1075 /* Do we know the element size? */
1076 known_size
= sym
->ts
.type
!= BT_CHARACTER
1077 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
1079 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (type
))
1081 /* For descriptorless arrays with known element size the actual
1082 argument is sufficient. */
1083 gfc_build_qualified_array (dummy
, sym
);
1087 if (GFC_DESCRIPTOR_TYPE_P (type
))
1089 /* Create a descriptorless array pointer. */
1092 /* Even when -frepack-arrays is used, symbols with TARGET attribute
1093 are not repacked. */
1094 if (!flag_repack_arrays
|| sym
->attr
.target
)
1096 if (as
->type
== AS_ASSUMED_SIZE
)
1097 packed
= PACKED_FULL
;
1101 if (as
->type
== AS_EXPLICIT
)
1103 packed
= PACKED_FULL
;
1104 for (n
= 0; n
< as
->rank
; n
++)
1108 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
1109 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
1111 packed
= PACKED_PARTIAL
;
1117 packed
= PACKED_PARTIAL
;
1120 /* For classarrays the element type is required, but
1121 gfc_typenode_for_spec () returns the array descriptor. */
1122 type
= is_classarray
? gfc_get_element_type (type
)
1123 : gfc_typenode_for_spec (&sym
->ts
);
1124 type
= gfc_get_nodesc_array_type (type
, as
, packed
,
1129 /* We now have an expression for the element size, so create a fully
1130 qualified type. Reset sym->backend decl or this will just return the
1132 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1133 sym
->backend_decl
= NULL_TREE
;
1134 type
= gfc_sym_type (sym
);
1135 packed
= PACKED_FULL
;
1138 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1139 decl
= build_decl (input_location
,
1140 VAR_DECL
, get_identifier (name
), type
);
1142 DECL_ARTIFICIAL (decl
) = 1;
1143 DECL_NAMELESS (decl
) = 1;
1144 TREE_PUBLIC (decl
) = 0;
1145 TREE_STATIC (decl
) = 0;
1146 DECL_EXTERNAL (decl
) = 0;
1148 /* Avoid uninitialized warnings for optional dummy arguments. */
1149 if (sym
->attr
.optional
)
1150 TREE_NO_WARNING (decl
) = 1;
1152 /* We should never get deferred shape arrays here. We used to because of
1154 gcc_assert (as
->type
!= AS_DEFERRED
);
1156 if (packed
== PACKED_PARTIAL
)
1157 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
1158 else if (packed
== PACKED_FULL
)
1159 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1161 gfc_build_qualified_array (decl
, sym
);
1163 if (DECL_LANG_SPECIFIC (dummy
))
1164 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
1166 gfc_allocate_lang_decl (decl
);
1168 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
1170 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1171 || sym
->attr
.contained
)
1172 gfc_add_decl_to_function (decl
);
1174 gfc_add_decl_to_parent_function (decl
);
1179 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1180 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1181 pointing to the artificial variable for debug info purposes. */
1184 gfc_nonlocal_dummy_array_decl (gfc_symbol
*sym
)
1188 if (! nonlocal_dummy_decl_pset
)
1189 nonlocal_dummy_decl_pset
= new hash_set
<tree
>;
1191 if (nonlocal_dummy_decl_pset
->add (sym
->backend_decl
))
1194 dummy
= GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
);
1195 decl
= build_decl (input_location
, VAR_DECL
, DECL_NAME (dummy
),
1196 TREE_TYPE (sym
->backend_decl
));
1197 DECL_ARTIFICIAL (decl
) = 0;
1198 TREE_USED (decl
) = 1;
1199 TREE_PUBLIC (decl
) = 0;
1200 TREE_STATIC (decl
) = 0;
1201 DECL_EXTERNAL (decl
) = 0;
1202 if (DECL_BY_REFERENCE (dummy
))
1203 DECL_BY_REFERENCE (decl
) = 1;
1204 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (sym
->backend_decl
);
1205 SET_DECL_VALUE_EXPR (decl
, sym
->backend_decl
);
1206 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
1207 DECL_CONTEXT (decl
) = DECL_CONTEXT (sym
->backend_decl
);
1208 DECL_CHAIN (decl
) = nonlocal_dummy_decls
;
1209 nonlocal_dummy_decls
= decl
;
1212 /* Return a constant or a variable to use as a string length. Does not
1213 add the decl to the current scope. */
1216 gfc_create_string_length (gfc_symbol
* sym
)
1218 gcc_assert (sym
->ts
.u
.cl
);
1219 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
1221 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1226 /* The string length variable shall be in static memory if it is either
1227 explicitly SAVED, a module variable or with -fno-automatic. Only
1228 relevant is "len=:" - otherwise, it is either a constant length or
1229 it is an automatic variable. */
1230 bool static_length
= sym
->attr
.save
1231 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1232 || (flag_max_stack_var_size
== 0
1233 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1234 && !sym
->attr
.result
&& !sym
->attr
.function
);
1236 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1237 variables as some systems do not support the "." in the assembler name.
1238 For nonstatic variables, the "." does not appear in assembler. */
1242 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1245 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1247 else if (sym
->module
)
1248 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1250 name
= gfc_get_string (".%s", sym
->name
);
1252 length
= build_decl (input_location
,
1253 VAR_DECL
, get_identifier (name
),
1254 gfc_charlen_type_node
);
1255 DECL_ARTIFICIAL (length
) = 1;
1256 TREE_USED (length
) = 1;
1257 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1258 gfc_defer_symbol_init (sym
);
1260 sym
->ts
.u
.cl
->backend_decl
= length
;
1263 TREE_STATIC (length
) = 1;
1265 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1266 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1267 TREE_PUBLIC (length
) = 1;
1270 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1271 return sym
->ts
.u
.cl
->backend_decl
;
1274 /* If a variable is assigned a label, we add another two auxiliary
1278 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1284 gcc_assert (sym
->backend_decl
);
1286 decl
= sym
->backend_decl
;
1287 gfc_allocate_lang_decl (decl
);
1288 GFC_DECL_ASSIGN (decl
) = 1;
1289 length
= build_decl (input_location
,
1290 VAR_DECL
, create_tmp_var_name (sym
->name
),
1291 gfc_charlen_type_node
);
1292 addr
= build_decl (input_location
,
1293 VAR_DECL
, create_tmp_var_name (sym
->name
),
1295 gfc_finish_var_decl (length
, sym
);
1296 gfc_finish_var_decl (addr
, sym
);
1297 /* STRING_LENGTH is also used as flag. Less than -1 means that
1298 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1299 target label's address. Otherwise, value is the length of a format string
1300 and ASSIGN_ADDR is its address. */
1301 if (TREE_STATIC (length
))
1302 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1304 gfc_defer_symbol_init (sym
);
1306 GFC_DECL_STRING_LEN (decl
) = length
;
1307 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1312 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1317 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1318 if (sym_attr
.ext_attr
& (1 << id
))
1320 attr
= build_tree_list (
1321 get_identifier (ext_attr_list
[id
].middle_end_name
),
1323 list
= chainon (list
, attr
);
1326 if (sym_attr
.omp_declare_target
)
1327 list
= tree_cons (get_identifier ("omp declare target"),
1330 if (sym_attr
.oacc_function
)
1332 tree dims
= NULL_TREE
;
1334 int level
= sym_attr
.oacc_function
- 1;
1336 for (ix
= GOMP_DIM_MAX
; ix
--;)
1337 dims
= tree_cons (build_int_cst (boolean_type_node
, ix
>= level
),
1338 integer_zero_node
, dims
);
1340 list
= tree_cons (get_identifier ("oacc function"),
1348 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1351 /* Return the decl for a gfc_symbol, create it if it doesn't already
1355 gfc_get_symbol_decl (gfc_symbol
* sym
)
1358 tree length
= NULL_TREE
;
1361 bool intrinsic_array_parameter
= false;
1364 gcc_assert (sym
->attr
.referenced
1365 || sym
->attr
.flavor
== FL_PROCEDURE
1366 || sym
->attr
.use_assoc
1367 || sym
->attr
.used_in_submodule
1368 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1369 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1370 && sym
->backend_decl
));
1372 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1373 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1377 /* Make sure that the vtab for the declared type is completed. */
1378 if (sym
->ts
.type
== BT_CLASS
)
1380 gfc_component
*c
= CLASS_DATA (sym
);
1381 if (!c
->ts
.u
.derived
->backend_decl
)
1383 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1384 gfc_get_derived_type (sym
->ts
.u
.derived
);
1388 /* All deferred character length procedures need to retain the backend
1389 decl, which is a pointer to the character length in the caller's
1390 namespace and to declare a local character length. */
1391 if (!byref
&& sym
->attr
.function
1392 && sym
->ts
.type
== BT_CHARACTER
1394 && sym
->ts
.u
.cl
->passed_length
== NULL
1395 && sym
->ts
.u
.cl
->backend_decl
1396 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1398 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1399 gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)));
1400 sym
->ts
.u
.cl
->backend_decl
= build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1403 fun_or_res
= byref
&& (sym
->attr
.result
1404 || (sym
->attr
.function
&& sym
->ts
.deferred
));
1405 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || fun_or_res
)
1407 /* Return via extra parameter. */
1408 if (sym
->attr
.result
&& byref
1409 && !sym
->backend_decl
)
1412 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1413 /* For entry master function skip over the __entry
1415 if (sym
->ns
->proc_name
->attr
.entry_master
)
1416 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1419 /* Dummy variables should already have been created. */
1420 gcc_assert (sym
->backend_decl
);
1422 /* Create a character length variable. */
1423 if (sym
->ts
.type
== BT_CHARACTER
)
1425 /* For a deferred dummy, make a new string length variable. */
1426 if (sym
->ts
.deferred
1428 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1429 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1431 if (sym
->ts
.deferred
&& byref
)
1433 /* The string length of a deferred char array is stored in the
1434 parameter at sym->ts.u.cl->backend_decl as a reference and
1435 marked as a result. Exempt this variable from generating a
1436 temporary for it. */
1437 if (sym
->attr
.result
)
1439 /* We need to insert a indirect ref for param decls. */
1440 if (sym
->ts
.u
.cl
->backend_decl
1441 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1443 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1444 sym
->ts
.u
.cl
->backend_decl
=
1445 build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1448 /* For all other parameters make sure, that they are copied so
1449 that the value and any modifications are local to the routine
1450 by generating a temporary variable. */
1451 else if (sym
->attr
.function
1452 && sym
->ts
.u
.cl
->passed_length
== NULL
1453 && sym
->ts
.u
.cl
->backend_decl
)
1455 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1456 if (POINTER_TYPE_P (TREE_TYPE (sym
->ts
.u
.cl
->passed_length
)))
1457 sym
->ts
.u
.cl
->backend_decl
1458 = build_fold_indirect_ref (sym
->ts
.u
.cl
->backend_decl
);
1460 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1464 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1465 length
= gfc_create_string_length (sym
);
1467 length
= sym
->ts
.u
.cl
->backend_decl
;
1468 if (TREE_CODE (length
) == VAR_DECL
1469 && DECL_FILE_SCOPE_P (length
))
1471 /* Add the string length to the same context as the symbol. */
1472 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1473 gfc_add_decl_to_function (length
);
1475 gfc_add_decl_to_parent_function (length
);
1477 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1478 DECL_CONTEXT (length
));
1480 gfc_defer_symbol_init (sym
);
1484 /* Use a copy of the descriptor for dummy arrays. */
1485 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1486 && !TREE_USED (sym
->backend_decl
))
1488 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1489 /* Prevent the dummy from being detected as unused if it is copied. */
1490 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1491 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1492 sym
->backend_decl
= decl
;
1495 /* Returning the descriptor for dummy class arrays is hazardous, because
1496 some caller is expecting an expression to apply the component refs to.
1497 Therefore the descriptor is only created and stored in
1498 sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
1499 responsible to extract it from there, when the descriptor is
1501 if (IS_CLASS_ARRAY (sym
)
1502 && (!DECL_LANG_SPECIFIC (sym
->backend_decl
)
1503 || !GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)))
1505 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1506 /* Prevent the dummy from being detected as unused if it is copied. */
1507 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1508 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1509 sym
->backend_decl
= decl
;
1512 TREE_USED (sym
->backend_decl
) = 1;
1513 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1515 gfc_add_assign_aux_vars (sym
);
1518 if ((sym
->attr
.dimension
|| IS_CLASS_ARRAY (sym
))
1519 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1520 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1521 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1522 gfc_nonlocal_dummy_array_decl (sym
);
1524 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1525 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1527 return sym
->backend_decl
;
1530 if (sym
->backend_decl
)
1531 return sym
->backend_decl
;
1533 /* Special case for array-valued named constants from intrinsic
1534 procedures; those are inlined. */
1535 if (sym
->attr
.use_assoc
&& sym
->attr
.flavor
== FL_PARAMETER
1536 && (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
1537 || sym
->from_intmod
== INTMOD_ISO_C_BINDING
))
1538 intrinsic_array_parameter
= true;
1540 /* If use associated compilation, use the module
1542 if ((sym
->attr
.flavor
== FL_VARIABLE
1543 || sym
->attr
.flavor
== FL_PARAMETER
)
1544 && (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
)
1545 && !intrinsic_array_parameter
1547 && gfc_get_module_backend_decl (sym
))
1549 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1550 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1551 return sym
->backend_decl
;
1554 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1556 /* Catch functions. Only used for actual parameters,
1557 procedure pointers and procptr initialization targets. */
1558 if (sym
->attr
.use_assoc
|| sym
->attr
.intrinsic
1559 || sym
->attr
.if_source
!= IFSRC_DECL
)
1561 decl
= gfc_get_extern_function_decl (sym
);
1562 gfc_set_decl_location (decl
, &sym
->declared_at
);
1566 if (!sym
->backend_decl
)
1567 build_function_decl (sym
, false);
1568 decl
= sym
->backend_decl
;
1573 if (sym
->attr
.intrinsic
)
1574 gfc_internal_error ("intrinsic variable which isn't a procedure");
1576 /* Create string length decl first so that they can be used in the
1577 type declaration. For associate names, the target character
1578 length is used. Set 'length' to a constant so that if the
1579 string lenght is a variable, it is not finished a second time. */
1580 if (sym
->ts
.type
== BT_CHARACTER
)
1582 if (sym
->attr
.associate_var
1583 && sym
->ts
.u
.cl
->backend_decl
1584 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
1585 length
= gfc_index_zero_node
;
1587 length
= gfc_create_string_length (sym
);
1590 /* Create the decl for the variable. */
1591 decl
= build_decl (sym
->declared_at
.lb
->location
,
1592 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1594 /* Add attributes to variables. Functions are handled elsewhere. */
1595 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1596 decl_attributes (&decl
, attributes
, 0);
1598 /* Symbols from modules should have their assembler names mangled.
1599 This is done here rather than in gfc_finish_var_decl because it
1600 is different for string length variables. */
1603 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1604 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1605 DECL_IGNORED_P (decl
) = 1;
1608 if (sym
->attr
.select_type_temporary
)
1610 DECL_ARTIFICIAL (decl
) = 1;
1611 DECL_IGNORED_P (decl
) = 1;
1614 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1616 /* Create variables to hold the non-constant bits of array info. */
1617 gfc_build_qualified_array (decl
, sym
);
1619 if (sym
->attr
.contiguous
1620 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1621 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1624 /* Remember this variable for allocation/cleanup. */
1625 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1626 || (sym
->ts
.type
== BT_CLASS
&&
1627 (CLASS_DATA (sym
)->attr
.dimension
1628 || CLASS_DATA (sym
)->attr
.allocatable
))
1629 || (sym
->ts
.type
== BT_DERIVED
1630 && (sym
->ts
.u
.derived
->attr
.alloc_comp
1631 || (!sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
1632 && !sym
->ns
->proc_name
->attr
.is_main_program
1633 && gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
))))
1634 /* This applies a derived type default initializer. */
1635 || (sym
->ts
.type
== BT_DERIVED
1636 && sym
->attr
.save
== SAVE_NONE
1638 && !sym
->attr
.allocatable
1639 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1640 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1641 gfc_defer_symbol_init (sym
);
1643 gfc_finish_var_decl (decl
, sym
);
1645 if (sym
->ts
.type
== BT_CHARACTER
)
1647 /* Character variables need special handling. */
1648 gfc_allocate_lang_decl (decl
);
1650 /* Associate names can use the hidden string length variable
1651 of their associated target. */
1652 if (TREE_CODE (length
) != INTEGER_CST
)
1654 gfc_finish_var_decl (length
, sym
);
1655 gcc_assert (!sym
->value
);
1658 else if (sym
->attr
.subref_array_pointer
)
1660 /* We need the span for these beasts. */
1661 gfc_allocate_lang_decl (decl
);
1664 if (sym
->attr
.subref_array_pointer
)
1667 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1668 span
= build_decl (input_location
,
1669 VAR_DECL
, create_tmp_var_name ("span"),
1670 gfc_array_index_type
);
1671 gfc_finish_var_decl (span
, sym
);
1672 TREE_STATIC (span
) = TREE_STATIC (decl
);
1673 DECL_ARTIFICIAL (span
) = 1;
1675 GFC_DECL_SPAN (decl
) = span
;
1676 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1679 if (sym
->ts
.type
== BT_CLASS
)
1680 GFC_DECL_CLASS(decl
) = 1;
1682 sym
->backend_decl
= decl
;
1684 if (sym
->attr
.assign
)
1685 gfc_add_assign_aux_vars (sym
);
1687 if (intrinsic_array_parameter
)
1689 TREE_STATIC (decl
) = 1;
1690 DECL_EXTERNAL (decl
) = 0;
1693 if (TREE_STATIC (decl
)
1694 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1695 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1696 || flag_max_stack_var_size
== 0
1697 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1698 && (flag_coarray
!= GFC_FCOARRAY_LIB
1699 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
))
1701 /* Add static initializer. For procedures, it is only needed if
1702 SAVE is specified otherwise they need to be reinitialized
1703 every time the procedure is entered. The TREE_STATIC is
1704 in this case due to -fmax-stack-var-size=. */
1706 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1707 TREE_TYPE (decl
), sym
->attr
.dimension
1708 || (sym
->attr
.codimension
1709 && sym
->attr
.allocatable
),
1710 sym
->attr
.pointer
|| sym
->attr
.allocatable
1711 || sym
->ts
.type
== BT_CLASS
,
1712 sym
->attr
.proc_pointer
);
1715 if (!TREE_STATIC (decl
)
1716 && POINTER_TYPE_P (TREE_TYPE (decl
))
1717 && !sym
->attr
.pointer
1718 && !sym
->attr
.allocatable
1719 && !sym
->attr
.proc_pointer
1720 && !sym
->attr
.select_type_temporary
)
1721 DECL_BY_REFERENCE (decl
) = 1;
1723 if (sym
->attr
.associate_var
)
1724 GFC_DECL_ASSOCIATE_VAR_P (decl
) = 1;
1727 || (sym
->name
[0] == '_' && strncmp ("__def_init", sym
->name
, 10) == 0))
1728 TREE_READONLY (decl
) = 1;
1734 /* Substitute a temporary variable in place of the real one. */
1737 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1739 save
->attr
= sym
->attr
;
1740 save
->decl
= sym
->backend_decl
;
1742 gfc_clear_attr (&sym
->attr
);
1743 sym
->attr
.referenced
= 1;
1744 sym
->attr
.flavor
= FL_VARIABLE
;
1746 sym
->backend_decl
= decl
;
1750 /* Restore the original variable. */
1753 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1755 sym
->attr
= save
->attr
;
1756 sym
->backend_decl
= save
->decl
;
1760 /* Declare a procedure pointer. */
1763 get_proc_pointer_decl (gfc_symbol
*sym
)
1768 decl
= sym
->backend_decl
;
1772 decl
= build_decl (input_location
,
1773 VAR_DECL
, get_identifier (sym
->name
),
1774 build_pointer_type (gfc_get_function_type (sym
)));
1778 /* Apply name mangling. */
1779 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1780 if (sym
->attr
.use_assoc
)
1781 DECL_IGNORED_P (decl
) = 1;
1784 if ((sym
->ns
->proc_name
1785 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1786 || sym
->attr
.contained
)
1787 gfc_add_decl_to_function (decl
);
1788 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1789 gfc_add_decl_to_parent_function (decl
);
1791 sym
->backend_decl
= decl
;
1793 /* If a variable is USE associated, it's always external. */
1794 if (sym
->attr
.use_assoc
)
1796 DECL_EXTERNAL (decl
) = 1;
1797 TREE_PUBLIC (decl
) = 1;
1799 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1801 /* This is the declaration of a module variable. */
1802 TREE_PUBLIC (decl
) = 1;
1803 if (sym
->attr
.access
== ACCESS_PRIVATE
&& !sym
->attr
.public_used
)
1805 DECL_VISIBILITY (decl
) = VISIBILITY_HIDDEN
;
1806 DECL_VISIBILITY_SPECIFIED (decl
) = true;
1808 TREE_STATIC (decl
) = 1;
1811 if (!sym
->attr
.use_assoc
1812 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1813 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1814 TREE_STATIC (decl
) = 1;
1816 if (TREE_STATIC (decl
) && sym
->value
)
1818 /* Add static initializer. */
1819 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1821 sym
->attr
.dimension
,
1825 /* Handle threadprivate procedure pointers. */
1826 if (sym
->attr
.threadprivate
1827 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
1828 set_decl_tls_model (decl
, decl_default_tls_model (decl
));
1830 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1831 decl_attributes (&decl
, attributes
, 0);
1837 /* Get a basic decl for an external function. */
1840 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1846 gfc_intrinsic_sym
*isym
;
1848 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1853 if (sym
->backend_decl
)
1854 return sym
->backend_decl
;
1856 /* We should never be creating external decls for alternate entry points.
1857 The procedure may be an alternate entry point, but we don't want/need
1859 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1861 if (sym
->attr
.proc_pointer
)
1862 return get_proc_pointer_decl (sym
);
1864 /* See if this is an external procedure from the same file. If so,
1865 return the backend_decl. */
1866 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
1867 ? sym
->binding_label
: sym
->name
);
1869 if (gsym
&& !gsym
->defined
)
1872 /* This can happen because of C binding. */
1873 if (gsym
&& gsym
->ns
&& gsym
->ns
->proc_name
1874 && gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1877 if ((!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
1878 && !sym
->backend_decl
1880 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1881 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
1883 if (!gsym
->ns
->proc_name
->backend_decl
)
1885 /* By construction, the external function cannot be
1886 a contained procedure. */
1889 gfc_save_backend_locus (&old_loc
);
1892 gfc_create_function_decl (gsym
->ns
, true);
1895 gfc_restore_backend_locus (&old_loc
);
1898 /* If the namespace has entries, the proc_name is the
1899 entry master. Find the entry and use its backend_decl.
1900 otherwise, use the proc_name backend_decl. */
1901 if (gsym
->ns
->entries
)
1903 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1905 for (; entry
; entry
= entry
->next
)
1907 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1909 sym
->backend_decl
= entry
->sym
->backend_decl
;
1915 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1917 if (sym
->backend_decl
)
1919 /* Avoid problems of double deallocation of the backend declaration
1920 later in gfc_trans_use_stmts; cf. PR 45087. */
1921 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
1922 sym
->attr
.use_assoc
= 0;
1924 return sym
->backend_decl
;
1928 /* See if this is a module procedure from the same file. If so,
1929 return the backend_decl. */
1931 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1934 if (gsym
&& gsym
->ns
1935 && (gsym
->type
== GSYM_MODULE
1936 || (gsym
->ns
->proc_name
&& gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
1941 if (gsym
->type
== GSYM_MODULE
)
1942 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1944 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &s
);
1946 if (s
&& s
->backend_decl
)
1948 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1949 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
1951 else if (sym
->ts
.type
== BT_CHARACTER
)
1952 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1953 sym
->backend_decl
= s
->backend_decl
;
1954 return sym
->backend_decl
;
1958 if (sym
->attr
.intrinsic
)
1960 /* Call the resolution function to get the actual name. This is
1961 a nasty hack which relies on the resolution functions only looking
1962 at the first argument. We pass NULL for the second argument
1963 otherwise things like AINT get confused. */
1964 isym
= gfc_find_function (sym
->name
);
1965 gcc_assert (isym
->resolve
.f0
!= NULL
);
1967 memset (&e
, 0, sizeof (e
));
1968 e
.expr_type
= EXPR_FUNCTION
;
1970 memset (&argexpr
, 0, sizeof (argexpr
));
1971 gcc_assert (isym
->formal
);
1972 argexpr
.ts
= isym
->formal
->ts
;
1974 if (isym
->formal
->next
== NULL
)
1975 isym
->resolve
.f1 (&e
, &argexpr
);
1978 if (isym
->formal
->next
->next
== NULL
)
1979 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1982 if (isym
->formal
->next
->next
->next
== NULL
)
1983 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1986 /* All specific intrinsics take less than 5 arguments. */
1987 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1988 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1994 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1995 || e
.ts
.type
== BT_COMPLEX
))
1997 /* Specific which needs a different implementation if f2c
1998 calling conventions are used. */
1999 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
2002 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
2004 name
= get_identifier (s
);
2005 mangled_name
= name
;
2009 name
= gfc_sym_identifier (sym
);
2010 mangled_name
= gfc_sym_mangled_function_id (sym
);
2013 type
= gfc_get_function_type (sym
);
2014 fndecl
= build_decl (input_location
,
2015 FUNCTION_DECL
, name
, type
);
2017 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2018 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2019 the opposite of declaring a function as static in C). */
2020 DECL_EXTERNAL (fndecl
) = 1;
2021 TREE_PUBLIC (fndecl
) = 1;
2023 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
2024 decl_attributes (&fndecl
, attributes
, 0);
2026 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
2028 /* Set the context of this decl. */
2029 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
2031 /* TODO: Add external decls to the appropriate scope. */
2032 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
2036 /* Global declaration, e.g. intrinsic subroutine. */
2037 DECL_CONTEXT (fndecl
) = NULL_TREE
;
2040 /* Set attributes for PURE functions. A call to PURE function in the
2041 Fortran 95 sense is both pure and without side effects in the C
2043 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
2045 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
2046 DECL_PURE_P (fndecl
) = 1;
2047 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
2048 parameters and don't use alternate returns (is this
2049 allowed?). In that case, calls to them are meaningless, and
2050 can be optimized away. See also in build_function_decl(). */
2051 TREE_SIDE_EFFECTS (fndecl
) = 0;
2054 /* Mark non-returning functions. */
2055 if (sym
->attr
.noreturn
)
2056 TREE_THIS_VOLATILE(fndecl
) = 1;
2058 sym
->backend_decl
= fndecl
;
2060 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
2061 pushdecl_top_level (fndecl
);
2064 && sym
->formal_ns
->proc_name
== sym
2065 && sym
->formal_ns
->omp_declare_simd
)
2066 gfc_trans_omp_declare_simd (sym
->formal_ns
);
2072 /* Create a declaration for a procedure. For external functions (in the C
2073 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
2074 a master function with alternate entry points. */
2077 build_function_decl (gfc_symbol
* sym
, bool global
)
2079 tree fndecl
, type
, attributes
;
2080 symbol_attribute attr
;
2082 gfc_formal_arglist
*f
;
2084 bool module_procedure
= sym
->attr
.module_procedure
2086 && sym
->ns
->proc_name
2087 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
;
2089 gcc_assert (!sym
->attr
.external
|| module_procedure
);
2091 if (sym
->backend_decl
)
2094 /* Set the line and filename. sym->declared_at seems to point to the
2095 last statement for subroutines, but it'll do for now. */
2096 gfc_set_backend_locus (&sym
->declared_at
);
2098 /* Allow only one nesting level. Allow public declarations. */
2099 gcc_assert (current_function_decl
== NULL_TREE
2100 || DECL_FILE_SCOPE_P (current_function_decl
)
2101 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
2102 == NAMESPACE_DECL
));
2104 type
= gfc_get_function_type (sym
);
2105 fndecl
= build_decl (input_location
,
2106 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
2110 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
2111 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
2112 the opposite of declaring a function as static in C). */
2113 DECL_EXTERNAL (fndecl
) = 0;
2115 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
2116 && (sym
->ns
->default_access
== ACCESS_PRIVATE
2117 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
2118 && flag_module_private
)))
2119 sym
->attr
.access
= ACCESS_PRIVATE
;
2121 if (!current_function_decl
2122 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
2123 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
2124 || sym
->attr
.public_used
))
2125 TREE_PUBLIC (fndecl
) = 1;
2127 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
2128 TREE_USED (fndecl
) = 1;
2130 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
2131 decl_attributes (&fndecl
, attributes
, 0);
2133 /* Figure out the return type of the declared function, and build a
2134 RESULT_DECL for it. If this is a subroutine with alternate
2135 returns, build a RESULT_DECL for it. */
2136 result_decl
= NULL_TREE
;
2137 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
2140 if (gfc_return_by_reference (sym
))
2141 type
= void_type_node
;
2144 if (sym
->result
!= sym
)
2145 result_decl
= gfc_sym_identifier (sym
->result
);
2147 type
= TREE_TYPE (TREE_TYPE (fndecl
));
2152 /* Look for alternate return placeholders. */
2153 int has_alternate_returns
= 0;
2154 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2158 has_alternate_returns
= 1;
2163 if (has_alternate_returns
)
2164 type
= integer_type_node
;
2166 type
= void_type_node
;
2169 result_decl
= build_decl (input_location
,
2170 RESULT_DECL
, result_decl
, type
);
2171 DECL_ARTIFICIAL (result_decl
) = 1;
2172 DECL_IGNORED_P (result_decl
) = 1;
2173 DECL_CONTEXT (result_decl
) = fndecl
;
2174 DECL_RESULT (fndecl
) = result_decl
;
2176 /* Don't call layout_decl for a RESULT_DECL.
2177 layout_decl (result_decl, 0); */
2179 /* TREE_STATIC means the function body is defined here. */
2180 TREE_STATIC (fndecl
) = 1;
2182 /* Set attributes for PURE functions. A call to a PURE function in the
2183 Fortran 95 sense is both pure and without side effects in the C
2185 if (attr
.pure
|| attr
.implicit_pure
)
2187 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2188 including an alternate return. In that case it can also be
2189 marked as PURE. See also in gfc_get_extern_function_decl(). */
2190 if (attr
.function
&& !gfc_return_by_reference (sym
))
2191 DECL_PURE_P (fndecl
) = 1;
2192 TREE_SIDE_EFFECTS (fndecl
) = 0;
2196 /* Layout the function declaration and put it in the binding level
2197 of the current function. */
2200 pushdecl_top_level (fndecl
);
2204 /* Perform name mangling if this is a top level or module procedure. */
2205 if (current_function_decl
== NULL_TREE
)
2206 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
2208 sym
->backend_decl
= fndecl
;
2212 /* Create the DECL_ARGUMENTS for a procedure. */
2215 create_function_arglist (gfc_symbol
* sym
)
2218 gfc_formal_arglist
*f
;
2219 tree typelist
, hidden_typelist
;
2220 tree arglist
, hidden_arglist
;
2224 fndecl
= sym
->backend_decl
;
2226 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2227 the new FUNCTION_DECL node. */
2228 arglist
= NULL_TREE
;
2229 hidden_arglist
= NULL_TREE
;
2230 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
2232 if (sym
->attr
.entry_master
)
2234 type
= TREE_VALUE (typelist
);
2235 parm
= build_decl (input_location
,
2236 PARM_DECL
, get_identifier ("__entry"), type
);
2238 DECL_CONTEXT (parm
) = fndecl
;
2239 DECL_ARG_TYPE (parm
) = type
;
2240 TREE_READONLY (parm
) = 1;
2241 gfc_finish_decl (parm
);
2242 DECL_ARTIFICIAL (parm
) = 1;
2244 arglist
= chainon (arglist
, parm
);
2245 typelist
= TREE_CHAIN (typelist
);
2248 if (gfc_return_by_reference (sym
))
2250 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2252 if (sym
->ts
.type
== BT_CHARACTER
)
2254 /* Length of character result. */
2255 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2257 length
= build_decl (input_location
,
2259 get_identifier (".__result"),
2261 if (POINTER_TYPE_P (len_type
))
2263 sym
->ts
.u
.cl
->passed_length
= length
;
2264 TREE_USED (length
) = 1;
2266 else if (!sym
->ts
.u
.cl
->length
)
2268 sym
->ts
.u
.cl
->backend_decl
= length
;
2269 TREE_USED (length
) = 1;
2271 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2272 DECL_CONTEXT (length
) = fndecl
;
2273 DECL_ARG_TYPE (length
) = len_type
;
2274 TREE_READONLY (length
) = 1;
2275 DECL_ARTIFICIAL (length
) = 1;
2276 gfc_finish_decl (length
);
2277 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2278 || sym
->ts
.u
.cl
->backend_decl
== length
)
2283 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2285 tree len
= build_decl (input_location
,
2287 get_identifier ("..__result"),
2288 gfc_charlen_type_node
);
2289 DECL_ARTIFICIAL (len
) = 1;
2290 TREE_USED (len
) = 1;
2291 sym
->ts
.u
.cl
->backend_decl
= len
;
2294 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2295 arg
= sym
->result
? sym
->result
: sym
;
2296 backend_decl
= arg
->backend_decl
;
2297 /* Temporary clear it, so that gfc_sym_type creates complete
2299 arg
->backend_decl
= NULL
;
2300 type
= gfc_sym_type (arg
);
2301 arg
->backend_decl
= backend_decl
;
2302 type
= build_reference_type (type
);
2306 parm
= build_decl (input_location
,
2307 PARM_DECL
, get_identifier ("__result"), type
);
2309 DECL_CONTEXT (parm
) = fndecl
;
2310 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2311 TREE_READONLY (parm
) = 1;
2312 DECL_ARTIFICIAL (parm
) = 1;
2313 gfc_finish_decl (parm
);
2315 arglist
= chainon (arglist
, parm
);
2316 typelist
= TREE_CHAIN (typelist
);
2318 if (sym
->ts
.type
== BT_CHARACTER
)
2320 gfc_allocate_lang_decl (parm
);
2321 arglist
= chainon (arglist
, length
);
2322 typelist
= TREE_CHAIN (typelist
);
2326 hidden_typelist
= typelist
;
2327 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2328 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2329 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2331 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2333 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2335 /* Ignore alternate returns. */
2339 type
= TREE_VALUE (typelist
);
2341 if (f
->sym
->ts
.type
== BT_CHARACTER
2342 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2344 tree len_type
= TREE_VALUE (hidden_typelist
);
2345 tree length
= NULL_TREE
;
2346 if (!f
->sym
->ts
.deferred
)
2347 gcc_assert (len_type
== gfc_charlen_type_node
);
2349 gcc_assert (POINTER_TYPE_P (len_type
));
2351 strcpy (&name
[1], f
->sym
->name
);
2353 length
= build_decl (input_location
,
2354 PARM_DECL
, get_identifier (name
), len_type
);
2356 hidden_arglist
= chainon (hidden_arglist
, length
);
2357 DECL_CONTEXT (length
) = fndecl
;
2358 DECL_ARTIFICIAL (length
) = 1;
2359 DECL_ARG_TYPE (length
) = len_type
;
2360 TREE_READONLY (length
) = 1;
2361 gfc_finish_decl (length
);
2363 /* Remember the passed value. */
2364 if (!f
->sym
->ts
.u
.cl
|| f
->sym
->ts
.u
.cl
->passed_length
)
2366 /* This can happen if the same type is used for multiple
2367 arguments. We need to copy cl as otherwise
2368 cl->passed_length gets overwritten. */
2369 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2371 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2373 /* Use the passed value for assumed length variables. */
2374 if (!f
->sym
->ts
.u
.cl
->length
)
2376 TREE_USED (length
) = 1;
2377 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2378 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2381 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2383 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2384 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2386 if (POINTER_TYPE_P (len_type
))
2387 f
->sym
->ts
.u
.cl
->backend_decl
=
2388 build_fold_indirect_ref_loc (input_location
, length
);
2389 else if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2390 gfc_create_string_length (f
->sym
);
2392 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2393 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2394 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2396 type
= gfc_sym_type (f
->sym
);
2399 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2400 hence, the optional status cannot be transferred via a NULL pointer.
2401 Thus, we will use a hidden argument in that case. */
2402 else if (f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2403 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2404 && !gfc_bt_struct (f
->sym
->ts
.type
))
2407 strcpy (&name
[1], f
->sym
->name
);
2409 tmp
= build_decl (input_location
,
2410 PARM_DECL
, get_identifier (name
),
2413 hidden_arglist
= chainon (hidden_arglist
, tmp
);
2414 DECL_CONTEXT (tmp
) = fndecl
;
2415 DECL_ARTIFICIAL (tmp
) = 1;
2416 DECL_ARG_TYPE (tmp
) = boolean_type_node
;
2417 TREE_READONLY (tmp
) = 1;
2418 gfc_finish_decl (tmp
);
2421 /* For non-constant length array arguments, make sure they use
2422 a different type node from TYPE_ARG_TYPES type. */
2423 if (f
->sym
->attr
.dimension
2424 && type
== TREE_VALUE (typelist
)
2425 && TREE_CODE (type
) == POINTER_TYPE
2426 && GFC_ARRAY_TYPE_P (type
)
2427 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2428 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2430 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2431 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2433 type
= gfc_sym_type (f
->sym
);
2436 if (f
->sym
->attr
.proc_pointer
)
2437 type
= build_pointer_type (type
);
2439 if (f
->sym
->attr
.volatile_
)
2440 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2442 /* Build the argument declaration. */
2443 parm
= build_decl (input_location
,
2444 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2446 if (f
->sym
->attr
.volatile_
)
2448 TREE_THIS_VOLATILE (parm
) = 1;
2449 TREE_SIDE_EFFECTS (parm
) = 1;
2452 /* Fill in arg stuff. */
2453 DECL_CONTEXT (parm
) = fndecl
;
2454 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2455 /* All implementation args except for VALUE are read-only. */
2456 if (!f
->sym
->attr
.value
)
2457 TREE_READONLY (parm
) = 1;
2458 if (POINTER_TYPE_P (type
)
2459 && (!f
->sym
->attr
.proc_pointer
2460 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2461 DECL_BY_REFERENCE (parm
) = 1;
2463 gfc_finish_decl (parm
);
2464 gfc_finish_decl_attrs (parm
, &f
->sym
->attr
);
2466 f
->sym
->backend_decl
= parm
;
2468 /* Coarrays which are descriptorless or assumed-shape pass with
2469 -fcoarray=lib the token and the offset as hidden arguments. */
2470 if (flag_coarray
== GFC_FCOARRAY_LIB
2471 && ((f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.codimension
2472 && !f
->sym
->attr
.allocatable
)
2473 || (f
->sym
->ts
.type
== BT_CLASS
2474 && CLASS_DATA (f
->sym
)->attr
.codimension
2475 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2481 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2482 && !sym
->attr
.is_bind_c
);
2483 caf_type
= f
->sym
->ts
.type
== BT_CLASS
2484 ? TREE_TYPE (CLASS_DATA (f
->sym
)->backend_decl
)
2485 : TREE_TYPE (f
->sym
->backend_decl
);
2487 token
= build_decl (input_location
, PARM_DECL
,
2488 create_tmp_var_name ("caf_token"),
2489 build_qualified_type (pvoid_type_node
,
2490 TYPE_QUAL_RESTRICT
));
2491 if ((f
->sym
->ts
.type
!= BT_CLASS
2492 && f
->sym
->as
->type
!= AS_DEFERRED
)
2493 || (f
->sym
->ts
.type
== BT_CLASS
2494 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2496 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2497 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2498 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2499 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2500 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2504 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2505 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2508 DECL_CONTEXT (token
) = fndecl
;
2509 DECL_ARTIFICIAL (token
) = 1;
2510 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2511 TREE_READONLY (token
) = 1;
2512 hidden_arglist
= chainon (hidden_arglist
, token
);
2513 gfc_finish_decl (token
);
2515 offset
= build_decl (input_location
, PARM_DECL
,
2516 create_tmp_var_name ("caf_offset"),
2517 gfc_array_index_type
);
2519 if ((f
->sym
->ts
.type
!= BT_CLASS
2520 && f
->sym
->as
->type
!= AS_DEFERRED
)
2521 || (f
->sym
->ts
.type
== BT_CLASS
2522 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2524 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2526 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2530 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2531 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2533 DECL_CONTEXT (offset
) = fndecl
;
2534 DECL_ARTIFICIAL (offset
) = 1;
2535 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2536 TREE_READONLY (offset
) = 1;
2537 hidden_arglist
= chainon (hidden_arglist
, offset
);
2538 gfc_finish_decl (offset
);
2541 arglist
= chainon (arglist
, parm
);
2542 typelist
= TREE_CHAIN (typelist
);
2545 /* Add the hidden string length parameters, unless the procedure
2547 if (!sym
->attr
.is_bind_c
)
2548 arglist
= chainon (arglist
, hidden_arglist
);
2550 gcc_assert (hidden_typelist
== NULL_TREE
2551 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2552 DECL_ARGUMENTS (fndecl
) = arglist
;
2555 /* Do the setup necessary before generating the body of a function. */
2558 trans_function_start (gfc_symbol
* sym
)
2562 fndecl
= sym
->backend_decl
;
2564 /* Let GCC know the current scope is this function. */
2565 current_function_decl
= fndecl
;
2567 /* Let the world know what we're about to do. */
2568 announce_function (fndecl
);
2570 if (DECL_FILE_SCOPE_P (fndecl
))
2572 /* Create RTL for function declaration. */
2573 rest_of_decl_compilation (fndecl
, 1, 0);
2576 /* Create RTL for function definition. */
2577 make_decl_rtl (fndecl
);
2579 allocate_struct_function (fndecl
, false);
2581 /* function.c requires a push at the start of the function. */
2585 /* Create thunks for alternate entry points. */
2588 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2590 gfc_formal_arglist
*formal
;
2591 gfc_formal_arglist
*thunk_formal
;
2593 gfc_symbol
*thunk_sym
;
2599 /* This should always be a toplevel function. */
2600 gcc_assert (current_function_decl
== NULL_TREE
);
2602 gfc_save_backend_locus (&old_loc
);
2603 for (el
= ns
->entries
; el
; el
= el
->next
)
2605 vec
<tree
, va_gc
> *args
= NULL
;
2606 vec
<tree
, va_gc
> *string_args
= NULL
;
2608 thunk_sym
= el
->sym
;
2610 build_function_decl (thunk_sym
, global
);
2611 create_function_arglist (thunk_sym
);
2613 trans_function_start (thunk_sym
);
2615 thunk_fndecl
= thunk_sym
->backend_decl
;
2617 gfc_init_block (&body
);
2619 /* Pass extra parameter identifying this entry point. */
2620 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2621 vec_safe_push (args
, tmp
);
2623 if (thunk_sym
->attr
.function
)
2625 if (gfc_return_by_reference (ns
->proc_name
))
2627 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2628 vec_safe_push (args
, ref
);
2629 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2630 vec_safe_push (args
, DECL_CHAIN (ref
));
2634 for (formal
= gfc_sym_get_dummy_args (ns
->proc_name
); formal
;
2635 formal
= formal
->next
)
2637 /* Ignore alternate returns. */
2638 if (formal
->sym
== NULL
)
2641 /* We don't have a clever way of identifying arguments, so resort to
2642 a brute-force search. */
2643 for (thunk_formal
= gfc_sym_get_dummy_args (thunk_sym
);
2645 thunk_formal
= thunk_formal
->next
)
2647 if (thunk_formal
->sym
== formal
->sym
)
2653 /* Pass the argument. */
2654 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2655 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2656 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2658 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2659 vec_safe_push (string_args
, tmp
);
2664 /* Pass NULL for a missing argument. */
2665 vec_safe_push (args
, null_pointer_node
);
2666 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2668 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2669 vec_safe_push (string_args
, tmp
);
2674 /* Call the master function. */
2675 vec_safe_splice (args
, string_args
);
2676 tmp
= ns
->proc_name
->backend_decl
;
2677 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2678 if (ns
->proc_name
->attr
.mixed_entry_master
)
2680 tree union_decl
, field
;
2681 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2683 union_decl
= build_decl (input_location
,
2684 VAR_DECL
, get_identifier ("__result"),
2685 TREE_TYPE (master_type
));
2686 DECL_ARTIFICIAL (union_decl
) = 1;
2687 DECL_EXTERNAL (union_decl
) = 0;
2688 TREE_PUBLIC (union_decl
) = 0;
2689 TREE_USED (union_decl
) = 1;
2690 layout_decl (union_decl
, 0);
2691 pushdecl (union_decl
);
2693 DECL_CONTEXT (union_decl
) = current_function_decl
;
2694 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2695 TREE_TYPE (union_decl
), union_decl
, tmp
);
2696 gfc_add_expr_to_block (&body
, tmp
);
2698 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2699 field
; field
= DECL_CHAIN (field
))
2700 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2701 thunk_sym
->result
->name
) == 0)
2703 gcc_assert (field
!= NULL_TREE
);
2704 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2705 TREE_TYPE (field
), union_decl
, field
,
2707 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2708 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2709 DECL_RESULT (current_function_decl
), tmp
);
2710 tmp
= build1_v (RETURN_EXPR
, tmp
);
2712 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2715 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2716 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2717 DECL_RESULT (current_function_decl
), tmp
);
2718 tmp
= build1_v (RETURN_EXPR
, tmp
);
2720 gfc_add_expr_to_block (&body
, tmp
);
2722 /* Finish off this function and send it for code generation. */
2723 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2726 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2727 DECL_SAVED_TREE (thunk_fndecl
)
2728 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2729 DECL_INITIAL (thunk_fndecl
));
2731 /* Output the GENERIC tree. */
2732 dump_function (TDI_original
, thunk_fndecl
);
2734 /* Store the end of the function, so that we get good line number
2735 info for the epilogue. */
2736 cfun
->function_end_locus
= input_location
;
2738 /* We're leaving the context of this function, so zap cfun.
2739 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2740 tree_rest_of_compilation. */
2743 current_function_decl
= NULL_TREE
;
2745 cgraph_node::finalize_function (thunk_fndecl
, true);
2747 /* We share the symbols in the formal argument list with other entry
2748 points and the master function. Clear them so that they are
2749 recreated for each function. */
2750 for (formal
= gfc_sym_get_dummy_args (thunk_sym
); formal
;
2751 formal
= formal
->next
)
2752 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2754 formal
->sym
->backend_decl
= NULL_TREE
;
2755 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2756 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2759 if (thunk_sym
->attr
.function
)
2761 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2762 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2763 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2764 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2768 gfc_restore_backend_locus (&old_loc
);
2772 /* Create a decl for a function, and create any thunks for alternate entry
2773 points. If global is true, generate the function in the global binding
2774 level, otherwise in the current binding level (which can be global). */
2777 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
2779 /* Create a declaration for the master function. */
2780 build_function_decl (ns
->proc_name
, global
);
2782 /* Compile the entry thunks. */
2784 build_entry_thunks (ns
, global
);
2786 /* Now create the read argument list. */
2787 create_function_arglist (ns
->proc_name
);
2789 if (ns
->omp_declare_simd
)
2790 gfc_trans_omp_declare_simd (ns
);
2793 /* Return the decl used to hold the function return value. If
2794 parent_flag is set, the context is the parent_scope. */
2797 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2801 tree this_fake_result_decl
;
2802 tree this_function_decl
;
2804 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2808 this_fake_result_decl
= parent_fake_result_decl
;
2809 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2813 this_fake_result_decl
= current_fake_result_decl
;
2814 this_function_decl
= current_function_decl
;
2818 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2819 && sym
->ns
->proc_name
->attr
.entry_master
2820 && sym
!= sym
->ns
->proc_name
)
2823 if (this_fake_result_decl
!= NULL
)
2824 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2825 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2828 return TREE_VALUE (t
);
2829 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2832 this_fake_result_decl
= parent_fake_result_decl
;
2834 this_fake_result_decl
= current_fake_result_decl
;
2836 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2840 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2841 field
; field
= DECL_CHAIN (field
))
2842 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2846 gcc_assert (field
!= NULL_TREE
);
2847 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2848 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
2851 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2853 gfc_add_decl_to_parent_function (var
);
2855 gfc_add_decl_to_function (var
);
2857 SET_DECL_VALUE_EXPR (var
, decl
);
2858 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2859 GFC_DECL_RESULT (var
) = 1;
2861 TREE_CHAIN (this_fake_result_decl
)
2862 = tree_cons (get_identifier (sym
->name
), var
,
2863 TREE_CHAIN (this_fake_result_decl
));
2867 if (this_fake_result_decl
!= NULL_TREE
)
2868 return TREE_VALUE (this_fake_result_decl
);
2870 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2875 if (sym
->ts
.type
== BT_CHARACTER
)
2877 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2878 length
= gfc_create_string_length (sym
);
2880 length
= sym
->ts
.u
.cl
->backend_decl
;
2881 if (TREE_CODE (length
) == VAR_DECL
2882 && DECL_CONTEXT (length
) == NULL_TREE
)
2883 gfc_add_decl_to_function (length
);
2886 if (gfc_return_by_reference (sym
))
2888 decl
= DECL_ARGUMENTS (this_function_decl
);
2890 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2891 && sym
->ns
->proc_name
->attr
.entry_master
)
2892 decl
= DECL_CHAIN (decl
);
2894 TREE_USED (decl
) = 1;
2896 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2900 sprintf (name
, "__result_%.20s",
2901 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2903 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2904 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2905 VAR_DECL
, get_identifier (name
),
2906 gfc_sym_type (sym
));
2908 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2909 VAR_DECL
, get_identifier (name
),
2910 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2911 DECL_ARTIFICIAL (decl
) = 1;
2912 DECL_EXTERNAL (decl
) = 0;
2913 TREE_PUBLIC (decl
) = 0;
2914 TREE_USED (decl
) = 1;
2915 GFC_DECL_RESULT (decl
) = 1;
2916 TREE_ADDRESSABLE (decl
) = 1;
2918 layout_decl (decl
, 0);
2919 gfc_finish_decl_attrs (decl
, &sym
->attr
);
2922 gfc_add_decl_to_parent_function (decl
);
2924 gfc_add_decl_to_function (decl
);
2928 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2930 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2936 /* Builds a function decl. The remaining parameters are the types of the
2937 function arguments. Negative nargs indicates a varargs function. */
2940 build_library_function_decl_1 (tree name
, const char *spec
,
2941 tree rettype
, int nargs
, va_list p
)
2943 vec
<tree
, va_gc
> *arglist
;
2948 /* Library functions must be declared with global scope. */
2949 gcc_assert (current_function_decl
== NULL_TREE
);
2951 /* Create a list of the argument types. */
2952 vec_alloc (arglist
, abs (nargs
));
2953 for (n
= abs (nargs
); n
> 0; n
--)
2955 tree argtype
= va_arg (p
, tree
);
2956 arglist
->quick_push (argtype
);
2959 /* Build the function type and decl. */
2961 fntype
= build_function_type_vec (rettype
, arglist
);
2963 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
2966 tree attr_args
= build_tree_list (NULL_TREE
,
2967 build_string (strlen (spec
), spec
));
2968 tree attrs
= tree_cons (get_identifier ("fn spec"),
2969 attr_args
, TYPE_ATTRIBUTES (fntype
));
2970 fntype
= build_type_attribute_variant (fntype
, attrs
);
2972 fndecl
= build_decl (input_location
,
2973 FUNCTION_DECL
, name
, fntype
);
2975 /* Mark this decl as external. */
2976 DECL_EXTERNAL (fndecl
) = 1;
2977 TREE_PUBLIC (fndecl
) = 1;
2981 rest_of_decl_compilation (fndecl
, 1, 0);
2986 /* Builds a function decl. The remaining parameters are the types of the
2987 function arguments. Negative nargs indicates a varargs function. */
2990 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2994 va_start (args
, nargs
);
2995 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
3000 /* Builds a function decl. The remaining parameters are the types of the
3001 function arguments. Negative nargs indicates a varargs function.
3002 The SPEC parameter specifies the function argument and return type
3003 specification according to the fnspec function type attribute. */
3006 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
3007 tree rettype
, int nargs
, ...)
3011 va_start (args
, nargs
);
3012 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
3018 gfc_build_intrinsic_function_decls (void)
3020 tree gfc_int4_type_node
= gfc_get_int_type (4);
3021 tree gfc_pint4_type_node
= build_pointer_type (gfc_int4_type_node
);
3022 tree gfc_int8_type_node
= gfc_get_int_type (8);
3023 tree gfc_pint8_type_node
= build_pointer_type (gfc_int8_type_node
);
3024 tree gfc_int16_type_node
= gfc_get_int_type (16);
3025 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
3026 tree pchar1_type_node
= gfc_get_pchar_type (1);
3027 tree pchar4_type_node
= gfc_get_pchar_type (4);
3029 /* String functions. */
3030 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
3031 get_identifier (PREFIX("compare_string")), "..R.R",
3032 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
3033 gfc_charlen_type_node
, pchar1_type_node
);
3034 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
3035 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
3037 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
3038 get_identifier (PREFIX("concat_string")), "..W.R.R",
3039 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
3040 gfc_charlen_type_node
, pchar1_type_node
,
3041 gfc_charlen_type_node
, pchar1_type_node
);
3042 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
3044 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
3045 get_identifier (PREFIX("string_len_trim")), "..R",
3046 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
3047 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
3048 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
3050 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
3051 get_identifier (PREFIX("string_index")), "..R.R.",
3052 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3053 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3054 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
3055 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
3057 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
3058 get_identifier (PREFIX("string_scan")), "..R.R.",
3059 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3060 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3061 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
3062 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
3064 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
3065 get_identifier (PREFIX("string_verify")), "..R.R.",
3066 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
3067 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
3068 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
3069 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
3071 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
3072 get_identifier (PREFIX("string_trim")), ".Ww.R",
3073 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3074 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
3077 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
3078 get_identifier (PREFIX("string_minmax")), ".Ww.R",
3079 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3080 build_pointer_type (pchar1_type_node
), integer_type_node
,
3083 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
3084 get_identifier (PREFIX("adjustl")), ".W.R",
3085 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3087 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
3089 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
3090 get_identifier (PREFIX("adjustr")), ".W.R",
3091 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
3093 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
3095 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
3096 get_identifier (PREFIX("select_string")), ".R.R.",
3097 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3098 pchar1_type_node
, gfc_charlen_type_node
);
3099 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
3100 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
3102 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
3103 get_identifier (PREFIX("compare_string_char4")), "..R.R",
3104 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
3105 gfc_charlen_type_node
, pchar4_type_node
);
3106 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
3107 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
3109 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
3110 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
3111 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
3112 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
3114 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
3116 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
3117 get_identifier (PREFIX("string_len_trim_char4")), "..R",
3118 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
3119 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
3120 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
3122 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
3123 get_identifier (PREFIX("string_index_char4")), "..R.R.",
3124 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3125 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3126 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
3127 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
3129 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
3130 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
3131 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3132 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3133 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
3134 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
3136 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
3137 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
3138 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
3139 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
3140 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
3141 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
3143 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
3144 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
3145 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
3146 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
3149 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
3150 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
3151 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
3152 build_pointer_type (pchar4_type_node
), integer_type_node
,
3155 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
3156 get_identifier (PREFIX("adjustl_char4")), ".W.R",
3157 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3159 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
3161 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
3162 get_identifier (PREFIX("adjustr_char4")), ".W.R",
3163 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
3165 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
3167 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
3168 get_identifier (PREFIX("select_string_char4")), ".R.R.",
3169 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
3170 pvoid_type_node
, gfc_charlen_type_node
);
3171 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
3172 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
3175 /* Conversion between character kinds. */
3177 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
3178 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
3179 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
3180 gfc_charlen_type_node
, pchar1_type_node
);
3182 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
3183 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
3184 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
3185 gfc_charlen_type_node
, pchar4_type_node
);
3187 /* Misc. functions. */
3189 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
3190 get_identifier (PREFIX("ttynam")), ".W",
3191 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3194 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
3195 get_identifier (PREFIX("fdate")), ".W",
3196 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
3198 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
3199 get_identifier (PREFIX("ctime")), ".W",
3200 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
3201 gfc_int8_type_node
);
3203 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
3204 get_identifier (PREFIX("selected_char_kind")), "..R",
3205 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
3206 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
3207 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
3209 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
3210 get_identifier (PREFIX("selected_int_kind")), ".R",
3211 gfc_int4_type_node
, 1, pvoid_type_node
);
3212 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
3213 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
3215 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
3216 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
3217 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
3219 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
3220 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
3222 gfor_fndecl_system_clock4
= gfc_build_library_function_decl (
3223 get_identifier (PREFIX("system_clock_4")),
3224 void_type_node
, 3, gfc_pint4_type_node
, gfc_pint4_type_node
,
3225 gfc_pint4_type_node
);
3227 gfor_fndecl_system_clock8
= gfc_build_library_function_decl (
3228 get_identifier (PREFIX("system_clock_8")),
3229 void_type_node
, 3, gfc_pint8_type_node
, gfc_pint8_type_node
,
3230 gfc_pint8_type_node
);
3232 /* Power functions. */
3234 tree ctype
, rtype
, itype
, jtype
;
3235 int rkind
, ikind
, jkind
;
3238 static int ikinds
[NIKINDS
] = {4, 8, 16};
3239 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
3240 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
3242 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
3244 itype
= gfc_get_int_type (ikinds
[ikind
]);
3246 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
3248 jtype
= gfc_get_int_type (ikinds
[jkind
]);
3251 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
3253 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
3254 gfc_build_library_function_decl (get_identifier (name
),
3255 jtype
, 2, jtype
, itype
);
3256 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3257 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3261 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
3263 rtype
= gfc_get_real_type (rkinds
[rkind
]);
3266 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
3268 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
3269 gfc_build_library_function_decl (get_identifier (name
),
3270 rtype
, 2, rtype
, itype
);
3271 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3272 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3275 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
3278 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
3280 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
3281 gfc_build_library_function_decl (get_identifier (name
),
3282 ctype
, 2,ctype
, itype
);
3283 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3284 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3292 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
3293 get_identifier (PREFIX("ishftc4")),
3294 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
3295 gfc_int4_type_node
);
3296 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
3297 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
3299 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
3300 get_identifier (PREFIX("ishftc8")),
3301 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
3302 gfc_int4_type_node
);
3303 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
3304 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
3306 if (gfc_int16_type_node
)
3308 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
3309 get_identifier (PREFIX("ishftc16")),
3310 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3311 gfc_int4_type_node
);
3312 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3313 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3316 /* BLAS functions. */
3318 tree pint
= build_pointer_type (integer_type_node
);
3319 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3320 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3321 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3322 tree pz
= build_pointer_type
3323 (gfc_get_complex_type (gfc_default_double_kind
));
3325 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3327 (flag_underscoring
? "sgemm_" : "sgemm"),
3328 void_type_node
, 15, pchar_type_node
,
3329 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3330 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3332 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3334 (flag_underscoring
? "dgemm_" : "dgemm"),
3335 void_type_node
, 15, pchar_type_node
,
3336 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3337 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3339 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3341 (flag_underscoring
? "cgemm_" : "cgemm"),
3342 void_type_node
, 15, pchar_type_node
,
3343 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3344 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3346 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3348 (flag_underscoring
? "zgemm_" : "zgemm"),
3349 void_type_node
, 15, pchar_type_node
,
3350 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3351 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3355 /* Other functions. */
3356 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3357 get_identifier (PREFIX("size0")), ".R",
3358 gfc_array_index_type
, 1, pvoid_type_node
);
3359 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3360 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3362 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3363 get_identifier (PREFIX("size1")), ".R",
3364 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3365 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3366 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3368 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3369 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3370 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3374 /* Make prototypes for runtime library functions. */
3377 gfc_build_builtin_function_decls (void)
3379 tree gfc_int4_type_node
= gfc_get_int_type (4);
3381 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3382 get_identifier (PREFIX("stop_numeric")),
3383 void_type_node
, 1, gfc_int4_type_node
);
3384 /* STOP doesn't return. */
3385 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3387 gfor_fndecl_stop_numeric_f08
= gfc_build_library_function_decl (
3388 get_identifier (PREFIX("stop_numeric_f08")),
3389 void_type_node
, 1, gfc_int4_type_node
);
3390 /* STOP doesn't return. */
3391 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08
) = 1;
3393 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3394 get_identifier (PREFIX("stop_string")), ".R.",
3395 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3396 /* STOP doesn't return. */
3397 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3399 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3400 get_identifier (PREFIX("error_stop_numeric")),
3401 void_type_node
, 1, gfc_int4_type_node
);
3402 /* ERROR STOP doesn't return. */
3403 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3405 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3406 get_identifier (PREFIX("error_stop_string")), ".R.",
3407 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3408 /* ERROR STOP doesn't return. */
3409 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3411 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3412 get_identifier (PREFIX("pause_numeric")),
3413 void_type_node
, 1, gfc_int4_type_node
);
3415 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3416 get_identifier (PREFIX("pause_string")), ".R.",
3417 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3419 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3420 get_identifier (PREFIX("runtime_error")), ".R",
3421 void_type_node
, -1, pchar_type_node
);
3422 /* The runtime_error function does not return. */
3423 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3425 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3426 get_identifier (PREFIX("runtime_error_at")), ".RR",
3427 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3428 /* The runtime_error_at function does not return. */
3429 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3431 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3432 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3433 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3435 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3436 get_identifier (PREFIX("generate_error")), ".R.R",
3437 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3440 gfor_fndecl_os_error
= gfc_build_library_function_decl_with_spec (
3441 get_identifier (PREFIX("os_error")), ".R",
3442 void_type_node
, 1, pchar_type_node
);
3443 /* The runtime_error function does not return. */
3444 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
3446 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3447 get_identifier (PREFIX("set_args")),
3448 void_type_node
, 2, integer_type_node
,
3449 build_pointer_type (pchar_type_node
));
3451 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3452 get_identifier (PREFIX("set_fpe")),
3453 void_type_node
, 1, integer_type_node
);
3455 gfor_fndecl_ieee_procedure_entry
= gfc_build_library_function_decl (
3456 get_identifier (PREFIX("ieee_procedure_entry")),
3457 void_type_node
, 1, pvoid_type_node
);
3459 gfor_fndecl_ieee_procedure_exit
= gfc_build_library_function_decl (
3460 get_identifier (PREFIX("ieee_procedure_exit")),
3461 void_type_node
, 1, pvoid_type_node
);
3463 /* Keep the array dimension in sync with the call, later in this file. */
3464 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3465 get_identifier (PREFIX("set_options")), "..R",
3466 void_type_node
, 2, integer_type_node
,
3467 build_pointer_type (integer_type_node
));
3469 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3470 get_identifier (PREFIX("set_convert")),
3471 void_type_node
, 1, integer_type_node
);
3473 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3474 get_identifier (PREFIX("set_record_marker")),
3475 void_type_node
, 1, integer_type_node
);
3477 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3478 get_identifier (PREFIX("set_max_subrecord_length")),
3479 void_type_node
, 1, integer_type_node
);
3481 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3482 get_identifier (PREFIX("internal_pack")), ".r",
3483 pvoid_type_node
, 1, pvoid_type_node
);
3485 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3486 get_identifier (PREFIX("internal_unpack")), ".wR",
3487 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3489 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3490 get_identifier (PREFIX("associated")), ".RR",
3491 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3492 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3493 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3495 /* Coarray library calls. */
3496 if (flag_coarray
== GFC_FCOARRAY_LIB
)
3498 tree pint_type
, pppchar_type
;
3500 pint_type
= build_pointer_type (integer_type_node
);
3502 = build_pointer_type (build_pointer_type (pchar_type_node
));
3504 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3505 get_identifier (PREFIX("caf_init")), void_type_node
,
3506 2, pint_type
, pppchar_type
);
3508 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3509 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3511 gfor_fndecl_caf_this_image
= gfc_build_library_function_decl (
3512 get_identifier (PREFIX("caf_this_image")), integer_type_node
,
3513 1, integer_type_node
);
3515 gfor_fndecl_caf_num_images
= gfc_build_library_function_decl (
3516 get_identifier (PREFIX("caf_num_images")), integer_type_node
,
3517 2, integer_type_node
, integer_type_node
);
3519 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3520 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node
, 6,
3521 size_type_node
, integer_type_node
, ppvoid_type_node
, pint_type
,
3522 pchar_type_node
, integer_type_node
);
3524 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3525 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node
, 4,
3526 ppvoid_type_node
, pint_type
, pchar_type_node
, integer_type_node
);
3528 gfor_fndecl_caf_get
= gfc_build_library_function_decl_with_spec (
3529 get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node
, 9,
3530 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3531 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3534 gfor_fndecl_caf_send
= gfc_build_library_function_decl_with_spec (
3535 get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node
, 9,
3536 pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3537 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3540 gfor_fndecl_caf_sendget
= gfc_build_library_function_decl_with_spec (
3541 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node
,
3542 13, pvoid_type_node
, size_type_node
, integer_type_node
, pvoid_type_node
,
3543 pvoid_type_node
, pvoid_type_node
, size_type_node
, integer_type_node
,
3544 pvoid_type_node
, pvoid_type_node
, integer_type_node
, integer_type_node
,
3547 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3548 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3549 3, pint_type
, pchar_type_node
, integer_type_node
);
3551 gfor_fndecl_caf_sync_memory
= gfc_build_library_function_decl_with_spec (
3552 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node
,
3553 3, pint_type
, pchar_type_node
, integer_type_node
);
3555 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3556 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3557 5, integer_type_node
, pint_type
, pint_type
,
3558 pchar_type_node
, integer_type_node
);
3560 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3561 get_identifier (PREFIX("caf_error_stop")),
3562 void_type_node
, 1, gfc_int4_type_node
);
3563 /* CAF's ERROR STOP doesn't return. */
3564 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3566 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3567 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3568 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3569 /* CAF's ERROR STOP doesn't return. */
3570 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3572 gfor_fndecl_caf_stop_numeric
= gfc_build_library_function_decl_with_spec (
3573 get_identifier (PREFIX("caf_stop_numeric")), ".R.",
3574 void_type_node
, 1, gfc_int4_type_node
);
3575 /* CAF's STOP doesn't return. */
3576 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric
) = 1;
3578 gfor_fndecl_caf_stop_str
= gfc_build_library_function_decl_with_spec (
3579 get_identifier (PREFIX("caf_stop_str")), ".R.",
3580 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3581 /* CAF's STOP doesn't return. */
3582 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str
) = 1;
3584 gfor_fndecl_caf_atomic_def
= gfc_build_library_function_decl_with_spec (
3585 get_identifier (PREFIX("caf_atomic_define")), "R..RW",
3586 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3587 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3589 gfor_fndecl_caf_atomic_ref
= gfc_build_library_function_decl_with_spec (
3590 get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
3591 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3592 pvoid_type_node
, pint_type
, integer_type_node
, integer_type_node
);
3594 gfor_fndecl_caf_atomic_cas
= gfc_build_library_function_decl_with_spec (
3595 get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
3596 void_type_node
, 9, pvoid_type_node
, size_type_node
, integer_type_node
,
3597 pvoid_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
3598 integer_type_node
, integer_type_node
);
3600 gfor_fndecl_caf_atomic_op
= gfc_build_library_function_decl_with_spec (
3601 get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
3602 void_type_node
, 9, integer_type_node
, pvoid_type_node
, size_type_node
,
3603 integer_type_node
, pvoid_type_node
, pvoid_type_node
, pint_type
,
3604 integer_type_node
, integer_type_node
);
3606 gfor_fndecl_caf_lock
= gfc_build_library_function_decl_with_spec (
3607 get_identifier (PREFIX("caf_lock")), "R..WWW",
3608 void_type_node
, 7, pvoid_type_node
, size_type_node
, integer_type_node
,
3609 pint_type
, pint_type
, pchar_type_node
, integer_type_node
);
3611 gfor_fndecl_caf_unlock
= gfc_build_library_function_decl_with_spec (
3612 get_identifier (PREFIX("caf_unlock")), "R..WW",
3613 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3614 pint_type
, pchar_type_node
, integer_type_node
);
3616 gfor_fndecl_caf_event_post
= gfc_build_library_function_decl_with_spec (
3617 get_identifier (PREFIX("caf_event_post")), "R..WW",
3618 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3619 pint_type
, pchar_type_node
, integer_type_node
);
3621 gfor_fndecl_caf_event_wait
= gfc_build_library_function_decl_with_spec (
3622 get_identifier (PREFIX("caf_event_wait")), "R..WW",
3623 void_type_node
, 6, pvoid_type_node
, size_type_node
, integer_type_node
,
3624 pint_type
, pchar_type_node
, integer_type_node
);
3626 gfor_fndecl_caf_event_query
= gfc_build_library_function_decl_with_spec (
3627 get_identifier (PREFIX("caf_event_query")), "R..WW",
3628 void_type_node
, 5, pvoid_type_node
, size_type_node
, integer_type_node
,
3629 pint_type
, pint_type
);
3631 gfor_fndecl_co_broadcast
= gfc_build_library_function_decl_with_spec (
3632 get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
3633 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
3634 pint_type
, pchar_type_node
, integer_type_node
);
3636 gfor_fndecl_co_max
= gfc_build_library_function_decl_with_spec (
3637 get_identifier (PREFIX("caf_co_max")), "W.WW",
3638 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
3639 pint_type
, pchar_type_node
, integer_type_node
, integer_type_node
);
3641 gfor_fndecl_co_min
= gfc_build_library_function_decl_with_spec (
3642 get_identifier (PREFIX("caf_co_min")), "W.WW",
3643 void_type_node
, 6, pvoid_type_node
, integer_type_node
,
3644 pint_type
, pchar_type_node
, integer_type_node
, integer_type_node
);
3646 gfor_fndecl_co_reduce
= gfc_build_library_function_decl_with_spec (
3647 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
3648 void_type_node
, 8, pvoid_type_node
,
3649 build_pointer_type (build_varargs_function_type_list (void_type_node
,
3651 integer_type_node
, integer_type_node
, pint_type
, pchar_type_node
,
3652 integer_type_node
, integer_type_node
);
3654 gfor_fndecl_co_sum
= gfc_build_library_function_decl_with_spec (
3655 get_identifier (PREFIX("caf_co_sum")), "W.WW",
3656 void_type_node
, 5, pvoid_type_node
, integer_type_node
,
3657 pint_type
, pchar_type_node
, integer_type_node
);
3660 gfc_build_intrinsic_function_decls ();
3661 gfc_build_intrinsic_lib_fndecls ();
3662 gfc_build_io_library_fndecls ();
3666 /* Evaluate the length of dummy character variables. */
3669 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
3670 gfc_wrapped_block
*block
)
3674 gfc_finish_decl (cl
->backend_decl
);
3676 gfc_start_block (&init
);
3678 /* Evaluate the string length expression. */
3679 gfc_conv_string_length (cl
, NULL
, &init
);
3681 gfc_trans_vla_type_sizes (sym
, &init
);
3683 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3687 /* Allocate and cleanup an automatic character variable. */
3690 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3696 gcc_assert (sym
->backend_decl
);
3697 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
3699 gfc_init_block (&init
);
3701 /* Evaluate the string length expression. */
3702 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
3704 gfc_trans_vla_type_sizes (sym
, &init
);
3706 decl
= sym
->backend_decl
;
3708 /* Emit a DECL_EXPR for this variable, which will cause the
3709 gimplifier to allocate storage, and all that good stuff. */
3710 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
3711 gfc_add_expr_to_block (&init
, tmp
);
3713 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3716 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3719 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3723 gcc_assert (sym
->backend_decl
);
3724 gfc_start_block (&init
);
3726 /* Set the initial value to length. See the comments in
3727 function gfc_add_assign_aux_vars in this file. */
3728 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
3729 build_int_cst (gfc_charlen_type_node
, -2));
3731 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3735 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
3737 tree t
= *tp
, var
, val
;
3739 if (t
== NULL
|| t
== error_mark_node
)
3741 if (TREE_CONSTANT (t
) || DECL_P (t
))
3744 if (TREE_CODE (t
) == SAVE_EXPR
)
3746 if (SAVE_EXPR_RESOLVED_P (t
))
3748 *tp
= TREE_OPERAND (t
, 0);
3751 val
= TREE_OPERAND (t
, 0);
3756 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
3757 gfc_add_decl_to_function (var
);
3758 gfc_add_modify (body
, var
, unshare_expr (val
));
3759 if (TREE_CODE (t
) == SAVE_EXPR
)
3760 TREE_OPERAND (t
, 0) = var
;
3765 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
3769 if (type
== NULL
|| type
== error_mark_node
)
3772 type
= TYPE_MAIN_VARIANT (type
);
3774 if (TREE_CODE (type
) == INTEGER_TYPE
)
3776 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
3777 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
3779 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3781 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
3782 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
3785 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3787 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
3788 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
3789 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
3790 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
3792 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3794 TYPE_SIZE (t
) = TYPE_SIZE (type
);
3795 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
3800 /* Make sure all type sizes and array domains are either constant,
3801 or variable or parameter decls. This is a simplified variant
3802 of gimplify_type_sizes, but we can't use it here, as none of the
3803 variables in the expressions have been gimplified yet.
3804 As type sizes and domains for various variable length arrays
3805 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3806 time, without this routine gimplify_type_sizes in the middle-end
3807 could result in the type sizes being gimplified earlier than where
3808 those variables are initialized. */
3811 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
3813 tree type
= TREE_TYPE (sym
->backend_decl
);
3815 if (TREE_CODE (type
) == FUNCTION_TYPE
3816 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
3818 if (! current_fake_result_decl
)
3821 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
3824 while (POINTER_TYPE_P (type
))
3825 type
= TREE_TYPE (type
);
3827 if (GFC_DESCRIPTOR_TYPE_P (type
))
3829 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3831 while (POINTER_TYPE_P (etype
))
3832 etype
= TREE_TYPE (etype
);
3834 gfc_trans_vla_type_sizes_1 (etype
, body
);
3837 gfc_trans_vla_type_sizes_1 (type
, body
);
3841 /* Initialize a derived type by building an lvalue from the symbol
3842 and using trans_assignment to do the work. Set dealloc to false
3843 if no deallocation prior the assignment is needed. */
3845 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
3853 gcc_assert (!sym
->attr
.allocatable
);
3854 gfc_set_sym_referenced (sym
);
3855 e
= gfc_lval_expr_from_sym (sym
);
3856 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3857 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3858 || sym
->ns
->proc_name
->attr
.entry_master
))
3860 present
= gfc_conv_expr_present (sym
);
3861 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
3862 tmp
, build_empty_stmt (input_location
));
3864 gfc_add_expr_to_block (block
, tmp
);
3869 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3870 them their default initializer, if they do not have allocatable
3871 components, they have their allocatable components deallocated. */
3874 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3877 gfc_formal_arglist
*f
;
3881 gfc_init_block (&init
);
3882 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
3883 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3884 && !f
->sym
->attr
.pointer
3885 && f
->sym
->ts
.type
== BT_DERIVED
)
3889 /* Note: Allocatables are excluded as they are already handled
3891 if (!f
->sym
->attr
.allocatable
3892 && gfc_is_finalizable (f
->sym
->ts
.u
.derived
, NULL
))
3897 gfc_init_block (&block
);
3898 f
->sym
->attr
.referenced
= 1;
3899 e
= gfc_lval_expr_from_sym (f
->sym
);
3900 gfc_add_finalizer_call (&block
, e
);
3902 tmp
= gfc_finish_block (&block
);
3905 if (tmp
== NULL_TREE
&& !f
->sym
->attr
.allocatable
3906 && f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3907 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3908 f
->sym
->backend_decl
,
3909 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3911 if (tmp
!= NULL_TREE
&& (f
->sym
->attr
.optional
3912 || f
->sym
->ns
->proc_name
->attr
.entry_master
))
3914 present
= gfc_conv_expr_present (f
->sym
);
3915 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3916 present
, tmp
, build_empty_stmt (input_location
));
3919 if (tmp
!= NULL_TREE
)
3920 gfc_add_expr_to_block (&init
, tmp
);
3921 else if (f
->sym
->value
&& !f
->sym
->attr
.allocatable
)
3922 gfc_init_default_dt (f
->sym
, &init
, true);
3924 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3925 && f
->sym
->ts
.type
== BT_CLASS
3926 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3927 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)
3932 gfc_init_block (&block
);
3933 f
->sym
->attr
.referenced
= 1;
3934 e
= gfc_lval_expr_from_sym (f
->sym
);
3935 gfc_add_finalizer_call (&block
, e
);
3937 tmp
= gfc_finish_block (&block
);
3939 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
3941 present
= gfc_conv_expr_present (f
->sym
);
3942 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3944 build_empty_stmt (input_location
));
3947 gfc_add_expr_to_block (&init
, tmp
);
3950 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3954 /* Helper function to manage deferred string lengths. */
3957 gfc_null_and_pass_deferred_len (gfc_symbol
*sym
, stmtblock_t
*init
,
3962 /* Character length passed by reference. */
3963 tmp
= sym
->ts
.u
.cl
->passed_length
;
3964 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3965 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3967 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3968 /* Zero the string length when entering the scope. */
3969 gfc_add_modify (init
, sym
->ts
.u
.cl
->backend_decl
,
3970 build_int_cst (gfc_charlen_type_node
, 0));
3975 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3976 gfc_charlen_type_node
,
3977 sym
->ts
.u
.cl
->backend_decl
, tmp
);
3978 if (sym
->attr
.optional
)
3980 tree present
= gfc_conv_expr_present (sym
);
3981 tmp2
= build3_loc (input_location
, COND_EXPR
,
3982 void_type_node
, present
, tmp2
,
3983 build_empty_stmt (input_location
));
3985 gfc_add_expr_to_block (init
, tmp2
);
3988 gfc_restore_backend_locus (loc
);
3990 /* Pass the final character length back. */
3991 if (sym
->attr
.intent
!= INTENT_IN
)
3993 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3994 gfc_charlen_type_node
, tmp
,
3995 sym
->ts
.u
.cl
->backend_decl
);
3996 if (sym
->attr
.optional
)
3998 tree present
= gfc_conv_expr_present (sym
);
3999 tmp
= build3_loc (input_location
, COND_EXPR
,
4000 void_type_node
, present
, tmp
,
4001 build_empty_stmt (input_location
));
4010 /* Generate function entry and exit code, and add it to the function body.
4012 Allocation and initialization of array variables.
4013 Allocation of character string variables.
4014 Initialization and possibly repacking of dummy arrays.
4015 Initialization of ASSIGN statement auxiliary variable.
4016 Initialization of ASSOCIATE names.
4017 Automatic deallocation. */
4020 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
4024 gfc_formal_arglist
*f
;
4025 stmtblock_t tmpblock
;
4026 bool seen_trans_deferred_array
= false;
4032 /* Deal with implicit return variables. Explicit return variables will
4033 already have been added. */
4034 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
4036 if (!current_fake_result_decl
)
4038 gfc_entry_list
*el
= NULL
;
4039 if (proc_sym
->attr
.entry_master
)
4041 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
4042 if (el
->sym
!= el
->sym
->result
)
4045 /* TODO: move to the appropriate place in resolve.c. */
4046 if (warn_return_type
&& el
== NULL
)
4047 gfc_warning (OPT_Wreturn_type
,
4048 "Return value of function %qs at %L not set",
4049 proc_sym
->name
, &proc_sym
->declared_at
);
4051 else if (proc_sym
->as
)
4053 tree result
= TREE_VALUE (current_fake_result_decl
);
4054 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
4056 /* An automatic character length, pointer array result. */
4057 if (proc_sym
->ts
.type
== BT_CHARACTER
4058 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4061 if (proc_sym
->ts
.deferred
)
4063 gfc_save_backend_locus (&loc
);
4064 gfc_set_backend_locus (&proc_sym
->declared_at
);
4065 gfc_start_block (&init
);
4066 tmp
= gfc_null_and_pass_deferred_len (proc_sym
, &init
, &loc
);
4067 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4070 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4073 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
4075 if (proc_sym
->ts
.deferred
)
4078 gfc_save_backend_locus (&loc
);
4079 gfc_set_backend_locus (&proc_sym
->declared_at
);
4080 gfc_start_block (&init
);
4081 /* Zero the string length on entry. */
4082 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
4083 build_int_cst (gfc_charlen_type_node
, 0));
4084 /* Null the pointer. */
4085 e
= gfc_lval_expr_from_sym (proc_sym
);
4086 gfc_init_se (&se
, NULL
);
4087 se
.want_pointer
= 1;
4088 gfc_conv_expr (&se
, e
);
4091 gfc_add_modify (&init
, tmp
,
4092 fold_convert (TREE_TYPE (se
.expr
),
4093 null_pointer_node
));
4094 gfc_restore_backend_locus (&loc
);
4096 /* Pass back the string length on exit. */
4097 tmp
= proc_sym
->ts
.u
.cl
->backend_decl
;
4098 if (TREE_CODE (tmp
) != INDIRECT_REF
4099 && proc_sym
->ts
.u
.cl
->passed_length
)
4101 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
4102 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4103 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
4104 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4105 gfc_charlen_type_node
, tmp
,
4106 proc_sym
->ts
.u
.cl
->backend_decl
);
4111 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4113 else if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4114 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
4117 gcc_assert (flag_f2c
&& proc_sym
->ts
.type
== BT_COMPLEX
);
4120 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4121 should be done here so that the offsets and lbounds of arrays
4123 gfc_save_backend_locus (&loc
);
4124 gfc_set_backend_locus (&proc_sym
->declared_at
);
4125 init_intent_out_dt (proc_sym
, block
);
4126 gfc_restore_backend_locus (&loc
);
4128 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
4130 bool alloc_comp_or_fini
= (sym
->ts
.type
== BT_DERIVED
)
4131 && (sym
->ts
.u
.derived
->attr
.alloc_comp
4132 || gfc_is_finalizable (sym
->ts
.u
.derived
,
4137 if (sym
->attr
.subref_array_pointer
4138 && GFC_DECL_SPAN (sym
->backend_decl
)
4139 && !TREE_STATIC (GFC_DECL_SPAN (sym
->backend_decl
)))
4141 gfc_init_block (&tmpblock
);
4142 gfc_add_modify (&tmpblock
, GFC_DECL_SPAN (sym
->backend_decl
),
4143 build_int_cst (gfc_array_index_type
, 0));
4144 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4148 if (sym
->ts
.type
== BT_CLASS
4149 && (sym
->attr
.save
|| flag_max_stack_var_size
== 0)
4150 && CLASS_DATA (sym
)->attr
.allocatable
)
4154 if (UNLIMITED_POLY (sym
))
4155 vptr
= null_pointer_node
;
4159 vsym
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
4160 vptr
= gfc_get_symbol_decl (vsym
);
4161 vptr
= gfc_build_addr_expr (NULL
, vptr
);
4164 if (CLASS_DATA (sym
)->attr
.dimension
4165 || (CLASS_DATA (sym
)->attr
.codimension
4166 && flag_coarray
!= GFC_FCOARRAY_LIB
))
4168 tmp
= gfc_class_data_get (sym
->backend_decl
);
4169 tmp
= gfc_build_null_descriptor (TREE_TYPE (tmp
));
4172 tmp
= null_pointer_node
;
4174 DECL_INITIAL (sym
->backend_decl
)
4175 = gfc_class_set_static_fields (sym
->backend_decl
, vptr
, tmp
);
4176 TREE_CONSTANT (DECL_INITIAL (sym
->backend_decl
)) = 1;
4178 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
4179 || (IS_CLASS_ARRAY (sym
) && !CLASS_DATA (sym
)->attr
.allocatable
)))
4181 bool is_classarray
= IS_CLASS_ARRAY (sym
);
4182 symbol_attribute
*array_attr
;
4184 array_type type_of_array
;
4186 array_attr
= is_classarray
? &CLASS_DATA (sym
)->attr
: &sym
->attr
;
4187 as
= is_classarray
? CLASS_DATA (sym
)->as
: sym
->as
;
4188 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
4189 type_of_array
= as
->type
;
4190 if (type_of_array
== AS_ASSUMED_SIZE
&& as
->cp_was_assumed
)
4191 type_of_array
= AS_EXPLICIT
;
4192 switch (type_of_array
)
4195 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4196 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4197 /* Allocatable and pointer arrays need to processed
4199 else if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.pointer
)
4200 || (sym
->ts
.type
== BT_CLASS
4201 && CLASS_DATA (sym
)->attr
.class_pointer
)
4202 || array_attr
->allocatable
)
4204 if (TREE_STATIC (sym
->backend_decl
))
4206 gfc_save_backend_locus (&loc
);
4207 gfc_set_backend_locus (&sym
->declared_at
);
4208 gfc_trans_static_array_pointer (sym
);
4209 gfc_restore_backend_locus (&loc
);
4213 seen_trans_deferred_array
= true;
4214 gfc_trans_deferred_array (sym
, block
);
4217 else if (sym
->attr
.codimension
4218 && TREE_STATIC (sym
->backend_decl
))
4220 gfc_init_block (&tmpblock
);
4221 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
4223 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4229 gfc_save_backend_locus (&loc
);
4230 gfc_set_backend_locus (&sym
->declared_at
);
4232 if (alloc_comp_or_fini
)
4234 seen_trans_deferred_array
= true;
4235 gfc_trans_deferred_array (sym
, block
);
4237 else if (sym
->ts
.type
== BT_DERIVED
4240 && sym
->attr
.save
== SAVE_NONE
)
4242 gfc_start_block (&tmpblock
);
4243 gfc_init_default_dt (sym
, &tmpblock
, false);
4244 gfc_add_init_cleanup (block
,
4245 gfc_finish_block (&tmpblock
),
4249 gfc_trans_auto_array_allocation (sym
->backend_decl
,
4251 gfc_restore_backend_locus (&loc
);
4255 case AS_ASSUMED_SIZE
:
4256 /* Must be a dummy parameter. */
4257 gcc_assert (sym
->attr
.dummy
|| as
->cp_was_assumed
);
4259 /* We should always pass assumed size arrays the g77 way. */
4260 if (sym
->attr
.dummy
)
4261 gfc_trans_g77_array (sym
, block
);
4264 case AS_ASSUMED_SHAPE
:
4265 /* Must be a dummy parameter. */
4266 gcc_assert (sym
->attr
.dummy
);
4268 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
4271 case AS_ASSUMED_RANK
:
4273 seen_trans_deferred_array
= true;
4274 gfc_trans_deferred_array (sym
, block
);
4275 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
4276 && sym
->attr
.result
)
4278 gfc_start_block (&init
);
4279 gfc_save_backend_locus (&loc
);
4280 gfc_set_backend_locus (&sym
->declared_at
);
4281 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4282 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4289 if (alloc_comp_or_fini
&& !seen_trans_deferred_array
)
4290 gfc_trans_deferred_array (sym
, block
);
4292 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4293 && (sym
->ts
.type
== BT_CLASS
4294 && CLASS_DATA (sym
)->attr
.class_pointer
))
4296 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
4297 && (sym
->attr
.allocatable
4298 || (sym
->attr
.pointer
&& sym
->attr
.result
)
4299 || (sym
->ts
.type
== BT_CLASS
4300 && CLASS_DATA (sym
)->attr
.allocatable
)))
4302 if (!sym
->attr
.save
&& flag_max_stack_var_size
!= 0)
4304 tree descriptor
= NULL_TREE
;
4306 gfc_save_backend_locus (&loc
);
4307 gfc_set_backend_locus (&sym
->declared_at
);
4308 gfc_start_block (&init
);
4310 if (!sym
->attr
.pointer
)
4312 /* Nullify and automatic deallocation of allocatable
4314 e
= gfc_lval_expr_from_sym (sym
);
4315 if (sym
->ts
.type
== BT_CLASS
)
4316 gfc_add_data_component (e
);
4318 gfc_init_se (&se
, NULL
);
4319 if (sym
->ts
.type
!= BT_CLASS
4320 || sym
->ts
.u
.derived
->attr
.dimension
4321 || sym
->ts
.u
.derived
->attr
.codimension
)
4323 se
.want_pointer
= 1;
4324 gfc_conv_expr (&se
, e
);
4326 else if (sym
->ts
.type
== BT_CLASS
4327 && !CLASS_DATA (sym
)->attr
.dimension
4328 && !CLASS_DATA (sym
)->attr
.codimension
)
4330 se
.want_pointer
= 1;
4331 gfc_conv_expr (&se
, e
);
4335 se
.descriptor_only
= 1;
4336 gfc_conv_expr (&se
, e
);
4337 descriptor
= se
.expr
;
4338 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
4339 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
4343 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
4345 /* Nullify when entering the scope. */
4346 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4347 TREE_TYPE (se
.expr
), se
.expr
,
4348 fold_convert (TREE_TYPE (se
.expr
),
4349 null_pointer_node
));
4350 if (sym
->attr
.optional
)
4352 tree present
= gfc_conv_expr_present (sym
);
4353 tmp
= build3_loc (input_location
, COND_EXPR
,
4354 void_type_node
, present
, tmp
,
4355 build_empty_stmt (input_location
));
4357 gfc_add_expr_to_block (&init
, tmp
);
4361 if ((sym
->attr
.dummy
|| sym
->attr
.result
)
4362 && sym
->ts
.type
== BT_CHARACTER
4364 && sym
->ts
.u
.cl
->passed_length
)
4365 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4367 gfc_restore_backend_locus (&loc
);
4369 /* Deallocate when leaving the scope. Nullifying is not
4371 if (!sym
->attr
.result
&& !sym
->attr
.dummy
&& !sym
->attr
.pointer
4372 && !sym
->ns
->proc_name
->attr
.is_main_program
)
4374 if (sym
->ts
.type
== BT_CLASS
4375 && CLASS_DATA (sym
)->attr
.codimension
)
4376 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
4377 NULL_TREE
, NULL_TREE
,
4378 NULL_TREE
, true, NULL
,
4382 gfc_expr
*expr
= gfc_lval_expr_from_sym (sym
);
4383 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, NULL_TREE
,
4384 true, expr
, sym
->ts
);
4385 gfc_free_expr (expr
);
4389 if (sym
->ts
.type
== BT_CLASS
)
4391 /* Initialize _vptr to declared type. */
4395 gfc_save_backend_locus (&loc
);
4396 gfc_set_backend_locus (&sym
->declared_at
);
4397 e
= gfc_lval_expr_from_sym (sym
);
4398 gfc_add_vptr_component (e
);
4399 gfc_init_se (&se
, NULL
);
4400 se
.want_pointer
= 1;
4401 gfc_conv_expr (&se
, e
);
4403 if (UNLIMITED_POLY (sym
))
4404 rhs
= build_int_cst (TREE_TYPE (se
.expr
), 0);
4407 vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
4408 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
4409 gfc_get_symbol_decl (vtab
));
4411 gfc_add_modify (&init
, se
.expr
, rhs
);
4412 gfc_restore_backend_locus (&loc
);
4415 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4418 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
4423 /* If we get to here, all that should be left are pointers. */
4424 gcc_assert (sym
->attr
.pointer
);
4426 if (sym
->attr
.dummy
)
4428 gfc_start_block (&init
);
4429 gfc_save_backend_locus (&loc
);
4430 gfc_set_backend_locus (&sym
->declared_at
);
4431 tmp
= gfc_null_and_pass_deferred_len (sym
, &init
, &loc
);
4432 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4435 else if (sym
->ts
.deferred
)
4436 gfc_fatal_error ("Deferred type parameter not yet supported");
4437 else if (alloc_comp_or_fini
)
4438 gfc_trans_deferred_array (sym
, block
);
4439 else if (sym
->ts
.type
== BT_CHARACTER
)
4441 gfc_save_backend_locus (&loc
);
4442 gfc_set_backend_locus (&sym
->declared_at
);
4443 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4444 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
4446 gfc_trans_auto_character_variable (sym
, block
);
4447 gfc_restore_backend_locus (&loc
);
4449 else if (sym
->attr
.assign
)
4451 gfc_save_backend_locus (&loc
);
4452 gfc_set_backend_locus (&sym
->declared_at
);
4453 gfc_trans_assign_aux_var (sym
, block
);
4454 gfc_restore_backend_locus (&loc
);
4456 else if (sym
->ts
.type
== BT_DERIVED
4459 && sym
->attr
.save
== SAVE_NONE
)
4461 gfc_start_block (&tmpblock
);
4462 gfc_init_default_dt (sym
, &tmpblock
, false);
4463 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4466 else if (!(UNLIMITED_POLY(sym
)))
4470 gfc_init_block (&tmpblock
);
4472 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
4474 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
4476 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4477 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4478 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
4482 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
4483 && current_fake_result_decl
!= NULL
)
4485 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4486 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4487 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
4490 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
4494 struct module_hasher
: ggc_ptr_hash
<module_htab_entry
>
4496 typedef const char *compare_type
;
4498 static hashval_t
hash (module_htab_entry
*s
) { return htab_hash_string (s
); }
4500 equal (module_htab_entry
*a
, const char *b
)
4502 return !strcmp (a
->name
, b
);
4506 static GTY (()) hash_table
<module_hasher
> *module_htab
;
4508 /* Hash and equality functions for module_htab's decls. */
4511 module_decl_hasher::hash (tree t
)
4513 const_tree n
= DECL_NAME (t
);
4515 n
= TYPE_NAME (TREE_TYPE (t
));
4516 return htab_hash_string (IDENTIFIER_POINTER (n
));
4520 module_decl_hasher::equal (tree t1
, const char *x2
)
4522 const_tree n1
= DECL_NAME (t1
);
4523 if (n1
== NULL_TREE
)
4524 n1
= TYPE_NAME (TREE_TYPE (t1
));
4525 return strcmp (IDENTIFIER_POINTER (n1
), x2
) == 0;
4528 struct module_htab_entry
*
4529 gfc_find_module (const char *name
)
4532 module_htab
= hash_table
<module_hasher
>::create_ggc (10);
4534 module_htab_entry
**slot
4535 = module_htab
->find_slot_with_hash (name
, htab_hash_string (name
), INSERT
);
4538 module_htab_entry
*entry
= ggc_cleared_alloc
<module_htab_entry
> ();
4540 entry
->name
= gfc_get_string (name
);
4541 entry
->decls
= hash_table
<module_decl_hasher
>::create_ggc (10);
4548 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
4552 if (DECL_NAME (decl
))
4553 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
4556 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
4557 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
4560 = entry
->decls
->find_slot_with_hash (name
, htab_hash_string (name
),
4567 /* Generate debugging symbols for namelists. This function must come after
4568 generate_local_decl to ensure that the variables in the namelist are
4569 already declared. */
4572 generate_namelist_decl (gfc_symbol
* sym
)
4576 vec
<constructor_elt
, va_gc
> *nml_decls
= NULL
;
4578 gcc_assert (sym
->attr
.flavor
== FL_NAMELIST
);
4579 for (nml
= sym
->namelist
; nml
; nml
= nml
->next
)
4581 if (nml
->sym
->backend_decl
== NULL_TREE
)
4583 nml
->sym
->attr
.referenced
= 1;
4584 nml
->sym
->backend_decl
= gfc_get_symbol_decl (nml
->sym
);
4586 DECL_IGNORED_P (nml
->sym
->backend_decl
) = 0;
4587 CONSTRUCTOR_APPEND_ELT (nml_decls
, NULL_TREE
, nml
->sym
->backend_decl
);
4590 decl
= make_node (NAMELIST_DECL
);
4591 TREE_TYPE (decl
) = void_type_node
;
4592 NAMELIST_DECL_ASSOCIATED_DECL (decl
) = build_constructor (NULL_TREE
, nml_decls
);
4593 DECL_NAME (decl
) = get_identifier (sym
->name
);
4598 /* Output an initialized decl for a module variable. */
4601 gfc_create_module_variable (gfc_symbol
* sym
)
4605 /* Module functions with alternate entries are dealt with later and
4606 would get caught by the next condition. */
4607 if (sym
->attr
.entry
)
4610 /* Make sure we convert the types of the derived types from iso_c_binding
4612 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4613 && sym
->ts
.type
== BT_DERIVED
)
4614 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4616 if (gfc_fl_struct (sym
->attr
.flavor
)
4617 && sym
->backend_decl
4618 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
4620 decl
= sym
->backend_decl
;
4621 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4623 if (!sym
->attr
.use_assoc
&& !sym
->attr
.used_in_submodule
)
4625 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
4626 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
4627 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
4628 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
4629 == sym
->ns
->proc_name
->backend_decl
);
4631 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4632 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
4633 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
4636 /* Only output variables, procedure pointers and array valued,
4637 or derived type, parameters. */
4638 if (sym
->attr
.flavor
!= FL_VARIABLE
4639 && !(sym
->attr
.flavor
== FL_PARAMETER
4640 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
4641 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4644 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
4646 decl
= sym
->backend_decl
;
4647 gcc_assert (DECL_FILE_SCOPE_P (decl
));
4648 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4649 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4650 gfc_module_add_decl (cur_module
, decl
);
4653 /* Don't generate variables from other modules. Variables from
4654 COMMONs and Cray pointees will already have been generated. */
4655 if (sym
->attr
.use_assoc
|| sym
->attr
.used_in_submodule
4656 || sym
->attr
.in_common
|| sym
->attr
.cray_pointee
)
4659 /* Equivalenced variables arrive here after creation. */
4660 if (sym
->backend_decl
4661 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
4664 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
4665 gfc_internal_error ("backend decl for module variable %qs already exists",
4668 if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
4669 && (sym
->attr
.access
== ACCESS_UNKNOWN
4670 && (sym
->ns
->default_access
== ACCESS_PRIVATE
4671 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
4672 && flag_module_private
))))
4673 sym
->attr
.access
= ACCESS_PRIVATE
;
4675 if (warn_unused_variable
&& !sym
->attr
.referenced
4676 && sym
->attr
.access
== ACCESS_PRIVATE
)
4677 gfc_warning (OPT_Wunused_value
,
4678 "Unused PRIVATE module variable %qs declared at %L",
4679 sym
->name
, &sym
->declared_at
);
4681 /* We always want module variables to be created. */
4682 sym
->attr
.referenced
= 1;
4683 /* Create the decl. */
4684 decl
= gfc_get_symbol_decl (sym
);
4686 /* Create the variable. */
4688 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4689 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4690 rest_of_decl_compilation (decl
, 1, 0);
4691 gfc_module_add_decl (cur_module
, decl
);
4693 /* Also add length of strings. */
4694 if (sym
->ts
.type
== BT_CHARACTER
)
4698 length
= sym
->ts
.u
.cl
->backend_decl
;
4699 gcc_assert (length
|| sym
->attr
.proc_pointer
);
4700 if (length
&& !INTEGER_CST_P (length
))
4703 rest_of_decl_compilation (length
, 1, 0);
4707 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4708 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4709 has_coarray_vars
= true;
4712 /* Emit debug information for USE statements. */
4715 gfc_trans_use_stmts (gfc_namespace
* ns
)
4717 gfc_use_list
*use_stmt
;
4718 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
4720 struct module_htab_entry
*entry
4721 = gfc_find_module (use_stmt
->module_name
);
4722 gfc_use_rename
*rent
;
4724 if (entry
->namespace_decl
== NULL
)
4726 entry
->namespace_decl
4727 = build_decl (input_location
,
4729 get_identifier (use_stmt
->module_name
),
4731 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
4733 gfc_set_backend_locus (&use_stmt
->where
);
4734 if (!use_stmt
->only_flag
)
4735 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
4737 ns
->proc_name
->backend_decl
,
4739 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
4741 tree decl
, local_name
;
4743 if (rent
->op
!= INTRINSIC_NONE
)
4746 hashval_t hash
= htab_hash_string (rent
->use_name
);
4747 tree
*slot
= entry
->decls
->find_slot_with_hash (rent
->use_name
, hash
,
4753 st
= gfc_find_symtree (ns
->sym_root
,
4755 ? rent
->local_name
: rent
->use_name
);
4757 /* The following can happen if a derived type is renamed. */
4761 name
= xstrdup (rent
->local_name
[0]
4762 ? rent
->local_name
: rent
->use_name
);
4763 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
4764 st
= gfc_find_symtree (ns
->sym_root
, name
);
4769 /* Sometimes, generic interfaces wind up being over-ruled by a
4770 local symbol (see PR41062). */
4771 if (!st
->n
.sym
->attr
.use_assoc
)
4774 if (st
->n
.sym
->backend_decl
4775 && DECL_P (st
->n
.sym
->backend_decl
)
4776 && st
->n
.sym
->module
4777 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
4779 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
4780 || (TREE_CODE (st
->n
.sym
->backend_decl
)
4782 decl
= copy_node (st
->n
.sym
->backend_decl
);
4783 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4784 DECL_EXTERNAL (decl
) = 1;
4785 DECL_IGNORED_P (decl
) = 0;
4786 DECL_INITIAL (decl
) = NULL_TREE
;
4788 else if (st
->n
.sym
->attr
.flavor
== FL_NAMELIST
4789 && st
->n
.sym
->attr
.use_only
4790 && st
->n
.sym
->module
4791 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
)
4794 decl
= generate_namelist_decl (st
->n
.sym
);
4795 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4796 DECL_EXTERNAL (decl
) = 1;
4797 DECL_IGNORED_P (decl
) = 0;
4798 DECL_INITIAL (decl
) = NULL_TREE
;
4802 *slot
= error_mark_node
;
4803 entry
->decls
->clear_slot (slot
);
4808 decl
= (tree
) *slot
;
4809 if (rent
->local_name
[0])
4810 local_name
= get_identifier (rent
->local_name
);
4812 local_name
= NULL_TREE
;
4813 gfc_set_backend_locus (&rent
->where
);
4814 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
4815 ns
->proc_name
->backend_decl
,
4816 !use_stmt
->only_flag
);
4822 /* Return true if expr is a constant initializer that gfc_conv_initializer
4826 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
4836 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
4838 else if (expr
->expr_type
== EXPR_STRUCTURE
)
4839 return check_constant_initializer (expr
, ts
, false, false);
4840 else if (expr
->expr_type
!= EXPR_ARRAY
)
4842 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4843 c
; c
= gfc_constructor_next (c
))
4847 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
4849 if (!check_constant_initializer (c
->expr
, ts
, false, false))
4852 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4857 else switch (ts
->type
)
4860 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4862 cm
= expr
->ts
.u
.derived
->components
;
4863 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4864 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4866 if (!c
->expr
|| cm
->attr
.allocatable
)
4868 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
4875 return expr
->expr_type
== EXPR_CONSTANT
;
4879 /* Emit debug info for parameters and unreferenced variables with
4883 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
4887 if (sym
->attr
.flavor
!= FL_PARAMETER
4888 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
4891 if (sym
->backend_decl
!= NULL
4892 || sym
->value
== NULL
4893 || sym
->attr
.use_assoc
4896 || sym
->attr
.function
4897 || sym
->attr
.intrinsic
4898 || sym
->attr
.pointer
4899 || sym
->attr
.allocatable
4900 || sym
->attr
.cray_pointee
4901 || sym
->attr
.threadprivate
4902 || sym
->attr
.is_bind_c
4903 || sym
->attr
.subref_array_pointer
4904 || sym
->attr
.assign
)
4907 if (sym
->ts
.type
== BT_CHARACTER
)
4909 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4910 if (sym
->ts
.u
.cl
->backend_decl
== NULL
4911 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
4914 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
4921 if (sym
->as
->type
!= AS_EXPLICIT
)
4923 for (n
= 0; n
< sym
->as
->rank
; n
++)
4924 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
4925 || sym
->as
->upper
[n
] == NULL
4926 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
4930 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
4931 sym
->attr
.dimension
, false))
4934 if (flag_coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
4937 /* Create the decl for the variable or constant. */
4938 decl
= build_decl (input_location
,
4939 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
4940 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
4941 if (sym
->attr
.flavor
== FL_PARAMETER
)
4942 TREE_READONLY (decl
) = 1;
4943 gfc_set_decl_location (decl
, &sym
->declared_at
);
4944 if (sym
->attr
.dimension
)
4945 GFC_DECL_PACKED_ARRAY (decl
) = 1;
4946 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4947 TREE_STATIC (decl
) = 1;
4948 TREE_USED (decl
) = 1;
4949 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
4950 TREE_PUBLIC (decl
) = 1;
4951 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
4953 sym
->attr
.dimension
,
4955 debug_hooks
->early_global_decl (decl
);
4960 generate_coarray_sym_init (gfc_symbol
*sym
)
4962 tree tmp
, size
, decl
, token
;
4963 bool is_lock_type
, is_event_type
;
4966 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
4967 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
4968 || sym
->attr
.select_type_temporary
)
4971 decl
= sym
->backend_decl
;
4972 TREE_USED(decl
) = 1;
4973 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
4975 is_lock_type
= sym
->ts
.type
== BT_DERIVED
4976 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4977 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
;
4979 is_event_type
= sym
->ts
.type
== BT_DERIVED
4980 && sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4981 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
;
4983 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4984 to make sure the variable is not optimized away. */
4985 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
4987 /* For lock types, we pass the array size as only the library knows the
4988 size of the variable. */
4989 if (is_lock_type
|| is_event_type
)
4990 size
= gfc_index_one_node
;
4992 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
4994 /* Ensure that we do not have size=0 for zero-sized arrays. */
4995 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
4996 fold_convert (size_type_node
, size
),
4997 build_int_cst (size_type_node
, 1));
4999 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
5001 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
5002 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
5003 fold_convert (size_type_node
, tmp
), size
);
5006 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
5007 token
= gfc_build_addr_expr (ppvoid_type_node
,
5008 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
5010 reg_type
= sym
->attr
.artificial
? GFC_CAF_CRITICAL
: GFC_CAF_LOCK_STATIC
;
5011 else if (is_event_type
)
5012 reg_type
= GFC_CAF_EVENT_STATIC
;
5014 reg_type
= GFC_CAF_COARRAY_STATIC
;
5015 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 6, size
,
5016 build_int_cst (integer_type_node
, reg_type
),
5017 token
, null_pointer_node
, /* token, stat. */
5018 null_pointer_node
, /* errgmsg, errmsg_len. */
5019 build_int_cst (integer_type_node
, 0));
5020 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
), tmp
));
5022 /* Handle "static" initializer. */
5025 sym
->attr
.pointer
= 1;
5026 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
5028 sym
->attr
.pointer
= 0;
5029 gfc_add_expr_to_block (&caf_init_block
, tmp
);
5034 /* Generate constructor function to initialize static, nonallocatable
5038 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
5040 tree fndecl
, tmp
, decl
, save_fn_decl
;
5042 save_fn_decl
= current_function_decl
;
5043 push_function_context ();
5045 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
5046 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
5047 create_tmp_var_name ("_caf_init"), tmp
);
5049 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
5050 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
5052 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
5053 DECL_ARTIFICIAL (decl
) = 1;
5054 DECL_IGNORED_P (decl
) = 1;
5055 DECL_CONTEXT (decl
) = fndecl
;
5056 DECL_RESULT (fndecl
) = decl
;
5059 current_function_decl
= fndecl
;
5060 announce_function (fndecl
);
5062 rest_of_decl_compilation (fndecl
, 0, 0);
5063 make_decl_rtl (fndecl
);
5064 allocate_struct_function (fndecl
, false);
5067 gfc_init_block (&caf_init_block
);
5069 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
5071 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
5075 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5077 DECL_SAVED_TREE (fndecl
)
5078 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5079 DECL_INITIAL (fndecl
));
5080 dump_function (TDI_original
, fndecl
);
5082 cfun
->function_end_locus
= input_location
;
5085 if (decl_function_context (fndecl
))
5086 (void) cgraph_node::create (fndecl
);
5088 cgraph_node::finalize_function (fndecl
, true);
5090 pop_function_context ();
5091 current_function_decl
= save_fn_decl
;
5096 create_module_nml_decl (gfc_symbol
*sym
)
5098 if (sym
->attr
.flavor
== FL_NAMELIST
)
5100 tree decl
= generate_namelist_decl (sym
);
5102 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
5103 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
5104 rest_of_decl_compilation (decl
, 1, 0);
5105 gfc_module_add_decl (cur_module
, decl
);
5110 /* Generate all the required code for module variables. */
5113 gfc_generate_module_vars (gfc_namespace
* ns
)
5115 module_namespace
= ns
;
5116 cur_module
= gfc_find_module (ns
->proc_name
->name
);
5118 /* Check if the frontend left the namespace in a reasonable state. */
5119 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
5121 /* Generate COMMON blocks. */
5122 gfc_trans_common (ns
);
5124 has_coarray_vars
= false;
5126 /* Create decls for all the module variables. */
5127 gfc_traverse_ns (ns
, gfc_create_module_variable
);
5128 gfc_traverse_ns (ns
, create_module_nml_decl
);
5130 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5131 generate_coarray_init (ns
);
5135 gfc_trans_use_stmts (ns
);
5136 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5141 gfc_generate_contained_functions (gfc_namespace
* parent
)
5145 /* We create all the prototypes before generating any code. */
5146 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5148 /* Skip namespaces from used modules. */
5149 if (ns
->parent
!= parent
)
5152 gfc_create_function_decl (ns
, false);
5155 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
5157 /* Skip namespaces from used modules. */
5158 if (ns
->parent
!= parent
)
5161 gfc_generate_function_code (ns
);
5166 /* Drill down through expressions for the array specification bounds and
5167 character length calling generate_local_decl for all those variables
5168 that have not already been declared. */
5171 generate_local_decl (gfc_symbol
*);
5173 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5176 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
5177 int *f ATTRIBUTE_UNUSED
)
5179 if (e
->expr_type
!= EXPR_VARIABLE
5180 || sym
== e
->symtree
->n
.sym
5181 || e
->symtree
->n
.sym
->mark
5182 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
5185 generate_local_decl (e
->symtree
->n
.sym
);
5190 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
5192 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
5196 /* Check for dependencies in the character length and array spec. */
5199 generate_dependency_declarations (gfc_symbol
*sym
)
5203 if (sym
->ts
.type
== BT_CHARACTER
5205 && sym
->ts
.u
.cl
->length
5206 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5207 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
5209 if (sym
->as
&& sym
->as
->rank
)
5211 for (i
= 0; i
< sym
->as
->rank
; i
++)
5213 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
5214 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
5220 /* Generate decls for all local variables. We do this to ensure correct
5221 handling of expressions which only appear in the specification of
5225 generate_local_decl (gfc_symbol
* sym
)
5227 if (sym
->attr
.flavor
== FL_VARIABLE
)
5229 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
5230 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
5231 has_coarray_vars
= true;
5233 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
5234 generate_dependency_declarations (sym
);
5236 if (sym
->attr
.referenced
)
5237 gfc_get_symbol_decl (sym
);
5239 /* Warnings for unused dummy arguments. */
5240 else if (sym
->attr
.dummy
&& !sym
->attr
.in_namelist
)
5242 /* INTENT(out) dummy arguments are likely meant to be set. */
5243 if (warn_unused_dummy_argument
&& sym
->attr
.intent
== INTENT_OUT
)
5245 if (sym
->ts
.type
!= BT_DERIVED
)
5246 gfc_warning (OPT_Wunused_dummy_argument
,
5247 "Dummy argument %qs at %L was declared "
5248 "INTENT(OUT) but was not set", sym
->name
,
5250 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
)
5251 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
5252 gfc_warning (OPT_Wunused_dummy_argument
,
5253 "Derived-type dummy argument %qs at %L was "
5254 "declared INTENT(OUT) but was not set and "
5255 "does not have a default initializer",
5256 sym
->name
, &sym
->declared_at
);
5257 if (sym
->backend_decl
!= NULL_TREE
)
5258 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5260 else if (warn_unused_dummy_argument
)
5262 gfc_warning (OPT_Wunused_dummy_argument
,
5263 "Unused dummy argument %qs at %L", sym
->name
,
5265 if (sym
->backend_decl
!= NULL_TREE
)
5266 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5270 /* Warn for unused variables, but not if they're inside a common
5271 block or a namelist. */
5272 else if (warn_unused_variable
5273 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
5275 if (sym
->attr
.use_only
)
5277 gfc_warning (OPT_Wunused_variable
,
5278 "Unused module variable %qs which has been "
5279 "explicitly imported at %L", sym
->name
,
5281 if (sym
->backend_decl
!= NULL_TREE
)
5282 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5284 else if (!sym
->attr
.use_assoc
)
5286 gfc_warning (OPT_Wunused_variable
,
5287 "Unused variable %qs declared at %L",
5288 sym
->name
, &sym
->declared_at
);
5289 if (sym
->backend_decl
!= NULL_TREE
)
5290 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5294 /* For variable length CHARACTER parameters, the PARM_DECL already
5295 references the length variable, so force gfc_get_symbol_decl
5296 even when not referenced. If optimize > 0, it will be optimized
5297 away anyway. But do this only after emitting -Wunused-parameter
5298 warning if requested. */
5299 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
5300 && sym
->ts
.type
== BT_CHARACTER
5301 && sym
->ts
.u
.cl
->backend_decl
!= NULL
5302 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
5304 sym
->attr
.referenced
= 1;
5305 gfc_get_symbol_decl (sym
);
5308 /* INTENT(out) dummy arguments and result variables with allocatable
5309 components are reset by default and need to be set referenced to
5310 generate the code for nullification and automatic lengths. */
5311 if (!sym
->attr
.referenced
5312 && sym
->ts
.type
== BT_DERIVED
5313 && sym
->ts
.u
.derived
->attr
.alloc_comp
5314 && !sym
->attr
.pointer
5315 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
5317 (sym
->attr
.result
&& sym
!= sym
->result
)))
5319 sym
->attr
.referenced
= 1;
5320 gfc_get_symbol_decl (sym
);
5323 /* Check for dependencies in the array specification and string
5324 length, adding the necessary declarations to the function. We
5325 mark the symbol now, as well as in traverse_ns, to prevent
5326 getting stuck in a circular dependency. */
5329 else if (sym
->attr
.flavor
== FL_PARAMETER
)
5331 if (warn_unused_parameter
5332 && !sym
->attr
.referenced
)
5334 if (!sym
->attr
.use_assoc
)
5335 gfc_warning (OPT_Wunused_parameter
,
5336 "Unused parameter %qs declared at %L", sym
->name
,
5338 else if (sym
->attr
.use_only
)
5339 gfc_warning (OPT_Wunused_parameter
,
5340 "Unused parameter %qs which has been explicitly "
5341 "imported at %L", sym
->name
, &sym
->declared_at
);
5346 && sym
->ns
->parent
->code
5347 && sym
->ns
->parent
->code
->op
== EXEC_BLOCK
)
5349 if (sym
->attr
.referenced
)
5350 gfc_get_symbol_decl (sym
);
5354 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
5356 /* TODO: move to the appropriate place in resolve.c. */
5357 if (warn_return_type
5358 && sym
->attr
.function
5360 && sym
!= sym
->result
5361 && !sym
->result
->attr
.referenced
5362 && !sym
->attr
.use_assoc
5363 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
5365 gfc_warning (OPT_Wreturn_type
,
5366 "Return value %qs of function %qs declared at "
5367 "%L not set", sym
->result
->name
, sym
->name
,
5368 &sym
->result
->declared_at
);
5370 /* Prevents "Unused variable" warning for RESULT variables. */
5371 sym
->result
->mark
= 1;
5375 if (sym
->attr
.dummy
== 1)
5377 /* Modify the tree type for scalar character dummy arguments of bind(c)
5378 procedures if they are passed by value. The tree type for them will
5379 be promoted to INTEGER_TYPE for the middle end, which appears to be
5380 what C would do with characters passed by-value. The value attribute
5381 implies the dummy is a scalar. */
5382 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
5383 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
5384 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
5385 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
5387 /* Unused procedure passed as dummy argument. */
5388 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5390 if (!sym
->attr
.referenced
)
5392 if (warn_unused_dummy_argument
)
5393 gfc_warning (OPT_Wunused_dummy_argument
,
5394 "Unused dummy argument %qs at %L", sym
->name
,
5398 /* Silence bogus "unused parameter" warnings from the
5400 if (sym
->backend_decl
!= NULL_TREE
)
5401 TREE_NO_WARNING (sym
->backend_decl
) = 1;
5405 /* Make sure we convert the types of the derived types from iso_c_binding
5407 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
5408 && sym
->ts
.type
== BT_DERIVED
)
5409 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
5414 generate_local_nml_decl (gfc_symbol
* sym
)
5416 if (sym
->attr
.flavor
== FL_NAMELIST
&& !sym
->attr
.use_assoc
)
5418 tree decl
= generate_namelist_decl (sym
);
5425 generate_local_vars (gfc_namespace
* ns
)
5427 gfc_traverse_ns (ns
, generate_local_decl
);
5428 gfc_traverse_ns (ns
, generate_local_nml_decl
);
5432 /* Generate a switch statement to jump to the correct entry point. Also
5433 creates the label decls for the entry points. */
5436 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
5443 gfc_init_block (&block
);
5444 for (; el
; el
= el
->next
)
5446 /* Add the case label. */
5447 label
= gfc_build_label_decl (NULL_TREE
);
5448 val
= build_int_cst (gfc_array_index_type
, el
->id
);
5449 tmp
= build_case_label (val
, NULL_TREE
, label
);
5450 gfc_add_expr_to_block (&block
, tmp
);
5452 /* And jump to the actual entry point. */
5453 label
= gfc_build_label_decl (NULL_TREE
);
5454 tmp
= build1_v (GOTO_EXPR
, label
);
5455 gfc_add_expr_to_block (&block
, tmp
);
5457 /* Save the label decl. */
5460 tmp
= gfc_finish_block (&block
);
5461 /* The first argument selects the entry point. */
5462 val
= DECL_ARGUMENTS (current_function_decl
);
5463 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
5464 val
, tmp
, NULL_TREE
);
5469 /* Add code to string lengths of actual arguments passed to a function against
5470 the expected lengths of the dummy arguments. */
5473 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
5475 gfc_formal_arglist
*formal
;
5477 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
5478 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
5479 && !formal
->sym
->ts
.deferred
)
5481 enum tree_code comparison
;
5486 const char *message
;
5492 gcc_assert (cl
->passed_length
!= NULL_TREE
);
5493 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
5495 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5496 string lengths must match exactly. Otherwise, it is only required
5497 that the actual string length is *at least* the expected one.
5498 Sequence association allows for a mismatch of the string length
5499 if the actual argument is (part of) an array, but only if the
5500 dummy argument is an array. (See "Sequence association" in
5501 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5502 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
5503 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
5504 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
5506 comparison
= NE_EXPR
;
5507 message
= _("Actual string length does not match the declared one"
5508 " for dummy argument '%s' (%ld/%ld)");
5510 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
5514 comparison
= LT_EXPR
;
5515 message
= _("Actual string length is shorter than the declared one"
5516 " for dummy argument '%s' (%ld/%ld)");
5519 /* Build the condition. For optional arguments, an actual length
5520 of 0 is also acceptable if the associated string is NULL, which
5521 means the argument was not passed. */
5522 cond
= fold_build2_loc (input_location
, comparison
, boolean_type_node
,
5523 cl
->passed_length
, cl
->backend_decl
);
5524 if (fsym
->attr
.optional
)
5530 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
5533 build_zero_cst (gfc_charlen_type_node
));
5534 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5535 fsym
->attr
.referenced
= 1;
5536 not_absent
= gfc_conv_expr_present (fsym
);
5538 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5539 boolean_type_node
, not_0length
,
5542 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5543 boolean_type_node
, cond
, absent_failed
);
5546 /* Build the runtime check. */
5547 argname
= gfc_build_cstring_const (fsym
->name
);
5548 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
5549 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
5551 fold_convert (long_integer_type_node
,
5553 fold_convert (long_integer_type_node
,
5560 create_main_function (tree fndecl
)
5564 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
5567 old_context
= current_function_decl
;
5571 push_function_context ();
5572 saved_parent_function_decls
= saved_function_decls
;
5573 saved_function_decls
= NULL_TREE
;
5576 /* main() function must be declared with global scope. */
5577 gcc_assert (current_function_decl
== NULL_TREE
);
5579 /* Declare the function. */
5580 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
5581 build_pointer_type (pchar_type_node
),
5583 main_identifier_node
= get_identifier ("main");
5584 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
5585 main_identifier_node
, tmp
);
5586 DECL_EXTERNAL (ftn_main
) = 0;
5587 TREE_PUBLIC (ftn_main
) = 1;
5588 TREE_STATIC (ftn_main
) = 1;
5589 DECL_ATTRIBUTES (ftn_main
)
5590 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
5592 /* Setup the result declaration (for "return 0"). */
5593 result_decl
= build_decl (input_location
,
5594 RESULT_DECL
, NULL_TREE
, integer_type_node
);
5595 DECL_ARTIFICIAL (result_decl
) = 1;
5596 DECL_IGNORED_P (result_decl
) = 1;
5597 DECL_CONTEXT (result_decl
) = ftn_main
;
5598 DECL_RESULT (ftn_main
) = result_decl
;
5600 pushdecl (ftn_main
);
5602 /* Get the arguments. */
5604 arglist
= NULL_TREE
;
5605 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
5607 tmp
= TREE_VALUE (typelist
);
5608 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
5609 DECL_CONTEXT (argc
) = ftn_main
;
5610 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
5611 TREE_READONLY (argc
) = 1;
5612 gfc_finish_decl (argc
);
5613 arglist
= chainon (arglist
, argc
);
5615 typelist
= TREE_CHAIN (typelist
);
5616 tmp
= TREE_VALUE (typelist
);
5617 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
5618 DECL_CONTEXT (argv
) = ftn_main
;
5619 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
5620 TREE_READONLY (argv
) = 1;
5621 DECL_BY_REFERENCE (argv
) = 1;
5622 gfc_finish_decl (argv
);
5623 arglist
= chainon (arglist
, argv
);
5625 DECL_ARGUMENTS (ftn_main
) = arglist
;
5626 current_function_decl
= ftn_main
;
5627 announce_function (ftn_main
);
5629 rest_of_decl_compilation (ftn_main
, 1, 0);
5630 make_decl_rtl (ftn_main
);
5631 allocate_struct_function (ftn_main
, false);
5634 gfc_init_block (&body
);
5636 /* Call some libgfortran initialization routines, call then MAIN__(). */
5638 /* Call _gfortran_caf_init (*argc, ***argv). */
5639 if (flag_coarray
== GFC_FCOARRAY_LIB
)
5641 tree pint_type
, pppchar_type
;
5642 pint_type
= build_pointer_type (integer_type_node
);
5644 = build_pointer_type (build_pointer_type (pchar_type_node
));
5646 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 2,
5647 gfc_build_addr_expr (pint_type
, argc
),
5648 gfc_build_addr_expr (pppchar_type
, argv
));
5649 gfc_add_expr_to_block (&body
, tmp
);
5652 /* Call _gfortran_set_args (argc, argv). */
5653 TREE_USED (argc
) = 1;
5654 TREE_USED (argv
) = 1;
5655 tmp
= build_call_expr_loc (input_location
,
5656 gfor_fndecl_set_args
, 2, argc
, argv
);
5657 gfc_add_expr_to_block (&body
, tmp
);
5659 /* Add a call to set_options to set up the runtime library Fortran
5660 language standard parameters. */
5662 tree array_type
, array
, var
;
5663 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5665 /* Passing a new option to the library requires four modifications:
5666 + add it to the tree_cons list below
5667 + change the array size in the call to build_array_type
5668 + change the first argument to the library call
5669 gfor_fndecl_set_options
5670 + modify the library (runtime/compile_options.c)! */
5672 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5673 build_int_cst (integer_type_node
,
5674 gfc_option
.warn_std
));
5675 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5676 build_int_cst (integer_type_node
,
5677 gfc_option
.allow_std
));
5678 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5679 build_int_cst (integer_type_node
, pedantic
));
5680 /* TODO: This is the old -fdump-core option, which is unused but
5681 passed due to ABI compatibility; remove when bumping the
5683 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5684 build_int_cst (integer_type_node
,
5686 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5687 build_int_cst (integer_type_node
, flag_backtrace
));
5688 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5689 build_int_cst (integer_type_node
, flag_sign_zero
));
5690 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5691 build_int_cst (integer_type_node
,
5693 & GFC_RTCHECK_BOUNDS
)));
5694 /* TODO: This is the -frange-check option, which no longer affects
5695 library behavior; when bumping the library ABI this slot can be
5696 reused for something else. As it is the last element in the
5697 array, we can instead leave it out altogether. */
5698 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5699 build_int_cst (integer_type_node
, 0));
5700 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5701 build_int_cst (integer_type_node
,
5702 gfc_option
.fpe_summary
));
5704 array_type
= build_array_type (integer_type_node
,
5705 build_index_type (size_int (8)));
5706 array
= build_constructor (array_type
, v
);
5707 TREE_CONSTANT (array
) = 1;
5708 TREE_STATIC (array
) = 1;
5710 /* Create a static variable to hold the jump table. */
5711 var
= build_decl (input_location
, VAR_DECL
,
5712 create_tmp_var_name ("options"),
5714 DECL_ARTIFICIAL (var
) = 1;
5715 DECL_IGNORED_P (var
) = 1;
5716 TREE_CONSTANT (var
) = 1;
5717 TREE_STATIC (var
) = 1;
5718 TREE_READONLY (var
) = 1;
5719 DECL_INITIAL (var
) = array
;
5721 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
5723 tmp
= build_call_expr_loc (input_location
,
5724 gfor_fndecl_set_options
, 2,
5725 build_int_cst (integer_type_node
, 9), var
);
5726 gfc_add_expr_to_block (&body
, tmp
);
5729 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5730 the library will raise a FPE when needed. */
5731 if (gfc_option
.fpe
!= 0)
5733 tmp
= build_call_expr_loc (input_location
,
5734 gfor_fndecl_set_fpe
, 1,
5735 build_int_cst (integer_type_node
,
5737 gfc_add_expr_to_block (&body
, tmp
);
5740 /* If this is the main program and an -fconvert option was provided,
5741 add a call to set_convert. */
5743 if (flag_convert
!= GFC_FLAG_CONVERT_NATIVE
)
5745 tmp
= build_call_expr_loc (input_location
,
5746 gfor_fndecl_set_convert
, 1,
5747 build_int_cst (integer_type_node
, flag_convert
));
5748 gfc_add_expr_to_block (&body
, tmp
);
5751 /* If this is the main program and an -frecord-marker option was provided,
5752 add a call to set_record_marker. */
5754 if (flag_record_marker
!= 0)
5756 tmp
= build_call_expr_loc (input_location
,
5757 gfor_fndecl_set_record_marker
, 1,
5758 build_int_cst (integer_type_node
,
5759 flag_record_marker
));
5760 gfc_add_expr_to_block (&body
, tmp
);
5763 if (flag_max_subrecord_length
!= 0)
5765 tmp
= build_call_expr_loc (input_location
,
5766 gfor_fndecl_set_max_subrecord_length
, 1,
5767 build_int_cst (integer_type_node
,
5768 flag_max_subrecord_length
));
5769 gfc_add_expr_to_block (&body
, tmp
);
5772 /* Call MAIN__(). */
5773 tmp
= build_call_expr_loc (input_location
,
5775 gfc_add_expr_to_block (&body
, tmp
);
5777 /* Mark MAIN__ as used. */
5778 TREE_USED (fndecl
) = 1;
5780 /* Coarray: Call _gfortran_caf_finalize(void). */
5781 if (flag_coarray
== GFC_FCOARRAY_LIB
)
5783 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
5784 gfc_add_expr_to_block (&body
, tmp
);
5788 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
5789 DECL_RESULT (ftn_main
),
5790 build_int_cst (integer_type_node
, 0));
5791 tmp
= build1_v (RETURN_EXPR
, tmp
);
5792 gfc_add_expr_to_block (&body
, tmp
);
5795 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
5798 /* Finish off this function and send it for code generation. */
5800 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
5802 DECL_SAVED_TREE (ftn_main
)
5803 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
5804 DECL_INITIAL (ftn_main
));
5806 /* Output the GENERIC tree. */
5807 dump_function (TDI_original
, ftn_main
);
5809 cgraph_node::finalize_function (ftn_main
, true);
5813 pop_function_context ();
5814 saved_function_decls
= saved_parent_function_decls
;
5816 current_function_decl
= old_context
;
5820 /* Get the result expression for a procedure. */
5823 get_proc_result (gfc_symbol
* sym
)
5825 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
5827 if (current_fake_result_decl
!= NULL
)
5828 return TREE_VALUE (current_fake_result_decl
);
5833 return sym
->result
->backend_decl
;
5837 /* Generate an appropriate return-statement for a procedure. */
5840 gfc_generate_return (void)
5846 sym
= current_procedure_symbol
;
5847 fndecl
= sym
->backend_decl
;
5849 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
5853 result
= get_proc_result (sym
);
5855 /* Set the return value to the dummy result variable. The
5856 types may be different for scalar default REAL functions
5857 with -ff2c, therefore we have to convert. */
5858 if (result
!= NULL_TREE
)
5860 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
5861 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5862 TREE_TYPE (result
), DECL_RESULT (fndecl
),
5867 return build1_v (RETURN_EXPR
, result
);
5872 is_from_ieee_module (gfc_symbol
*sym
)
5874 if (sym
->from_intmod
== INTMOD_IEEE_FEATURES
5875 || sym
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
5876 || sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
5877 seen_ieee_symbol
= 1;
5882 is_ieee_module_used (gfc_namespace
*ns
)
5884 seen_ieee_symbol
= 0;
5885 gfc_traverse_ns (ns
, is_from_ieee_module
);
5886 return seen_ieee_symbol
;
5890 static gfc_omp_clauses
*module_oacc_clauses
;
5894 add_clause (gfc_symbol
*sym
, gfc_omp_map_op map_op
)
5896 gfc_omp_namelist
*n
;
5898 n
= gfc_get_omp_namelist ();
5900 n
->u
.map_op
= map_op
;
5902 if (!module_oacc_clauses
)
5903 module_oacc_clauses
= gfc_get_omp_clauses ();
5905 if (module_oacc_clauses
->lists
[OMP_LIST_MAP
])
5906 n
->next
= module_oacc_clauses
->lists
[OMP_LIST_MAP
];
5908 module_oacc_clauses
->lists
[OMP_LIST_MAP
] = n
;
5913 find_module_oacc_declare_clauses (gfc_symbol
*sym
)
5915 if (sym
->attr
.use_assoc
)
5917 gfc_omp_map_op map_op
;
5919 if (sym
->attr
.oacc_declare_create
)
5920 map_op
= OMP_MAP_FORCE_ALLOC
;
5922 if (sym
->attr
.oacc_declare_copyin
)
5923 map_op
= OMP_MAP_FORCE_TO
;
5925 if (sym
->attr
.oacc_declare_deviceptr
)
5926 map_op
= OMP_MAP_FORCE_DEVICEPTR
;
5928 if (sym
->attr
.oacc_declare_device_resident
)
5929 map_op
= OMP_MAP_DEVICE_RESIDENT
;
5931 if (sym
->attr
.oacc_declare_create
5932 || sym
->attr
.oacc_declare_copyin
5933 || sym
->attr
.oacc_declare_deviceptr
5934 || sym
->attr
.oacc_declare_device_resident
)
5936 sym
->attr
.referenced
= 1;
5937 add_clause (sym
, map_op
);
5944 finish_oacc_declare (gfc_namespace
*ns
, gfc_symbol
*sym
, bool block
)
5947 gfc_oacc_declare
*oc
;
5948 locus where
= gfc_current_locus
;
5949 gfc_omp_clauses
*omp_clauses
= NULL
;
5950 gfc_omp_namelist
*n
, *p
;
5952 gfc_traverse_ns (ns
, find_module_oacc_declare_clauses
);
5954 if (module_oacc_clauses
&& sym
->attr
.flavor
== FL_PROGRAM
)
5956 gfc_oacc_declare
*new_oc
;
5958 new_oc
= gfc_get_oacc_declare ();
5959 new_oc
->next
= ns
->oacc_declare
;
5960 new_oc
->clauses
= module_oacc_clauses
;
5962 ns
->oacc_declare
= new_oc
;
5963 module_oacc_clauses
= NULL
;
5966 if (!ns
->oacc_declare
)
5969 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5975 gfc_error ("Sorry, $!ACC DECLARE at %L is not allowed "
5976 "in BLOCK construct", &oc
->loc
);
5979 if (oc
->clauses
&& oc
->clauses
->lists
[OMP_LIST_MAP
])
5981 if (omp_clauses
== NULL
)
5983 omp_clauses
= oc
->clauses
;
5987 for (n
= oc
->clauses
->lists
[OMP_LIST_MAP
]; n
; p
= n
, n
= n
->next
)
5990 gcc_assert (p
->next
== NULL
);
5992 p
->next
= omp_clauses
->lists
[OMP_LIST_MAP
];
5993 omp_clauses
= oc
->clauses
;
6000 for (n
= omp_clauses
->lists
[OMP_LIST_MAP
]; n
; n
= n
->next
)
6002 switch (n
->u
.map_op
)
6004 case OMP_MAP_DEVICE_RESIDENT
:
6005 n
->u
.map_op
= OMP_MAP_FORCE_ALLOC
;
6013 code
= XCNEW (gfc_code
);
6014 code
->op
= EXEC_OACC_DECLARE
;
6017 code
->ext
.oacc_declare
= gfc_get_oacc_declare ();
6018 code
->ext
.oacc_declare
->clauses
= omp_clauses
;
6020 code
->block
= XCNEW (gfc_code
);
6021 code
->block
->op
= EXEC_OACC_DECLARE
;
6022 code
->block
->loc
= where
;
6025 code
->block
->next
= ns
->code
;
6033 /* Generate code for a function. */
6036 gfc_generate_function_code (gfc_namespace
* ns
)
6042 tree fpstate
= NULL_TREE
;
6043 stmtblock_t init
, cleanup
;
6045 gfc_wrapped_block try_block
;
6046 tree recurcheckvar
= NULL_TREE
;
6048 gfc_symbol
*previous_procedure_symbol
;
6052 sym
= ns
->proc_name
;
6053 previous_procedure_symbol
= current_procedure_symbol
;
6054 current_procedure_symbol
= sym
;
6056 /* Check that the frontend isn't still using this. */
6057 gcc_assert (sym
->tlink
== NULL
);
6060 /* Create the declaration for functions with global scope. */
6061 if (!sym
->backend_decl
)
6062 gfc_create_function_decl (ns
, false);
6064 fndecl
= sym
->backend_decl
;
6065 old_context
= current_function_decl
;
6069 push_function_context ();
6070 saved_parent_function_decls
= saved_function_decls
;
6071 saved_function_decls
= NULL_TREE
;
6074 trans_function_start (sym
);
6076 gfc_init_block (&init
);
6078 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
6080 /* Copy length backend_decls to all entry point result
6085 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
6086 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
6087 for (el
= ns
->entries
; el
; el
= el
->next
)
6088 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
6091 /* Translate COMMON blocks. */
6092 gfc_trans_common (ns
);
6094 /* Null the parent fake result declaration if this namespace is
6095 a module function or an external procedures. */
6096 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
6097 || ns
->parent
== NULL
)
6098 parent_fake_result_decl
= NULL_TREE
;
6100 gfc_generate_contained_functions (ns
);
6102 nonlocal_dummy_decls
= NULL
;
6103 nonlocal_dummy_decl_pset
= NULL
;
6105 has_coarray_vars
= false;
6106 generate_local_vars (ns
);
6108 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
6109 generate_coarray_init (ns
);
6111 /* Keep the parent fake result declaration in module functions
6112 or external procedures. */
6113 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
6114 || ns
->parent
== NULL
)
6115 current_fake_result_decl
= parent_fake_result_decl
;
6117 current_fake_result_decl
= NULL_TREE
;
6119 is_recursive
= sym
->attr
.recursive
6120 || (sym
->attr
.entry_master
6121 && sym
->ns
->entries
->sym
->attr
.recursive
);
6122 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
6123 && !is_recursive
&& !flag_recursive
)
6127 msg
= xasprintf ("Recursive call to nonrecursive procedure '%s'",
6129 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
6130 TREE_STATIC (recurcheckvar
) = 1;
6131 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
6132 gfc_add_expr_to_block (&init
, recurcheckvar
);
6133 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
6134 &sym
->declared_at
, msg
);
6135 gfc_add_modify (&init
, recurcheckvar
, boolean_true_node
);
6139 /* Check if an IEEE module is used in the procedure. If so, save
6140 the floating point state. */
6141 ieee
= is_ieee_module_used (ns
);
6143 fpstate
= gfc_save_fp_state (&init
);
6145 /* Now generate the code for the body of this function. */
6146 gfc_init_block (&body
);
6148 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
6149 && sym
->attr
.subroutine
)
6151 tree alternate_return
;
6152 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
6153 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
6158 /* Jump to the correct entry point. */
6159 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
6160 gfc_add_expr_to_block (&body
, tmp
);
6163 /* If bounds-checking is enabled, generate code to check passed in actual
6164 arguments against the expected dummy argument attributes (e.g. string
6166 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
6167 add_argument_checking (&body
, sym
);
6169 finish_oacc_declare (ns
, sym
, false);
6171 tmp
= gfc_trans_code (ns
->code
);
6172 gfc_add_expr_to_block (&body
, tmp
);
6174 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
6175 || (sym
->result
&& sym
->result
!= sym
6176 && sym
->result
->ts
.type
== BT_DERIVED
6177 && sym
->result
->ts
.u
.derived
->attr
.alloc_comp
))
6179 bool artificial_result_decl
= false;
6180 tree result
= get_proc_result (sym
);
6181 gfc_symbol
*rsym
= sym
== sym
->result
? sym
: sym
->result
;
6183 /* Make sure that a function returning an object with
6184 alloc/pointer_components always has a result, where at least
6185 the allocatable/pointer components are set to zero. */
6186 if (result
== NULL_TREE
&& sym
->attr
.function
6187 && ((sym
->result
->ts
.type
== BT_DERIVED
6188 && (sym
->attr
.allocatable
6189 || sym
->attr
.pointer
6190 || sym
->result
->ts
.u
.derived
->attr
.alloc_comp
6191 || sym
->result
->ts
.u
.derived
->attr
.pointer_comp
))
6192 || (sym
->result
->ts
.type
== BT_CLASS
6193 && (CLASS_DATA (sym
)->attr
.allocatable
6194 || CLASS_DATA (sym
)->attr
.class_pointer
6195 || CLASS_DATA (sym
->result
)->attr
.alloc_comp
6196 || CLASS_DATA (sym
->result
)->attr
.pointer_comp
))))
6198 artificial_result_decl
= true;
6199 result
= gfc_get_fake_result_decl (sym
, 0);
6202 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
6204 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
6205 && sym
->result
== sym
)
6206 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
6207 null_pointer_node
));
6208 else if (sym
->ts
.type
== BT_CLASS
6209 && CLASS_DATA (sym
)->attr
.allocatable
6210 && CLASS_DATA (sym
)->attr
.dimension
== 0
6211 && sym
->result
== sym
)
6213 tmp
= CLASS_DATA (sym
)->backend_decl
;
6214 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
6215 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
6216 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
6217 null_pointer_node
));
6219 else if (sym
->ts
.type
== BT_DERIVED
6220 && !sym
->attr
.allocatable
)
6223 /* Arrays are not initialized using the default initializer of
6224 their elements. Therefore only check if a default
6225 initializer is available when the result is scalar. */
6226 init_exp
= rsym
->as
? NULL
: gfc_default_initializer (&rsym
->ts
);
6229 tmp
= gfc_trans_structure_assign (result
, init_exp
, 0);
6230 gfc_free_expr (init_exp
);
6231 gfc_add_expr_to_block (&init
, tmp
);
6233 else if (rsym
->ts
.u
.derived
->attr
.alloc_comp
)
6235 rank
= rsym
->as
? rsym
->as
->rank
: 0;
6236 tmp
= gfc_nullify_alloc_comp (rsym
->ts
.u
.derived
, result
,
6238 gfc_prepend_expr_to_block (&body
, tmp
);
6243 if (result
== NULL_TREE
|| artificial_result_decl
)
6245 /* TODO: move to the appropriate place in resolve.c. */
6246 if (warn_return_type
&& sym
== sym
->result
)
6247 gfc_warning (OPT_Wreturn_type
,
6248 "Return value of function %qs at %L not set",
6249 sym
->name
, &sym
->declared_at
);
6250 if (warn_return_type
)
6251 TREE_NO_WARNING(sym
->backend_decl
) = 1;
6253 if (result
!= NULL_TREE
)
6254 gfc_add_expr_to_block (&body
, gfc_generate_return ());
6257 gfc_init_block (&cleanup
);
6259 /* Reset recursion-check variable. */
6260 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
6261 && !is_recursive
&& !flag_openmp
&& recurcheckvar
!= NULL_TREE
)
6263 gfc_add_modify (&cleanup
, recurcheckvar
, boolean_false_node
);
6264 recurcheckvar
= NULL
;
6267 /* If IEEE modules are loaded, restore the floating-point state. */
6269 gfc_restore_fp_state (&cleanup
, fpstate
);
6271 /* Finish the function body and add init and cleanup code. */
6272 tmp
= gfc_finish_block (&body
);
6273 gfc_start_wrapped_block (&try_block
, tmp
);
6274 /* Add code to create and cleanup arrays. */
6275 gfc_trans_deferred_vars (sym
, &try_block
);
6276 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
6277 gfc_finish_block (&cleanup
));
6279 /* Add all the decls we created during processing. */
6280 decl
= saved_function_decls
;
6285 next
= DECL_CHAIN (decl
);
6286 DECL_CHAIN (decl
) = NULL_TREE
;
6290 saved_function_decls
= NULL_TREE
;
6292 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
6295 /* Finish off this function and send it for code generation. */
6297 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
6299 DECL_SAVED_TREE (fndecl
)
6300 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
6301 DECL_INITIAL (fndecl
));
6303 if (nonlocal_dummy_decls
)
6305 BLOCK_VARS (DECL_INITIAL (fndecl
))
6306 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
6307 delete nonlocal_dummy_decl_pset
;
6308 nonlocal_dummy_decls
= NULL
;
6309 nonlocal_dummy_decl_pset
= NULL
;
6312 /* Output the GENERIC tree. */
6313 dump_function (TDI_original
, fndecl
);
6315 /* Store the end of the function, so that we get good line number
6316 info for the epilogue. */
6317 cfun
->function_end_locus
= input_location
;
6319 /* We're leaving the context of this function, so zap cfun.
6320 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
6321 tree_rest_of_compilation. */
6326 pop_function_context ();
6327 saved_function_decls
= saved_parent_function_decls
;
6329 current_function_decl
= old_context
;
6331 if (decl_function_context (fndecl
))
6333 /* Register this function with cgraph just far enough to get it
6334 added to our parent's nested function list.
6335 If there are static coarrays in this function, the nested _caf_init
6336 function has already called cgraph_create_node, which also created
6337 the cgraph node for this function. */
6338 if (!has_coarray_vars
|| flag_coarray
!= GFC_FCOARRAY_LIB
)
6339 (void) cgraph_node::create (fndecl
);
6342 cgraph_node::finalize_function (fndecl
, true);
6344 gfc_trans_use_stmts (ns
);
6345 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
6347 if (sym
->attr
.is_main_program
)
6348 create_main_function (fndecl
);
6350 current_procedure_symbol
= previous_procedure_symbol
;
6355 gfc_generate_constructors (void)
6357 gcc_assert (gfc_static_ctors
== NULL_TREE
);
6365 if (gfc_static_ctors
== NULL_TREE
)
6368 fnname
= get_file_function_name ("I");
6369 type
= build_function_type_list (void_type_node
, NULL_TREE
);
6371 fndecl
= build_decl (input_location
,
6372 FUNCTION_DECL
, fnname
, type
);
6373 TREE_PUBLIC (fndecl
) = 1;
6375 decl
= build_decl (input_location
,
6376 RESULT_DECL
, NULL_TREE
, void_type_node
);
6377 DECL_ARTIFICIAL (decl
) = 1;
6378 DECL_IGNORED_P (decl
) = 1;
6379 DECL_CONTEXT (decl
) = fndecl
;
6380 DECL_RESULT (fndecl
) = decl
;
6384 current_function_decl
= fndecl
;
6386 rest_of_decl_compilation (fndecl
, 1, 0);
6388 make_decl_rtl (fndecl
);
6390 allocate_struct_function (fndecl
, false);
6394 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
6396 tmp
= build_call_expr_loc (input_location
,
6397 TREE_VALUE (gfc_static_ctors
), 0);
6398 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
6404 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
6405 DECL_SAVED_TREE (fndecl
)
6406 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
6407 DECL_INITIAL (fndecl
));
6409 free_after_parsing (cfun
);
6410 free_after_compilation (cfun
);
6412 tree_rest_of_compilation (fndecl
);
6414 current_function_decl
= NULL_TREE
;
6418 /* Translates a BLOCK DATA program unit. This means emitting the
6419 commons contained therein plus their initializations. We also emit
6420 a globally visible symbol to make sure that each BLOCK DATA program
6421 unit remains unique. */
6424 gfc_generate_block_data (gfc_namespace
* ns
)
6429 /* Tell the backend the source location of the block data. */
6431 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
6433 gfc_set_backend_locus (&gfc_current_locus
);
6435 /* Process the DATA statements. */
6436 gfc_trans_common (ns
);
6438 /* Create a global symbol with the mane of the block data. This is to
6439 generate linker errors if the same name is used twice. It is never
6442 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
6444 id
= get_identifier ("__BLOCK_DATA__");
6446 decl
= build_decl (input_location
,
6447 VAR_DECL
, id
, gfc_array_index_type
);
6448 TREE_PUBLIC (decl
) = 1;
6449 TREE_STATIC (decl
) = 1;
6450 DECL_IGNORED_P (decl
) = 1;
6453 rest_of_decl_compilation (decl
, 1, 0);
6457 /* Process the local variables of a BLOCK construct. */
6460 gfc_process_block_locals (gfc_namespace
* ns
)
6464 gcc_assert (saved_local_decls
== NULL_TREE
);
6465 has_coarray_vars
= false;
6467 generate_local_vars (ns
);
6469 if (flag_coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
6470 generate_coarray_init (ns
);
6472 decl
= saved_local_decls
;
6477 next
= DECL_CHAIN (decl
);
6478 DECL_CHAIN (decl
) = NULL_TREE
;
6482 saved_local_decls
= NULL_TREE
;
6486 #include "gt-fortran-trans-decl.h"