1 /* Backend function setup
2 Copyright (C) 2002-2013 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"
28 #include "tree-dump.h"
29 #include "gimple.h" /* For create_tmp_var_raw. */
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For announce_function. */
39 #include "pointer-set.h"
40 #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"
48 #define MAX_LABEL_VALUE 99999
51 /* Holds the result of the function if no result variable specified. */
53 static GTY(()) tree current_fake_result_decl
;
54 static GTY(()) tree parent_fake_result_decl
;
57 /* Holds the variable DECLs for the current function. */
59 static GTY(()) tree saved_function_decls
;
60 static GTY(()) tree saved_parent_function_decls
;
62 static struct pointer_set_t
*nonlocal_dummy_decl_pset
;
63 static GTY(()) tree nonlocal_dummy_decls
;
65 /* Holds the variable DECLs that are locals. */
67 static GTY(()) tree saved_local_decls
;
69 /* The namespace of the module we're currently generating. Only used while
70 outputting decls for module variables. Do not rely on this being set. */
72 static gfc_namespace
*module_namespace
;
74 /* The currently processed procedure symbol. */
75 static gfc_symbol
* current_procedure_symbol
= NULL
;
78 /* With -fcoarray=lib: For generating the registering call
79 of static coarrays. */
80 static bool has_coarray_vars
;
81 static stmtblock_t caf_init_block
;
84 /* List of static constructor functions. */
86 tree gfc_static_ctors
;
89 /* Function declarations for builtin library functions. */
91 tree gfor_fndecl_pause_numeric
;
92 tree gfor_fndecl_pause_string
;
93 tree gfor_fndecl_stop_numeric
;
94 tree gfor_fndecl_stop_numeric_f08
;
95 tree gfor_fndecl_stop_string
;
96 tree gfor_fndecl_error_stop_numeric
;
97 tree gfor_fndecl_error_stop_string
;
98 tree gfor_fndecl_runtime_error
;
99 tree gfor_fndecl_runtime_error_at
;
100 tree gfor_fndecl_runtime_warning_at
;
101 tree gfor_fndecl_os_error
;
102 tree gfor_fndecl_generate_error
;
103 tree gfor_fndecl_set_args
;
104 tree gfor_fndecl_set_fpe
;
105 tree gfor_fndecl_set_options
;
106 tree gfor_fndecl_set_convert
;
107 tree gfor_fndecl_set_record_marker
;
108 tree gfor_fndecl_set_max_subrecord_length
;
109 tree gfor_fndecl_ctime
;
110 tree gfor_fndecl_fdate
;
111 tree gfor_fndecl_ttynam
;
112 tree gfor_fndecl_in_pack
;
113 tree gfor_fndecl_in_unpack
;
114 tree gfor_fndecl_associated
;
117 /* Coarray run-time library function decls. */
118 tree gfor_fndecl_caf_init
;
119 tree gfor_fndecl_caf_finalize
;
120 tree gfor_fndecl_caf_register
;
121 tree gfor_fndecl_caf_deregister
;
122 tree gfor_fndecl_caf_critical
;
123 tree gfor_fndecl_caf_end_critical
;
124 tree gfor_fndecl_caf_sync_all
;
125 tree gfor_fndecl_caf_sync_images
;
126 tree gfor_fndecl_caf_error_stop
;
127 tree gfor_fndecl_caf_error_stop_str
;
129 /* Coarray global variables for num_images/this_image. */
131 tree gfort_gvar_caf_num_images
;
132 tree gfort_gvar_caf_this_image
;
135 /* Math functions. Many other math functions are handled in
136 trans-intrinsic.c. */
138 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
139 tree gfor_fndecl_math_ishftc4
;
140 tree gfor_fndecl_math_ishftc8
;
141 tree gfor_fndecl_math_ishftc16
;
144 /* String functions. */
146 tree gfor_fndecl_compare_string
;
147 tree gfor_fndecl_concat_string
;
148 tree gfor_fndecl_string_len_trim
;
149 tree gfor_fndecl_string_index
;
150 tree gfor_fndecl_string_scan
;
151 tree gfor_fndecl_string_verify
;
152 tree gfor_fndecl_string_trim
;
153 tree gfor_fndecl_string_minmax
;
154 tree gfor_fndecl_adjustl
;
155 tree gfor_fndecl_adjustr
;
156 tree gfor_fndecl_select_string
;
157 tree gfor_fndecl_compare_string_char4
;
158 tree gfor_fndecl_concat_string_char4
;
159 tree gfor_fndecl_string_len_trim_char4
;
160 tree gfor_fndecl_string_index_char4
;
161 tree gfor_fndecl_string_scan_char4
;
162 tree gfor_fndecl_string_verify_char4
;
163 tree gfor_fndecl_string_trim_char4
;
164 tree gfor_fndecl_string_minmax_char4
;
165 tree gfor_fndecl_adjustl_char4
;
166 tree gfor_fndecl_adjustr_char4
;
167 tree gfor_fndecl_select_string_char4
;
170 /* Conversion between character kinds. */
171 tree gfor_fndecl_convert_char1_to_char4
;
172 tree gfor_fndecl_convert_char4_to_char1
;
175 /* Other misc. runtime library functions. */
176 tree gfor_fndecl_size0
;
177 tree gfor_fndecl_size1
;
178 tree gfor_fndecl_iargc
;
180 /* Intrinsic functions implemented in Fortran. */
181 tree gfor_fndecl_sc_kind
;
182 tree gfor_fndecl_si_kind
;
183 tree gfor_fndecl_sr_kind
;
185 /* BLAS gemm functions. */
186 tree gfor_fndecl_sgemm
;
187 tree gfor_fndecl_dgemm
;
188 tree gfor_fndecl_cgemm
;
189 tree gfor_fndecl_zgemm
;
193 gfc_add_decl_to_parent_function (tree decl
)
196 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
197 DECL_NONLOCAL (decl
) = 1;
198 DECL_CHAIN (decl
) = saved_parent_function_decls
;
199 saved_parent_function_decls
= decl
;
203 gfc_add_decl_to_function (tree decl
)
206 TREE_USED (decl
) = 1;
207 DECL_CONTEXT (decl
) = current_function_decl
;
208 DECL_CHAIN (decl
) = saved_function_decls
;
209 saved_function_decls
= decl
;
213 add_decl_as_local (tree decl
)
216 TREE_USED (decl
) = 1;
217 DECL_CONTEXT (decl
) = current_function_decl
;
218 DECL_CHAIN (decl
) = saved_local_decls
;
219 saved_local_decls
= decl
;
223 /* Build a backend label declaration. Set TREE_USED for named labels.
224 The context of the label is always the current_function_decl. All
225 labels are marked artificial. */
228 gfc_build_label_decl (tree label_id
)
230 /* 2^32 temporaries should be enough. */
231 static unsigned int tmp_num
= 1;
235 if (label_id
== NULL_TREE
)
237 /* Build an internal label name. */
238 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
239 label_id
= get_identifier (label_name
);
244 /* Build the LABEL_DECL node. Labels have no type. */
245 label_decl
= build_decl (input_location
,
246 LABEL_DECL
, label_id
, void_type_node
);
247 DECL_CONTEXT (label_decl
) = current_function_decl
;
248 DECL_MODE (label_decl
) = VOIDmode
;
250 /* We always define the label as used, even if the original source
251 file never references the label. We don't want all kinds of
252 spurious warnings for old-style Fortran code with too many
254 TREE_USED (label_decl
) = 1;
256 DECL_ARTIFICIAL (label_decl
) = 1;
261 /* Set the backend source location of a decl. */
264 gfc_set_decl_location (tree decl
, locus
* loc
)
266 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
270 /* Return the backend label declaration for a given label structure,
271 or create it if it doesn't exist yet. */
274 gfc_get_label_decl (gfc_st_label
* lp
)
276 if (lp
->backend_decl
)
277 return lp
->backend_decl
;
280 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
283 /* Validate the label declaration from the front end. */
284 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
286 /* Build a mangled name for the label. */
287 sprintf (label_name
, "__label_%.6d", lp
->value
);
289 /* Build the LABEL_DECL node. */
290 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
292 /* Tell the debugger where the label came from. */
293 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
294 gfc_set_decl_location (label_decl
, &lp
->where
);
296 DECL_ARTIFICIAL (label_decl
) = 1;
298 /* Store the label in the label list and return the LABEL_DECL. */
299 lp
->backend_decl
= label_decl
;
305 /* Convert a gfc_symbol to an identifier of the same name. */
308 gfc_sym_identifier (gfc_symbol
* sym
)
310 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
311 return (get_identifier ("MAIN__"));
313 return (get_identifier (sym
->name
));
317 /* Construct mangled name from symbol name. */
320 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
322 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
324 /* Prevent the mangling of identifiers that have an assigned
325 binding label (mainly those that are bind(c)). */
326 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
327 return get_identifier (sym
->binding_label
);
329 if (sym
->module
== NULL
)
330 return gfc_sym_identifier (sym
);
333 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
334 return get_identifier (name
);
339 /* Construct mangled function name from symbol name. */
342 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
345 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
347 /* It may be possible to simply use the binding label if it's
348 provided, and remove the other checks. Then we could use it
349 for other things if we wished. */
350 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
352 /* use the binding label rather than the mangled name */
353 return get_identifier (sym
->binding_label
);
355 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
356 || (sym
->module
!= NULL
&& (sym
->attr
.external
357 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
359 /* Main program is mangled into MAIN__. */
360 if (sym
->attr
.is_main_program
)
361 return get_identifier ("MAIN__");
363 /* Intrinsic procedures are never mangled. */
364 if (sym
->attr
.proc
== PROC_INTRINSIC
)
365 return get_identifier (sym
->name
);
367 if (gfc_option
.flag_underscoring
)
369 has_underscore
= strchr (sym
->name
, '_') != 0;
370 if (gfc_option
.flag_second_underscore
&& has_underscore
)
371 snprintf (name
, sizeof name
, "%s__", sym
->name
);
373 snprintf (name
, sizeof name
, "%s_", sym
->name
);
374 return get_identifier (name
);
377 return get_identifier (sym
->name
);
381 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
382 return get_identifier (name
);
388 gfc_set_decl_assembler_name (tree decl
, tree name
)
390 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
391 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
395 /* Returns true if a variable of specified size should go on the stack. */
398 gfc_can_put_var_on_stack (tree size
)
400 unsigned HOST_WIDE_INT low
;
402 if (!INTEGER_CST_P (size
))
405 if (gfc_option
.flag_max_stack_var_size
< 0)
408 if (TREE_INT_CST_HIGH (size
) != 0)
411 low
= TREE_INT_CST_LOW (size
);
412 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
415 /* TODO: Set a per-function stack size limit. */
421 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
422 an expression involving its corresponding pointer. There are
423 2 cases; one for variable size arrays, and one for everything else,
424 because variable-sized arrays require one fewer level of
428 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
430 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
433 /* Parameters need to be dereferenced. */
434 if (sym
->cp_pointer
->attr
.dummy
)
435 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
438 /* Check to see if we're dealing with a variable-sized array. */
439 if (sym
->attr
.dimension
440 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
442 /* These decls will be dereferenced later, so we don't dereference
444 value
= convert (TREE_TYPE (decl
), ptr_decl
);
448 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
450 value
= build_fold_indirect_ref_loc (input_location
,
454 SET_DECL_VALUE_EXPR (decl
, value
);
455 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
456 GFC_DECL_CRAY_POINTEE (decl
) = 1;
460 /* Finish processing of a declaration without an initial value. */
463 gfc_finish_decl (tree decl
)
465 gcc_assert (TREE_CODE (decl
) == PARM_DECL
466 || DECL_INITIAL (decl
) == NULL_TREE
);
468 if (TREE_CODE (decl
) != VAR_DECL
)
471 if (DECL_SIZE (decl
) == NULL_TREE
472 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
473 layout_decl (decl
, 0);
475 /* A few consistency checks. */
476 /* A static variable with an incomplete type is an error if it is
477 initialized. Also if it is not file scope. Otherwise, let it
478 through, but if it is not `extern' then it may cause an error
480 /* An automatic variable with an incomplete type is an error. */
482 /* We should know the storage size. */
483 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
484 || (TREE_STATIC (decl
)
485 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
486 : DECL_EXTERNAL (decl
)));
488 /* The storage size should be constant. */
489 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
491 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
495 /* Apply symbol attributes to a variable, and add it to the function scope. */
498 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
501 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
502 This is the equivalent of the TARGET variables.
503 We also need to set this if the variable is passed by reference in a
506 /* Set DECL_VALUE_EXPR for Cray Pointees. */
507 if (sym
->attr
.cray_pointee
)
508 gfc_finish_cray_pointee (decl
, sym
);
510 if (sym
->attr
.target
)
511 TREE_ADDRESSABLE (decl
) = 1;
512 /* If it wasn't used we wouldn't be getting it. */
513 TREE_USED (decl
) = 1;
515 if (sym
->attr
.flavor
== FL_PARAMETER
516 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
517 TREE_READONLY (decl
) = 1;
519 /* Chain this decl to the pending declarations. Don't do pushdecl()
520 because this would add them to the current scope rather than the
522 if (current_function_decl
!= NULL_TREE
)
524 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
525 || sym
->result
== sym
)
526 gfc_add_decl_to_function (decl
);
527 else if (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
528 /* This is a BLOCK construct. */
529 add_decl_as_local (decl
);
531 gfc_add_decl_to_parent_function (decl
);
534 if (sym
->attr
.cray_pointee
)
537 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
539 /* We need to put variables that are bind(c) into the common
540 segment of the object file, because this is what C would do.
541 gfortran would typically put them in either the BSS or
542 initialized data segments, and only mark them as common if
543 they were part of common blocks. However, if they are not put
544 into common space, then C cannot initialize global Fortran
545 variables that it interoperates with and the draft says that
546 either Fortran or C should be able to initialize it (but not
547 both, of course.) (J3/04-007, section 15.3). */
548 TREE_PUBLIC(decl
) = 1;
549 DECL_COMMON(decl
) = 1;
552 /* If a variable is USE associated, it's always external. */
553 if (sym
->attr
.use_assoc
)
555 DECL_EXTERNAL (decl
) = 1;
556 TREE_PUBLIC (decl
) = 1;
558 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
560 /* TODO: Don't set sym->module for result or dummy variables. */
561 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
562 /* This is the declaration of a module variable. */
563 if (sym
->attr
.access
== ACCESS_UNKNOWN
564 && (sym
->ns
->default_access
== ACCESS_PRIVATE
565 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
566 && gfc_option
.flag_module_private
)))
567 sym
->attr
.access
= ACCESS_PRIVATE
;
569 if (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
)
570 TREE_PUBLIC (decl
) = 1;
571 TREE_STATIC (decl
) = 1;
574 /* Derived types are a bit peculiar because of the possibility of
575 a default initializer; this must be applied each time the variable
576 comes into scope it therefore need not be static. These variables
577 are SAVE_NONE but have an initializer. Otherwise explicitly
578 initialized variables are SAVE_IMPLICIT and explicitly saved are
580 if (!sym
->attr
.use_assoc
581 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
582 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
583 || (gfc_option
.coarray
== GFC_FCOARRAY_LIB
584 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
585 TREE_STATIC (decl
) = 1;
587 if (sym
->attr
.volatile_
)
589 TREE_THIS_VOLATILE (decl
) = 1;
590 TREE_SIDE_EFFECTS (decl
) = 1;
591 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
592 TREE_TYPE (decl
) = new_type
;
595 /* Keep variables larger than max-stack-var-size off stack. */
596 if (!sym
->ns
->proc_name
->attr
.recursive
597 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
598 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
599 /* Put variable length auto array pointers always into stack. */
600 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
601 || sym
->attr
.dimension
== 0
602 || sym
->as
->type
!= AS_EXPLICIT
604 || sym
->attr
.allocatable
)
605 && !DECL_ARTIFICIAL (decl
))
606 TREE_STATIC (decl
) = 1;
608 /* Handle threadprivate variables. */
609 if (sym
->attr
.threadprivate
610 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
611 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
615 /* Allocate the lang-specific part of a decl. */
618 gfc_allocate_lang_decl (tree decl
)
620 DECL_LANG_SPECIFIC (decl
) = ggc_alloc_cleared_lang_decl(sizeof
624 /* Remember a symbol to generate initialization/cleanup code at function
628 gfc_defer_symbol_init (gfc_symbol
* sym
)
634 /* Don't add a symbol twice. */
638 last
= head
= sym
->ns
->proc_name
;
641 /* Make sure that setup code for dummy variables which are used in the
642 setup of other variables is generated first. */
645 /* Find the first dummy arg seen after us, or the first non-dummy arg.
646 This is a circular list, so don't go past the head. */
648 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
654 /* Insert in between last and p. */
660 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
661 backend_decl for a module symbol, if it all ready exists. If the
662 module gsymbol does not exist, it is created. If the symbol does
663 not exist, it is added to the gsymbol namespace. Returns true if
664 an existing backend_decl is found. */
667 gfc_get_module_backend_decl (gfc_symbol
*sym
)
673 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
675 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
681 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
687 gsym
= gfc_get_gsymbol (sym
->module
);
688 gsym
->type
= GSYM_MODULE
;
689 gsym
->ns
= gfc_get_namespace (NULL
, 0);
692 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
696 else if (sym
->attr
.flavor
== FL_DERIVED
)
698 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
701 gcc_assert (s
->attr
.generic
);
702 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
703 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
710 if (!s
->backend_decl
)
711 s
->backend_decl
= gfc_get_derived_type (s
);
712 gfc_copy_dt_decls_ifequal (s
, sym
, true);
715 else if (s
->backend_decl
)
717 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
718 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
720 else if (sym
->ts
.type
== BT_CHARACTER
)
721 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
722 sym
->backend_decl
= s
->backend_decl
;
730 /* Create an array index type variable with function scope. */
733 create_index_var (const char * pfx
, int nest
)
737 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
739 gfc_add_decl_to_parent_function (decl
);
741 gfc_add_decl_to_function (decl
);
746 /* Create variables to hold all the non-constant bits of info for a
747 descriptorless array. Remember these in the lang-specific part of the
751 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
756 gfc_namespace
* procns
;
758 type
= TREE_TYPE (decl
);
760 /* We just use the descriptor, if there is one. */
761 if (GFC_DESCRIPTOR_TYPE_P (type
))
764 gcc_assert (GFC_ARRAY_TYPE_P (type
));
765 procns
= gfc_find_proc_namespace (sym
->ns
);
766 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
767 && !sym
->attr
.contained
;
769 if (sym
->attr
.codimension
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
770 && sym
->as
->type
!= AS_ASSUMED_SHAPE
771 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
775 token
= gfc_create_var_np (build_qualified_type (pvoid_type_node
,
778 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
779 DECL_ARTIFICIAL (token
) = 1;
780 TREE_STATIC (token
) = 1;
781 gfc_add_decl_to_function (token
);
784 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
786 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
788 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
789 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
791 /* Don't try to use the unknown bound for assumed shape arrays. */
792 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
793 && (sym
->as
->type
!= AS_ASSUMED_SIZE
794 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
796 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
797 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
800 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
802 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
803 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
806 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
807 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
809 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
811 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
812 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
814 /* Don't try to use the unknown ubound for the last coarray dimension. */
815 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
816 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
818 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
819 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
822 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
824 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
826 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
829 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
831 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
834 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
835 && sym
->as
->type
!= AS_ASSUMED_SIZE
)
837 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
838 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
841 if (POINTER_TYPE_P (type
))
843 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
844 gcc_assert (TYPE_LANG_SPECIFIC (type
)
845 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
846 type
= TREE_TYPE (type
);
849 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
853 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
854 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
855 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
857 TYPE_DOMAIN (type
) = range
;
861 if (TYPE_NAME (type
) != NULL_TREE
862 && GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1) != NULL_TREE
863 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1)) == VAR_DECL
)
865 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
867 for (dim
= 0; dim
< sym
->as
->rank
- 1; dim
++)
869 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
870 gtype
= TREE_TYPE (gtype
);
872 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
873 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
874 TYPE_NAME (type
) = NULL_TREE
;
877 if (TYPE_NAME (type
) == NULL_TREE
)
879 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
881 for (dim
= sym
->as
->rank
- 1; dim
>= 0; dim
--)
884 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
885 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
886 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
887 gtype
= build_array_type (gtype
, rtype
);
888 /* Ensure the bound variables aren't optimized out at -O0.
889 For -O1 and above they often will be optimized out, but
890 can be tracked by VTA. Also set DECL_NAMELESS, so that
891 the artificial lbound.N or ubound.N DECL_NAME doesn't
892 end up in debug info. */
893 if (lbound
&& TREE_CODE (lbound
) == VAR_DECL
894 && DECL_ARTIFICIAL (lbound
) && DECL_IGNORED_P (lbound
))
896 if (DECL_NAME (lbound
)
897 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
899 DECL_NAMELESS (lbound
) = 1;
900 DECL_IGNORED_P (lbound
) = 0;
902 if (ubound
&& TREE_CODE (ubound
) == VAR_DECL
903 && DECL_ARTIFICIAL (ubound
) && DECL_IGNORED_P (ubound
))
905 if (DECL_NAME (ubound
)
906 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
908 DECL_NAMELESS (ubound
) = 1;
909 DECL_IGNORED_P (ubound
) = 0;
912 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
913 TYPE_DECL
, NULL
, gtype
);
914 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
919 /* For some dummy arguments we don't use the actual argument directly.
920 Instead we create a local decl and use that. This allows us to perform
921 initialization, and construct full type information. */
924 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
934 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
935 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
938 /* Add to list of variables if not a fake result variable. */
939 if (sym
->attr
.result
|| sym
->attr
.dummy
)
940 gfc_defer_symbol_init (sym
);
942 type
= TREE_TYPE (dummy
);
943 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
944 && POINTER_TYPE_P (type
));
946 /* Do we know the element size? */
947 known_size
= sym
->ts
.type
!= BT_CHARACTER
948 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
950 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
952 /* For descriptorless arrays with known element size the actual
953 argument is sufficient. */
954 gcc_assert (GFC_ARRAY_TYPE_P (type
));
955 gfc_build_qualified_array (dummy
, sym
);
959 type
= TREE_TYPE (type
);
960 if (GFC_DESCRIPTOR_TYPE_P (type
))
962 /* Create a descriptorless array pointer. */
966 /* Even when -frepack-arrays is used, symbols with TARGET attribute
968 if (!gfc_option
.flag_repack_arrays
|| sym
->attr
.target
)
970 if (as
->type
== AS_ASSUMED_SIZE
)
971 packed
= PACKED_FULL
;
975 if (as
->type
== AS_EXPLICIT
)
977 packed
= PACKED_FULL
;
978 for (n
= 0; n
< as
->rank
; n
++)
982 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
983 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
984 packed
= PACKED_PARTIAL
;
988 packed
= PACKED_PARTIAL
;
991 type
= gfc_typenode_for_spec (&sym
->ts
);
992 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
997 /* We now have an expression for the element size, so create a fully
998 qualified type. Reset sym->backend decl or this will just return the
1000 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1001 sym
->backend_decl
= NULL_TREE
;
1002 type
= gfc_sym_type (sym
);
1003 packed
= PACKED_FULL
;
1006 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1007 decl
= build_decl (input_location
,
1008 VAR_DECL
, get_identifier (name
), type
);
1010 DECL_ARTIFICIAL (decl
) = 1;
1011 DECL_NAMELESS (decl
) = 1;
1012 TREE_PUBLIC (decl
) = 0;
1013 TREE_STATIC (decl
) = 0;
1014 DECL_EXTERNAL (decl
) = 0;
1016 /* We should never get deferred shape arrays here. We used to because of
1018 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
1020 if (packed
== PACKED_PARTIAL
)
1021 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
1022 else if (packed
== PACKED_FULL
)
1023 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1025 gfc_build_qualified_array (decl
, sym
);
1027 if (DECL_LANG_SPECIFIC (dummy
))
1028 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
1030 gfc_allocate_lang_decl (decl
);
1032 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
1034 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1035 || sym
->attr
.contained
)
1036 gfc_add_decl_to_function (decl
);
1038 gfc_add_decl_to_parent_function (decl
);
1043 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1044 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1045 pointing to the artificial variable for debug info purposes. */
1048 gfc_nonlocal_dummy_array_decl (gfc_symbol
*sym
)
1052 if (! nonlocal_dummy_decl_pset
)
1053 nonlocal_dummy_decl_pset
= pointer_set_create ();
1055 if (pointer_set_insert (nonlocal_dummy_decl_pset
, sym
->backend_decl
))
1058 dummy
= GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
);
1059 decl
= build_decl (input_location
, VAR_DECL
, DECL_NAME (dummy
),
1060 TREE_TYPE (sym
->backend_decl
));
1061 DECL_ARTIFICIAL (decl
) = 0;
1062 TREE_USED (decl
) = 1;
1063 TREE_PUBLIC (decl
) = 0;
1064 TREE_STATIC (decl
) = 0;
1065 DECL_EXTERNAL (decl
) = 0;
1066 if (DECL_BY_REFERENCE (dummy
))
1067 DECL_BY_REFERENCE (decl
) = 1;
1068 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (sym
->backend_decl
);
1069 SET_DECL_VALUE_EXPR (decl
, sym
->backend_decl
);
1070 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
1071 DECL_CONTEXT (decl
) = DECL_CONTEXT (sym
->backend_decl
);
1072 DECL_CHAIN (decl
) = nonlocal_dummy_decls
;
1073 nonlocal_dummy_decls
= decl
;
1076 /* Return a constant or a variable to use as a string length. Does not
1077 add the decl to the current scope. */
1080 gfc_create_string_length (gfc_symbol
* sym
)
1082 gcc_assert (sym
->ts
.u
.cl
);
1083 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
1085 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1090 /* The string length variable shall be in static memory if it is either
1091 explicitly SAVED, a module variable or with -fno-automatic. Only
1092 relevant is "len=:" - otherwise, it is either a constant length or
1093 it is an automatic variable. */
1094 bool static_length
= sym
->attr
.save
1095 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1096 || (gfc_option
.flag_max_stack_var_size
== 0
1097 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1098 && !sym
->attr
.result
&& !sym
->attr
.function
);
1100 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1101 variables as some systems do not support the "." in the assembler name.
1102 For nonstatic variables, the "." does not appear in assembler. */
1106 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1109 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1111 else if (sym
->module
)
1112 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1114 name
= gfc_get_string (".%s", sym
->name
);
1116 length
= build_decl (input_location
,
1117 VAR_DECL
, get_identifier (name
),
1118 gfc_charlen_type_node
);
1119 DECL_ARTIFICIAL (length
) = 1;
1120 TREE_USED (length
) = 1;
1121 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1122 gfc_defer_symbol_init (sym
);
1124 sym
->ts
.u
.cl
->backend_decl
= length
;
1127 TREE_STATIC (length
) = 1;
1129 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1130 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1131 TREE_PUBLIC (length
) = 1;
1134 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1135 return sym
->ts
.u
.cl
->backend_decl
;
1138 /* If a variable is assigned a label, we add another two auxiliary
1142 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1148 gcc_assert (sym
->backend_decl
);
1150 decl
= sym
->backend_decl
;
1151 gfc_allocate_lang_decl (decl
);
1152 GFC_DECL_ASSIGN (decl
) = 1;
1153 length
= build_decl (input_location
,
1154 VAR_DECL
, create_tmp_var_name (sym
->name
),
1155 gfc_charlen_type_node
);
1156 addr
= build_decl (input_location
,
1157 VAR_DECL
, create_tmp_var_name (sym
->name
),
1159 gfc_finish_var_decl (length
, sym
);
1160 gfc_finish_var_decl (addr
, sym
);
1161 /* STRING_LENGTH is also used as flag. Less than -1 means that
1162 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1163 target label's address. Otherwise, value is the length of a format string
1164 and ASSIGN_ADDR is its address. */
1165 if (TREE_STATIC (length
))
1166 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1168 gfc_defer_symbol_init (sym
);
1170 GFC_DECL_STRING_LEN (decl
) = length
;
1171 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1176 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1181 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1182 if (sym_attr
.ext_attr
& (1 << id
))
1184 attr
= build_tree_list (
1185 get_identifier (ext_attr_list
[id
].middle_end_name
),
1187 list
= chainon (list
, attr
);
1194 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1197 /* Return the decl for a gfc_symbol, create it if it doesn't already
1201 gfc_get_symbol_decl (gfc_symbol
* sym
)
1204 tree length
= NULL_TREE
;
1207 bool intrinsic_array_parameter
= false;
1210 gcc_assert (sym
->attr
.referenced
1211 || sym
->attr
.flavor
== FL_PROCEDURE
1212 || sym
->attr
.use_assoc
1213 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1214 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1215 && sym
->backend_decl
));
1217 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1218 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1222 /* Make sure that the vtab for the declared type is completed. */
1223 if (sym
->ts
.type
== BT_CLASS
)
1225 gfc_component
*c
= CLASS_DATA (sym
);
1226 if (!c
->ts
.u
.derived
->backend_decl
)
1228 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1229 gfc_get_derived_type (sym
->ts
.u
.derived
);
1233 /* All deferred character length procedures need to retain the backend
1234 decl, which is a pointer to the character length in the caller's
1235 namespace and to declare a local character length. */
1236 if (!byref
&& sym
->attr
.function
1237 && sym
->ts
.type
== BT_CHARACTER
1239 && sym
->ts
.u
.cl
->passed_length
== NULL
1240 && sym
->ts
.u
.cl
->backend_decl
1241 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1243 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1244 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1245 length
= gfc_create_string_length (sym
);
1248 fun_or_res
= byref
&& (sym
->attr
.result
1249 || (sym
->attr
.function
&& sym
->ts
.deferred
));
1250 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || fun_or_res
)
1252 /* Return via extra parameter. */
1253 if (sym
->attr
.result
&& byref
1254 && !sym
->backend_decl
)
1257 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1258 /* For entry master function skip over the __entry
1260 if (sym
->ns
->proc_name
->attr
.entry_master
)
1261 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1264 /* Dummy variables should already have been created. */
1265 gcc_assert (sym
->backend_decl
);
1267 /* Create a character length variable. */
1268 if (sym
->ts
.type
== BT_CHARACTER
)
1270 /* For a deferred dummy, make a new string length variable. */
1271 if (sym
->ts
.deferred
1273 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1274 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1276 if (sym
->ts
.deferred
&& fun_or_res
1277 && sym
->ts
.u
.cl
->passed_length
== NULL
1278 && sym
->ts
.u
.cl
->backend_decl
)
1280 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1281 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1284 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1285 length
= gfc_create_string_length (sym
);
1287 length
= sym
->ts
.u
.cl
->backend_decl
;
1288 if (TREE_CODE (length
) == VAR_DECL
1289 && DECL_FILE_SCOPE_P (length
))
1291 /* Add the string length to the same context as the symbol. */
1292 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1293 gfc_add_decl_to_function (length
);
1295 gfc_add_decl_to_parent_function (length
);
1297 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1298 DECL_CONTEXT (length
));
1300 gfc_defer_symbol_init (sym
);
1304 /* Use a copy of the descriptor for dummy arrays. */
1305 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1306 && !TREE_USED (sym
->backend_decl
))
1308 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1309 /* Prevent the dummy from being detected as unused if it is copied. */
1310 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1311 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1312 sym
->backend_decl
= decl
;
1315 TREE_USED (sym
->backend_decl
) = 1;
1316 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1318 gfc_add_assign_aux_vars (sym
);
1321 if (sym
->attr
.dimension
1322 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1323 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1324 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1325 gfc_nonlocal_dummy_array_decl (sym
);
1327 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1328 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1330 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1331 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1332 return sym
->backend_decl
;
1335 if (sym
->backend_decl
)
1336 return sym
->backend_decl
;
1338 /* Special case for array-valued named constants from intrinsic
1339 procedures; those are inlined. */
1340 if (sym
->attr
.use_assoc
&& sym
->from_intmod
1341 && sym
->attr
.flavor
== FL_PARAMETER
)
1342 intrinsic_array_parameter
= true;
1344 /* If use associated compilation, use the module
1346 if ((sym
->attr
.flavor
== FL_VARIABLE
1347 || sym
->attr
.flavor
== FL_PARAMETER
)
1348 && sym
->attr
.use_assoc
1349 && !intrinsic_array_parameter
1351 && gfc_get_module_backend_decl (sym
))
1353 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1354 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1355 return sym
->backend_decl
;
1358 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1360 /* Catch function declarations. Only used for actual parameters,
1361 procedure pointers and procptr initialization targets. */
1362 if (sym
->attr
.external
|| sym
->attr
.use_assoc
|| sym
->attr
.intrinsic
)
1364 decl
= gfc_get_extern_function_decl (sym
);
1365 gfc_set_decl_location (decl
, &sym
->declared_at
);
1369 if (!sym
->backend_decl
)
1370 build_function_decl (sym
, false);
1371 decl
= sym
->backend_decl
;
1376 if (sym
->attr
.intrinsic
)
1377 internal_error ("intrinsic variable which isn't a procedure");
1379 /* Create string length decl first so that they can be used in the
1380 type declaration. */
1381 if (sym
->ts
.type
== BT_CHARACTER
)
1382 length
= gfc_create_string_length (sym
);
1384 /* Create the decl for the variable. */
1385 decl
= build_decl (sym
->declared_at
.lb
->location
,
1386 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1388 /* Add attributes to variables. Functions are handled elsewhere. */
1389 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1390 decl_attributes (&decl
, attributes
, 0);
1392 /* Symbols from modules should have their assembler names mangled.
1393 This is done here rather than in gfc_finish_var_decl because it
1394 is different for string length variables. */
1397 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1398 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1399 DECL_IGNORED_P (decl
) = 1;
1402 if (sym
->attr
.select_type_temporary
)
1404 DECL_ARTIFICIAL (decl
) = 1;
1405 DECL_IGNORED_P (decl
) = 1;
1408 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1410 /* Create variables to hold the non-constant bits of array info. */
1411 gfc_build_qualified_array (decl
, sym
);
1413 if (sym
->attr
.contiguous
1414 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1415 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1418 /* Remember this variable for allocation/cleanup. */
1419 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1420 || (sym
->ts
.type
== BT_CLASS
&&
1421 (CLASS_DATA (sym
)->attr
.dimension
1422 || CLASS_DATA (sym
)->attr
.allocatable
))
1423 || (sym
->ts
.type
== BT_DERIVED
1424 && (sym
->ts
.u
.derived
->attr
.alloc_comp
1425 || (!sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
1426 && !sym
->ns
->proc_name
->attr
.is_main_program
1427 && gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
))))
1428 /* This applies a derived type default initializer. */
1429 || (sym
->ts
.type
== BT_DERIVED
1430 && sym
->attr
.save
== SAVE_NONE
1432 && !sym
->attr
.allocatable
1433 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1434 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1435 gfc_defer_symbol_init (sym
);
1437 gfc_finish_var_decl (decl
, sym
);
1439 if (sym
->ts
.type
== BT_CHARACTER
)
1441 /* Character variables need special handling. */
1442 gfc_allocate_lang_decl (decl
);
1444 if (TREE_CODE (length
) != INTEGER_CST
)
1446 gfc_finish_var_decl (length
, sym
);
1447 gcc_assert (!sym
->value
);
1450 else if (sym
->attr
.subref_array_pointer
)
1452 /* We need the span for these beasts. */
1453 gfc_allocate_lang_decl (decl
);
1456 if (sym
->attr
.subref_array_pointer
)
1459 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1460 span
= build_decl (input_location
,
1461 VAR_DECL
, create_tmp_var_name ("span"),
1462 gfc_array_index_type
);
1463 gfc_finish_var_decl (span
, sym
);
1464 TREE_STATIC (span
) = TREE_STATIC (decl
);
1465 DECL_ARTIFICIAL (span
) = 1;
1467 GFC_DECL_SPAN (decl
) = span
;
1468 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1471 if (sym
->ts
.type
== BT_CLASS
)
1472 GFC_DECL_CLASS(decl
) = 1;
1474 sym
->backend_decl
= decl
;
1476 if (sym
->attr
.assign
)
1477 gfc_add_assign_aux_vars (sym
);
1479 if (intrinsic_array_parameter
)
1481 TREE_STATIC (decl
) = 1;
1482 DECL_EXTERNAL (decl
) = 0;
1485 if (TREE_STATIC (decl
)
1486 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1487 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1488 || gfc_option
.flag_max_stack_var_size
== 0
1489 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1490 && (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
1491 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
))
1493 /* Add static initializer. For procedures, it is only needed if
1494 SAVE is specified otherwise they need to be reinitialized
1495 every time the procedure is entered. The TREE_STATIC is
1496 in this case due to -fmax-stack-var-size=. */
1497 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1500 || (sym
->attr
.codimension
1501 && sym
->attr
.allocatable
),
1503 || sym
->attr
.allocatable
,
1504 sym
->attr
.proc_pointer
);
1507 if (!TREE_STATIC (decl
)
1508 && POINTER_TYPE_P (TREE_TYPE (decl
))
1509 && !sym
->attr
.pointer
1510 && !sym
->attr
.allocatable
1511 && !sym
->attr
.proc_pointer
1512 && !sym
->attr
.select_type_temporary
)
1513 DECL_BY_REFERENCE (decl
) = 1;
1516 || (sym
->name
[0] == '_' && strncmp ("__def_init", sym
->name
, 10) == 0))
1517 TREE_READONLY (decl
) = 1;
1523 /* Substitute a temporary variable in place of the real one. */
1526 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1528 save
->attr
= sym
->attr
;
1529 save
->decl
= sym
->backend_decl
;
1531 gfc_clear_attr (&sym
->attr
);
1532 sym
->attr
.referenced
= 1;
1533 sym
->attr
.flavor
= FL_VARIABLE
;
1535 sym
->backend_decl
= decl
;
1539 /* Restore the original variable. */
1542 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1544 sym
->attr
= save
->attr
;
1545 sym
->backend_decl
= save
->decl
;
1549 /* Declare a procedure pointer. */
1552 get_proc_pointer_decl (gfc_symbol
*sym
)
1557 decl
= sym
->backend_decl
;
1561 decl
= build_decl (input_location
,
1562 VAR_DECL
, get_identifier (sym
->name
),
1563 build_pointer_type (gfc_get_function_type (sym
)));
1567 /* Apply name mangling. */
1568 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1569 if (sym
->attr
.use_assoc
)
1570 DECL_IGNORED_P (decl
) = 1;
1573 if ((sym
->ns
->proc_name
1574 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1575 || sym
->attr
.contained
)
1576 gfc_add_decl_to_function (decl
);
1577 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1578 gfc_add_decl_to_parent_function (decl
);
1580 sym
->backend_decl
= decl
;
1582 /* If a variable is USE associated, it's always external. */
1583 if (sym
->attr
.use_assoc
)
1585 DECL_EXTERNAL (decl
) = 1;
1586 TREE_PUBLIC (decl
) = 1;
1588 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1590 /* This is the declaration of a module variable. */
1591 TREE_PUBLIC (decl
) = 1;
1592 TREE_STATIC (decl
) = 1;
1595 if (!sym
->attr
.use_assoc
1596 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1597 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1598 TREE_STATIC (decl
) = 1;
1600 if (TREE_STATIC (decl
) && sym
->value
)
1602 /* Add static initializer. */
1603 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1605 sym
->attr
.dimension
,
1609 /* Handle threadprivate procedure pointers. */
1610 if (sym
->attr
.threadprivate
1611 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
1612 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
1614 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1615 decl_attributes (&decl
, attributes
, 0);
1621 /* Get a basic decl for an external function. */
1624 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1630 gfc_intrinsic_sym
*isym
;
1632 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1637 if (sym
->backend_decl
)
1638 return sym
->backend_decl
;
1640 /* We should never be creating external decls for alternate entry points.
1641 The procedure may be an alternate entry point, but we don't want/need
1643 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1645 if (sym
->attr
.proc_pointer
)
1646 return get_proc_pointer_decl (sym
);
1648 /* See if this is an external procedure from the same file. If so,
1649 return the backend_decl. */
1650 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
1651 ? sym
->binding_label
: sym
->name
);
1653 if (gsym
&& !gsym
->defined
)
1656 /* This can happen because of C binding. */
1657 if (gsym
&& gsym
->ns
&& gsym
->ns
->proc_name
1658 && gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1661 if ((!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
1662 && !sym
->backend_decl
1664 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1665 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
1667 if (!gsym
->ns
->proc_name
->backend_decl
)
1669 /* By construction, the external function cannot be
1670 a contained procedure. */
1673 gfc_save_backend_locus (&old_loc
);
1676 gfc_create_function_decl (gsym
->ns
, true);
1679 gfc_restore_backend_locus (&old_loc
);
1682 /* If the namespace has entries, the proc_name is the
1683 entry master. Find the entry and use its backend_decl.
1684 otherwise, use the proc_name backend_decl. */
1685 if (gsym
->ns
->entries
)
1687 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1689 for (; entry
; entry
= entry
->next
)
1691 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1693 sym
->backend_decl
= entry
->sym
->backend_decl
;
1699 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1701 if (sym
->backend_decl
)
1703 /* Avoid problems of double deallocation of the backend declaration
1704 later in gfc_trans_use_stmts; cf. PR 45087. */
1705 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
1706 sym
->attr
.use_assoc
= 0;
1708 return sym
->backend_decl
;
1712 /* See if this is a module procedure from the same file. If so,
1713 return the backend_decl. */
1715 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1718 if (gsym
&& gsym
->ns
1719 && (gsym
->type
== GSYM_MODULE
1720 || (gsym
->ns
->proc_name
&& gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
1725 if (gsym
->type
== GSYM_MODULE
)
1726 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1728 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &s
);
1730 if (s
&& s
->backend_decl
)
1732 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1733 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
1735 else if (sym
->ts
.type
== BT_CHARACTER
)
1736 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1737 sym
->backend_decl
= s
->backend_decl
;
1738 return sym
->backend_decl
;
1742 if (sym
->attr
.intrinsic
)
1744 /* Call the resolution function to get the actual name. This is
1745 a nasty hack which relies on the resolution functions only looking
1746 at the first argument. We pass NULL for the second argument
1747 otherwise things like AINT get confused. */
1748 isym
= gfc_find_function (sym
->name
);
1749 gcc_assert (isym
->resolve
.f0
!= NULL
);
1751 memset (&e
, 0, sizeof (e
));
1752 e
.expr_type
= EXPR_FUNCTION
;
1754 memset (&argexpr
, 0, sizeof (argexpr
));
1755 gcc_assert (isym
->formal
);
1756 argexpr
.ts
= isym
->formal
->ts
;
1758 if (isym
->formal
->next
== NULL
)
1759 isym
->resolve
.f1 (&e
, &argexpr
);
1762 if (isym
->formal
->next
->next
== NULL
)
1763 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1766 if (isym
->formal
->next
->next
->next
== NULL
)
1767 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1770 /* All specific intrinsics take less than 5 arguments. */
1771 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1772 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1777 if (gfc_option
.flag_f2c
1778 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1779 || e
.ts
.type
== BT_COMPLEX
))
1781 /* Specific which needs a different implementation if f2c
1782 calling conventions are used. */
1783 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1786 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1788 name
= get_identifier (s
);
1789 mangled_name
= name
;
1793 name
= gfc_sym_identifier (sym
);
1794 mangled_name
= gfc_sym_mangled_function_id (sym
);
1797 type
= gfc_get_function_type (sym
);
1798 fndecl
= build_decl (input_location
,
1799 FUNCTION_DECL
, name
, type
);
1801 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1802 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1803 the opposite of declaring a function as static in C). */
1804 DECL_EXTERNAL (fndecl
) = 1;
1805 TREE_PUBLIC (fndecl
) = 1;
1807 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1808 decl_attributes (&fndecl
, attributes
, 0);
1810 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
1812 /* Set the context of this decl. */
1813 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1815 /* TODO: Add external decls to the appropriate scope. */
1816 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1820 /* Global declaration, e.g. intrinsic subroutine. */
1821 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1824 /* Set attributes for PURE functions. A call to PURE function in the
1825 Fortran 95 sense is both pure and without side effects in the C
1827 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
1829 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1830 DECL_PURE_P (fndecl
) = 1;
1831 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1832 parameters and don't use alternate returns (is this
1833 allowed?). In that case, calls to them are meaningless, and
1834 can be optimized away. See also in build_function_decl(). */
1835 TREE_SIDE_EFFECTS (fndecl
) = 0;
1838 /* Mark non-returning functions. */
1839 if (sym
->attr
.noreturn
)
1840 TREE_THIS_VOLATILE(fndecl
) = 1;
1842 sym
->backend_decl
= fndecl
;
1844 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1845 pushdecl_top_level (fndecl
);
1851 /* Create a declaration for a procedure. For external functions (in the C
1852 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1853 a master function with alternate entry points. */
1856 build_function_decl (gfc_symbol
* sym
, bool global
)
1858 tree fndecl
, type
, attributes
;
1859 symbol_attribute attr
;
1861 gfc_formal_arglist
*f
;
1863 gcc_assert (!sym
->attr
.external
);
1865 if (sym
->backend_decl
)
1868 /* Set the line and filename. sym->declared_at seems to point to the
1869 last statement for subroutines, but it'll do for now. */
1870 gfc_set_backend_locus (&sym
->declared_at
);
1872 /* Allow only one nesting level. Allow public declarations. */
1873 gcc_assert (current_function_decl
== NULL_TREE
1874 || DECL_FILE_SCOPE_P (current_function_decl
)
1875 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
1876 == NAMESPACE_DECL
));
1878 type
= gfc_get_function_type (sym
);
1879 fndecl
= build_decl (input_location
,
1880 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1884 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1885 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1886 the opposite of declaring a function as static in C). */
1887 DECL_EXTERNAL (fndecl
) = 0;
1889 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
1890 && (sym
->ns
->default_access
== ACCESS_PRIVATE
1891 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
1892 && gfc_option
.flag_module_private
)))
1893 sym
->attr
.access
= ACCESS_PRIVATE
;
1895 if (!current_function_decl
1896 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
1897 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
1898 || sym
->attr
.public_used
))
1899 TREE_PUBLIC (fndecl
) = 1;
1901 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
1902 TREE_USED (fndecl
) = 1;
1904 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
1905 decl_attributes (&fndecl
, attributes
, 0);
1907 /* Figure out the return type of the declared function, and build a
1908 RESULT_DECL for it. If this is a subroutine with alternate
1909 returns, build a RESULT_DECL for it. */
1910 result_decl
= NULL_TREE
;
1911 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1914 if (gfc_return_by_reference (sym
))
1915 type
= void_type_node
;
1918 if (sym
->result
!= sym
)
1919 result_decl
= gfc_sym_identifier (sym
->result
);
1921 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1926 /* Look for alternate return placeholders. */
1927 int has_alternate_returns
= 0;
1928 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
1932 has_alternate_returns
= 1;
1937 if (has_alternate_returns
)
1938 type
= integer_type_node
;
1940 type
= void_type_node
;
1943 result_decl
= build_decl (input_location
,
1944 RESULT_DECL
, result_decl
, type
);
1945 DECL_ARTIFICIAL (result_decl
) = 1;
1946 DECL_IGNORED_P (result_decl
) = 1;
1947 DECL_CONTEXT (result_decl
) = fndecl
;
1948 DECL_RESULT (fndecl
) = result_decl
;
1950 /* Don't call layout_decl for a RESULT_DECL.
1951 layout_decl (result_decl, 0); */
1953 /* TREE_STATIC means the function body is defined here. */
1954 TREE_STATIC (fndecl
) = 1;
1956 /* Set attributes for PURE functions. A call to a PURE function in the
1957 Fortran 95 sense is both pure and without side effects in the C
1959 if (attr
.pure
|| attr
.implicit_pure
)
1961 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1962 including an alternate return. In that case it can also be
1963 marked as PURE. See also in gfc_get_extern_function_decl(). */
1964 if (attr
.function
&& !gfc_return_by_reference (sym
))
1965 DECL_PURE_P (fndecl
) = 1;
1966 TREE_SIDE_EFFECTS (fndecl
) = 0;
1970 /* Layout the function declaration and put it in the binding level
1971 of the current function. */
1974 pushdecl_top_level (fndecl
);
1978 /* Perform name mangling if this is a top level or module procedure. */
1979 if (current_function_decl
== NULL_TREE
)
1980 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
1982 sym
->backend_decl
= fndecl
;
1986 /* Create the DECL_ARGUMENTS for a procedure. */
1989 create_function_arglist (gfc_symbol
* sym
)
1992 gfc_formal_arglist
*f
;
1993 tree typelist
, hidden_typelist
;
1994 tree arglist
, hidden_arglist
;
1998 fndecl
= sym
->backend_decl
;
2000 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2001 the new FUNCTION_DECL node. */
2002 arglist
= NULL_TREE
;
2003 hidden_arglist
= NULL_TREE
;
2004 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
2006 if (sym
->attr
.entry_master
)
2008 type
= TREE_VALUE (typelist
);
2009 parm
= build_decl (input_location
,
2010 PARM_DECL
, get_identifier ("__entry"), type
);
2012 DECL_CONTEXT (parm
) = fndecl
;
2013 DECL_ARG_TYPE (parm
) = type
;
2014 TREE_READONLY (parm
) = 1;
2015 gfc_finish_decl (parm
);
2016 DECL_ARTIFICIAL (parm
) = 1;
2018 arglist
= chainon (arglist
, parm
);
2019 typelist
= TREE_CHAIN (typelist
);
2022 if (gfc_return_by_reference (sym
))
2024 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2026 if (sym
->ts
.type
== BT_CHARACTER
)
2028 /* Length of character result. */
2029 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2031 length
= build_decl (input_location
,
2033 get_identifier (".__result"),
2035 if (!sym
->ts
.u
.cl
->length
)
2037 sym
->ts
.u
.cl
->backend_decl
= length
;
2038 TREE_USED (length
) = 1;
2040 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2041 DECL_CONTEXT (length
) = fndecl
;
2042 DECL_ARG_TYPE (length
) = len_type
;
2043 TREE_READONLY (length
) = 1;
2044 DECL_ARTIFICIAL (length
) = 1;
2045 gfc_finish_decl (length
);
2046 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2047 || sym
->ts
.u
.cl
->backend_decl
== length
)
2052 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2054 tree len
= build_decl (input_location
,
2056 get_identifier ("..__result"),
2057 gfc_charlen_type_node
);
2058 DECL_ARTIFICIAL (len
) = 1;
2059 TREE_USED (len
) = 1;
2060 sym
->ts
.u
.cl
->backend_decl
= len
;
2063 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2064 arg
= sym
->result
? sym
->result
: sym
;
2065 backend_decl
= arg
->backend_decl
;
2066 /* Temporary clear it, so that gfc_sym_type creates complete
2068 arg
->backend_decl
= NULL
;
2069 type
= gfc_sym_type (arg
);
2070 arg
->backend_decl
= backend_decl
;
2071 type
= build_reference_type (type
);
2075 parm
= build_decl (input_location
,
2076 PARM_DECL
, get_identifier ("__result"), type
);
2078 DECL_CONTEXT (parm
) = fndecl
;
2079 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2080 TREE_READONLY (parm
) = 1;
2081 DECL_ARTIFICIAL (parm
) = 1;
2082 gfc_finish_decl (parm
);
2084 arglist
= chainon (arglist
, parm
);
2085 typelist
= TREE_CHAIN (typelist
);
2087 if (sym
->ts
.type
== BT_CHARACTER
)
2089 gfc_allocate_lang_decl (parm
);
2090 arglist
= chainon (arglist
, length
);
2091 typelist
= TREE_CHAIN (typelist
);
2095 hidden_typelist
= typelist
;
2096 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2097 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2098 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2100 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2102 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2104 /* Ignore alternate returns. */
2108 type
= TREE_VALUE (typelist
);
2110 if (f
->sym
->ts
.type
== BT_CHARACTER
2111 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2113 tree len_type
= TREE_VALUE (hidden_typelist
);
2114 tree length
= NULL_TREE
;
2115 if (!f
->sym
->ts
.deferred
)
2116 gcc_assert (len_type
== gfc_charlen_type_node
);
2118 gcc_assert (POINTER_TYPE_P (len_type
));
2120 strcpy (&name
[1], f
->sym
->name
);
2122 length
= build_decl (input_location
,
2123 PARM_DECL
, get_identifier (name
), len_type
);
2125 hidden_arglist
= chainon (hidden_arglist
, length
);
2126 DECL_CONTEXT (length
) = fndecl
;
2127 DECL_ARTIFICIAL (length
) = 1;
2128 DECL_ARG_TYPE (length
) = len_type
;
2129 TREE_READONLY (length
) = 1;
2130 gfc_finish_decl (length
);
2132 /* Remember the passed value. */
2133 if (!f
->sym
->ts
.u
.cl
|| f
->sym
->ts
.u
.cl
->passed_length
)
2135 /* This can happen if the same type is used for multiple
2136 arguments. We need to copy cl as otherwise
2137 cl->passed_length gets overwritten. */
2138 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2140 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2142 /* Use the passed value for assumed length variables. */
2143 if (!f
->sym
->ts
.u
.cl
->length
)
2145 TREE_USED (length
) = 1;
2146 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2147 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2150 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2152 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2153 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2155 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2156 gfc_create_string_length (f
->sym
);
2158 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2159 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2160 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2162 type
= gfc_sym_type (f
->sym
);
2165 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2166 hence, the optional status cannot be transfered via a NULL pointer.
2167 Thus, we will use a hidden argument in that case. */
2168 else if (f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2169 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2170 && f
->sym
->ts
.type
!= BT_DERIVED
)
2173 strcpy (&name
[1], f
->sym
->name
);
2175 tmp
= build_decl (input_location
,
2176 PARM_DECL
, get_identifier (name
),
2179 hidden_arglist
= chainon (hidden_arglist
, tmp
);
2180 DECL_CONTEXT (tmp
) = fndecl
;
2181 DECL_ARTIFICIAL (tmp
) = 1;
2182 DECL_ARG_TYPE (tmp
) = boolean_type_node
;
2183 TREE_READONLY (tmp
) = 1;
2184 gfc_finish_decl (tmp
);
2187 /* For non-constant length array arguments, make sure they use
2188 a different type node from TYPE_ARG_TYPES type. */
2189 if (f
->sym
->attr
.dimension
2190 && type
== TREE_VALUE (typelist
)
2191 && TREE_CODE (type
) == POINTER_TYPE
2192 && GFC_ARRAY_TYPE_P (type
)
2193 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2194 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2196 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2197 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2199 type
= gfc_sym_type (f
->sym
);
2202 if (f
->sym
->attr
.proc_pointer
)
2203 type
= build_pointer_type (type
);
2205 if (f
->sym
->attr
.volatile_
)
2206 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2208 /* Build the argument declaration. */
2209 parm
= build_decl (input_location
,
2210 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2212 if (f
->sym
->attr
.volatile_
)
2214 TREE_THIS_VOLATILE (parm
) = 1;
2215 TREE_SIDE_EFFECTS (parm
) = 1;
2218 /* Fill in arg stuff. */
2219 DECL_CONTEXT (parm
) = fndecl
;
2220 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2221 /* All implementation args are read-only. */
2222 TREE_READONLY (parm
) = 1;
2223 if (POINTER_TYPE_P (type
)
2224 && (!f
->sym
->attr
.proc_pointer
2225 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2226 DECL_BY_REFERENCE (parm
) = 1;
2228 gfc_finish_decl (parm
);
2230 f
->sym
->backend_decl
= parm
;
2232 /* Coarrays which are descriptorless or assumed-shape pass with
2233 -fcoarray=lib the token and the offset as hidden arguments. */
2234 if (f
->sym
->attr
.codimension
2235 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
2236 && !f
->sym
->attr
.allocatable
)
2242 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2243 && !sym
->attr
.is_bind_c
);
2244 caf_type
= TREE_TYPE (f
->sym
->backend_decl
);
2246 token
= build_decl (input_location
, PARM_DECL
,
2247 create_tmp_var_name ("caf_token"),
2248 build_qualified_type (pvoid_type_node
,
2249 TYPE_QUAL_RESTRICT
));
2250 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2252 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2253 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2254 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2255 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2256 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2260 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2261 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2264 DECL_CONTEXT (token
) = fndecl
;
2265 DECL_ARTIFICIAL (token
) = 1;
2266 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2267 TREE_READONLY (token
) = 1;
2268 hidden_arglist
= chainon (hidden_arglist
, token
);
2269 gfc_finish_decl (token
);
2271 offset
= build_decl (input_location
, PARM_DECL
,
2272 create_tmp_var_name ("caf_offset"),
2273 gfc_array_index_type
);
2275 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2277 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2279 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2283 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2284 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2286 DECL_CONTEXT (offset
) = fndecl
;
2287 DECL_ARTIFICIAL (offset
) = 1;
2288 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2289 TREE_READONLY (offset
) = 1;
2290 hidden_arglist
= chainon (hidden_arglist
, offset
);
2291 gfc_finish_decl (offset
);
2294 arglist
= chainon (arglist
, parm
);
2295 typelist
= TREE_CHAIN (typelist
);
2298 /* Add the hidden string length parameters, unless the procedure
2300 if (!sym
->attr
.is_bind_c
)
2301 arglist
= chainon (arglist
, hidden_arglist
);
2303 gcc_assert (hidden_typelist
== NULL_TREE
2304 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2305 DECL_ARGUMENTS (fndecl
) = arglist
;
2308 /* Do the setup necessary before generating the body of a function. */
2311 trans_function_start (gfc_symbol
* sym
)
2315 fndecl
= sym
->backend_decl
;
2317 /* Let GCC know the current scope is this function. */
2318 current_function_decl
= fndecl
;
2320 /* Let the world know what we're about to do. */
2321 announce_function (fndecl
);
2323 if (DECL_FILE_SCOPE_P (fndecl
))
2325 /* Create RTL for function declaration. */
2326 rest_of_decl_compilation (fndecl
, 1, 0);
2329 /* Create RTL for function definition. */
2330 make_decl_rtl (fndecl
);
2332 allocate_struct_function (fndecl
, false);
2334 /* function.c requires a push at the start of the function. */
2338 /* Create thunks for alternate entry points. */
2341 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2343 gfc_formal_arglist
*formal
;
2344 gfc_formal_arglist
*thunk_formal
;
2346 gfc_symbol
*thunk_sym
;
2352 /* This should always be a toplevel function. */
2353 gcc_assert (current_function_decl
== NULL_TREE
);
2355 gfc_save_backend_locus (&old_loc
);
2356 for (el
= ns
->entries
; el
; el
= el
->next
)
2358 vec
<tree
, va_gc
> *args
= NULL
;
2359 vec
<tree
, va_gc
> *string_args
= NULL
;
2361 thunk_sym
= el
->sym
;
2363 build_function_decl (thunk_sym
, global
);
2364 create_function_arglist (thunk_sym
);
2366 trans_function_start (thunk_sym
);
2368 thunk_fndecl
= thunk_sym
->backend_decl
;
2370 gfc_init_block (&body
);
2372 /* Pass extra parameter identifying this entry point. */
2373 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2374 vec_safe_push (args
, tmp
);
2376 if (thunk_sym
->attr
.function
)
2378 if (gfc_return_by_reference (ns
->proc_name
))
2380 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2381 vec_safe_push (args
, ref
);
2382 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2383 vec_safe_push (args
, DECL_CHAIN (ref
));
2387 for (formal
= gfc_sym_get_dummy_args (ns
->proc_name
); formal
;
2388 formal
= formal
->next
)
2390 /* Ignore alternate returns. */
2391 if (formal
->sym
== NULL
)
2394 /* We don't have a clever way of identifying arguments, so resort to
2395 a brute-force search. */
2396 for (thunk_formal
= gfc_sym_get_dummy_args (thunk_sym
);
2398 thunk_formal
= thunk_formal
->next
)
2400 if (thunk_formal
->sym
== formal
->sym
)
2406 /* Pass the argument. */
2407 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2408 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2409 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2411 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2412 vec_safe_push (string_args
, tmp
);
2417 /* Pass NULL for a missing argument. */
2418 vec_safe_push (args
, null_pointer_node
);
2419 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2421 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2422 vec_safe_push (string_args
, tmp
);
2427 /* Call the master function. */
2428 vec_safe_splice (args
, string_args
);
2429 tmp
= ns
->proc_name
->backend_decl
;
2430 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2431 if (ns
->proc_name
->attr
.mixed_entry_master
)
2433 tree union_decl
, field
;
2434 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2436 union_decl
= build_decl (input_location
,
2437 VAR_DECL
, get_identifier ("__result"),
2438 TREE_TYPE (master_type
));
2439 DECL_ARTIFICIAL (union_decl
) = 1;
2440 DECL_EXTERNAL (union_decl
) = 0;
2441 TREE_PUBLIC (union_decl
) = 0;
2442 TREE_USED (union_decl
) = 1;
2443 layout_decl (union_decl
, 0);
2444 pushdecl (union_decl
);
2446 DECL_CONTEXT (union_decl
) = current_function_decl
;
2447 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2448 TREE_TYPE (union_decl
), union_decl
, tmp
);
2449 gfc_add_expr_to_block (&body
, tmp
);
2451 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2452 field
; field
= DECL_CHAIN (field
))
2453 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2454 thunk_sym
->result
->name
) == 0)
2456 gcc_assert (field
!= NULL_TREE
);
2457 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2458 TREE_TYPE (field
), union_decl
, field
,
2460 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2461 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2462 DECL_RESULT (current_function_decl
), tmp
);
2463 tmp
= build1_v (RETURN_EXPR
, tmp
);
2465 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2468 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2469 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2470 DECL_RESULT (current_function_decl
), tmp
);
2471 tmp
= build1_v (RETURN_EXPR
, tmp
);
2473 gfc_add_expr_to_block (&body
, tmp
);
2475 /* Finish off this function and send it for code generation. */
2476 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2479 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2480 DECL_SAVED_TREE (thunk_fndecl
)
2481 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2482 DECL_INITIAL (thunk_fndecl
));
2484 /* Output the GENERIC tree. */
2485 dump_function (TDI_original
, thunk_fndecl
);
2487 /* Store the end of the function, so that we get good line number
2488 info for the epilogue. */
2489 cfun
->function_end_locus
= input_location
;
2491 /* We're leaving the context of this function, so zap cfun.
2492 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2493 tree_rest_of_compilation. */
2496 current_function_decl
= NULL_TREE
;
2498 cgraph_finalize_function (thunk_fndecl
, true);
2500 /* We share the symbols in the formal argument list with other entry
2501 points and the master function. Clear them so that they are
2502 recreated for each function. */
2503 for (formal
= gfc_sym_get_dummy_args (thunk_sym
); formal
;
2504 formal
= formal
->next
)
2505 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2507 formal
->sym
->backend_decl
= NULL_TREE
;
2508 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2509 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2512 if (thunk_sym
->attr
.function
)
2514 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2515 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2516 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2517 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2521 gfc_restore_backend_locus (&old_loc
);
2525 /* Create a decl for a function, and create any thunks for alternate entry
2526 points. If global is true, generate the function in the global binding
2527 level, otherwise in the current binding level (which can be global). */
2530 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
2532 /* Create a declaration for the master function. */
2533 build_function_decl (ns
->proc_name
, global
);
2535 /* Compile the entry thunks. */
2537 build_entry_thunks (ns
, global
);
2539 /* Now create the read argument list. */
2540 create_function_arglist (ns
->proc_name
);
2543 /* Return the decl used to hold the function return value. If
2544 parent_flag is set, the context is the parent_scope. */
2547 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2551 tree this_fake_result_decl
;
2552 tree this_function_decl
;
2554 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2558 this_fake_result_decl
= parent_fake_result_decl
;
2559 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2563 this_fake_result_decl
= current_fake_result_decl
;
2564 this_function_decl
= current_function_decl
;
2568 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2569 && sym
->ns
->proc_name
->attr
.entry_master
2570 && sym
!= sym
->ns
->proc_name
)
2573 if (this_fake_result_decl
!= NULL
)
2574 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2575 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2578 return TREE_VALUE (t
);
2579 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2582 this_fake_result_decl
= parent_fake_result_decl
;
2584 this_fake_result_decl
= current_fake_result_decl
;
2586 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2590 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2591 field
; field
= DECL_CHAIN (field
))
2592 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2596 gcc_assert (field
!= NULL_TREE
);
2597 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2598 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
2601 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2603 gfc_add_decl_to_parent_function (var
);
2605 gfc_add_decl_to_function (var
);
2607 SET_DECL_VALUE_EXPR (var
, decl
);
2608 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2609 GFC_DECL_RESULT (var
) = 1;
2611 TREE_CHAIN (this_fake_result_decl
)
2612 = tree_cons (get_identifier (sym
->name
), var
,
2613 TREE_CHAIN (this_fake_result_decl
));
2617 if (this_fake_result_decl
!= NULL_TREE
)
2618 return TREE_VALUE (this_fake_result_decl
);
2620 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2625 if (sym
->ts
.type
== BT_CHARACTER
)
2627 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2628 length
= gfc_create_string_length (sym
);
2630 length
= sym
->ts
.u
.cl
->backend_decl
;
2631 if (TREE_CODE (length
) == VAR_DECL
2632 && DECL_CONTEXT (length
) == NULL_TREE
)
2633 gfc_add_decl_to_function (length
);
2636 if (gfc_return_by_reference (sym
))
2638 decl
= DECL_ARGUMENTS (this_function_decl
);
2640 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2641 && sym
->ns
->proc_name
->attr
.entry_master
)
2642 decl
= DECL_CHAIN (decl
);
2644 TREE_USED (decl
) = 1;
2646 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2650 sprintf (name
, "__result_%.20s",
2651 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2653 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2654 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2655 VAR_DECL
, get_identifier (name
),
2656 gfc_sym_type (sym
));
2658 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2659 VAR_DECL
, get_identifier (name
),
2660 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2661 DECL_ARTIFICIAL (decl
) = 1;
2662 DECL_EXTERNAL (decl
) = 0;
2663 TREE_PUBLIC (decl
) = 0;
2664 TREE_USED (decl
) = 1;
2665 GFC_DECL_RESULT (decl
) = 1;
2666 TREE_ADDRESSABLE (decl
) = 1;
2668 layout_decl (decl
, 0);
2671 gfc_add_decl_to_parent_function (decl
);
2673 gfc_add_decl_to_function (decl
);
2677 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2679 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2685 /* Builds a function decl. The remaining parameters are the types of the
2686 function arguments. Negative nargs indicates a varargs function. */
2689 build_library_function_decl_1 (tree name
, const char *spec
,
2690 tree rettype
, int nargs
, va_list p
)
2692 vec
<tree
, va_gc
> *arglist
;
2697 /* Library functions must be declared with global scope. */
2698 gcc_assert (current_function_decl
== NULL_TREE
);
2700 /* Create a list of the argument types. */
2701 vec_alloc (arglist
, abs (nargs
));
2702 for (n
= abs (nargs
); n
> 0; n
--)
2704 tree argtype
= va_arg (p
, tree
);
2705 arglist
->quick_push (argtype
);
2708 /* Build the function type and decl. */
2710 fntype
= build_function_type_vec (rettype
, arglist
);
2712 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
2715 tree attr_args
= build_tree_list (NULL_TREE
,
2716 build_string (strlen (spec
), spec
));
2717 tree attrs
= tree_cons (get_identifier ("fn spec"),
2718 attr_args
, TYPE_ATTRIBUTES (fntype
));
2719 fntype
= build_type_attribute_variant (fntype
, attrs
);
2721 fndecl
= build_decl (input_location
,
2722 FUNCTION_DECL
, name
, fntype
);
2724 /* Mark this decl as external. */
2725 DECL_EXTERNAL (fndecl
) = 1;
2726 TREE_PUBLIC (fndecl
) = 1;
2730 rest_of_decl_compilation (fndecl
, 1, 0);
2735 /* Builds a function decl. The remaining parameters are the types of the
2736 function arguments. Negative nargs indicates a varargs function. */
2739 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2743 va_start (args
, nargs
);
2744 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
2749 /* Builds a function decl. The remaining parameters are the types of the
2750 function arguments. Negative nargs indicates a varargs function.
2751 The SPEC parameter specifies the function argument and return type
2752 specification according to the fnspec function type attribute. */
2755 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
2756 tree rettype
, int nargs
, ...)
2760 va_start (args
, nargs
);
2761 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
2767 gfc_build_intrinsic_function_decls (void)
2769 tree gfc_int4_type_node
= gfc_get_int_type (4);
2770 tree gfc_int8_type_node
= gfc_get_int_type (8);
2771 tree gfc_int16_type_node
= gfc_get_int_type (16);
2772 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2773 tree pchar1_type_node
= gfc_get_pchar_type (1);
2774 tree pchar4_type_node
= gfc_get_pchar_type (4);
2776 /* String functions. */
2777 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
2778 get_identifier (PREFIX("compare_string")), "..R.R",
2779 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
2780 gfc_charlen_type_node
, pchar1_type_node
);
2781 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
2782 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
2784 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
2785 get_identifier (PREFIX("concat_string")), "..W.R.R",
2786 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
2787 gfc_charlen_type_node
, pchar1_type_node
,
2788 gfc_charlen_type_node
, pchar1_type_node
);
2789 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
2791 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
2792 get_identifier (PREFIX("string_len_trim")), "..R",
2793 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
2794 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
2795 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
2797 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
2798 get_identifier (PREFIX("string_index")), "..R.R.",
2799 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2800 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2801 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
2802 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
2804 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
2805 get_identifier (PREFIX("string_scan")), "..R.R.",
2806 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2807 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2808 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
2809 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
2811 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
2812 get_identifier (PREFIX("string_verify")), "..R.R.",
2813 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2814 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2815 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
2816 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
2818 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
2819 get_identifier (PREFIX("string_trim")), ".Ww.R",
2820 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2821 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
2824 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
2825 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2826 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2827 build_pointer_type (pchar1_type_node
), integer_type_node
,
2830 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
2831 get_identifier (PREFIX("adjustl")), ".W.R",
2832 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2834 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
2836 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
2837 get_identifier (PREFIX("adjustr")), ".W.R",
2838 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2840 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
2842 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
2843 get_identifier (PREFIX("select_string")), ".R.R.",
2844 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2845 pchar1_type_node
, gfc_charlen_type_node
);
2846 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
2847 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
2849 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
2850 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2851 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
2852 gfc_charlen_type_node
, pchar4_type_node
);
2853 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
2854 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
2856 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
2857 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2858 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
2859 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
2861 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
2863 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
2864 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2865 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
2866 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
2867 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
2869 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
2870 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2871 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2872 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2873 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
2874 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
2876 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
2877 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2878 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2879 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2880 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
2881 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
2883 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
2884 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2885 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2886 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2887 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
2888 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
2890 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
2891 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2892 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2893 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
2896 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
2897 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2898 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2899 build_pointer_type (pchar4_type_node
), integer_type_node
,
2902 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
2903 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2904 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2906 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
2908 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
2909 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2910 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2912 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
2914 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
2915 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2916 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2917 pvoid_type_node
, gfc_charlen_type_node
);
2918 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
2919 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
2922 /* Conversion between character kinds. */
2924 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
2925 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2926 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
2927 gfc_charlen_type_node
, pchar1_type_node
);
2929 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
2930 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2931 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
2932 gfc_charlen_type_node
, pchar4_type_node
);
2934 /* Misc. functions. */
2936 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
2937 get_identifier (PREFIX("ttynam")), ".W",
2938 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2941 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
2942 get_identifier (PREFIX("fdate")), ".W",
2943 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
2945 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
2946 get_identifier (PREFIX("ctime")), ".W",
2947 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2948 gfc_int8_type_node
);
2950 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
2951 get_identifier (PREFIX("selected_char_kind")), "..R",
2952 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
2953 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
2954 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
2956 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
2957 get_identifier (PREFIX("selected_int_kind")), ".R",
2958 gfc_int4_type_node
, 1, pvoid_type_node
);
2959 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
2960 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
2962 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
2963 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2964 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
2966 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
2967 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
2969 /* Power functions. */
2971 tree ctype
, rtype
, itype
, jtype
;
2972 int rkind
, ikind
, jkind
;
2975 static int ikinds
[NIKINDS
] = {4, 8, 16};
2976 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2977 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2979 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2981 itype
= gfc_get_int_type (ikinds
[ikind
]);
2983 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2985 jtype
= gfc_get_int_type (ikinds
[jkind
]);
2988 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
2990 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
2991 gfc_build_library_function_decl (get_identifier (name
),
2992 jtype
, 2, jtype
, itype
);
2993 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2994 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2998 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
3000 rtype
= gfc_get_real_type (rkinds
[rkind
]);
3003 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
3005 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
3006 gfc_build_library_function_decl (get_identifier (name
),
3007 rtype
, 2, rtype
, itype
);
3008 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3009 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3012 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
3015 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
3017 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
3018 gfc_build_library_function_decl (get_identifier (name
),
3019 ctype
, 2,ctype
, itype
);
3020 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3021 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3029 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
3030 get_identifier (PREFIX("ishftc4")),
3031 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
3032 gfc_int4_type_node
);
3033 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
3034 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
3036 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
3037 get_identifier (PREFIX("ishftc8")),
3038 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
3039 gfc_int4_type_node
);
3040 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
3041 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
3043 if (gfc_int16_type_node
)
3045 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
3046 get_identifier (PREFIX("ishftc16")),
3047 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3048 gfc_int4_type_node
);
3049 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3050 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3053 /* BLAS functions. */
3055 tree pint
= build_pointer_type (integer_type_node
);
3056 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3057 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3058 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3059 tree pz
= build_pointer_type
3060 (gfc_get_complex_type (gfc_default_double_kind
));
3062 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3064 (gfc_option
.flag_underscoring
? "sgemm_"
3066 void_type_node
, 15, pchar_type_node
,
3067 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3068 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3070 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3072 (gfc_option
.flag_underscoring
? "dgemm_"
3074 void_type_node
, 15, pchar_type_node
,
3075 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3076 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3078 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3080 (gfc_option
.flag_underscoring
? "cgemm_"
3082 void_type_node
, 15, pchar_type_node
,
3083 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3084 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3086 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3088 (gfc_option
.flag_underscoring
? "zgemm_"
3090 void_type_node
, 15, pchar_type_node
,
3091 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3092 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3096 /* Other functions. */
3097 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3098 get_identifier (PREFIX("size0")), ".R",
3099 gfc_array_index_type
, 1, pvoid_type_node
);
3100 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3101 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3103 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3104 get_identifier (PREFIX("size1")), ".R",
3105 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3106 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3107 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3109 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3110 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3111 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3115 /* Make prototypes for runtime library functions. */
3118 gfc_build_builtin_function_decls (void)
3120 tree gfc_int4_type_node
= gfc_get_int_type (4);
3122 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3123 get_identifier (PREFIX("stop_numeric")),
3124 void_type_node
, 1, gfc_int4_type_node
);
3125 /* STOP doesn't return. */
3126 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3128 gfor_fndecl_stop_numeric_f08
= gfc_build_library_function_decl (
3129 get_identifier (PREFIX("stop_numeric_f08")),
3130 void_type_node
, 1, gfc_int4_type_node
);
3131 /* STOP doesn't return. */
3132 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08
) = 1;
3134 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3135 get_identifier (PREFIX("stop_string")), ".R.",
3136 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3137 /* STOP doesn't return. */
3138 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3140 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3141 get_identifier (PREFIX("error_stop_numeric")),
3142 void_type_node
, 1, gfc_int4_type_node
);
3143 /* ERROR STOP doesn't return. */
3144 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3146 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3147 get_identifier (PREFIX("error_stop_string")), ".R.",
3148 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3149 /* ERROR STOP doesn't return. */
3150 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3152 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3153 get_identifier (PREFIX("pause_numeric")),
3154 void_type_node
, 1, gfc_int4_type_node
);
3156 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3157 get_identifier (PREFIX("pause_string")), ".R.",
3158 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3160 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3161 get_identifier (PREFIX("runtime_error")), ".R",
3162 void_type_node
, -1, pchar_type_node
);
3163 /* The runtime_error function does not return. */
3164 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3166 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3167 get_identifier (PREFIX("runtime_error_at")), ".RR",
3168 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3169 /* The runtime_error_at function does not return. */
3170 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3172 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3173 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3174 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3176 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3177 get_identifier (PREFIX("generate_error")), ".R.R",
3178 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3181 gfor_fndecl_os_error
= gfc_build_library_function_decl_with_spec (
3182 get_identifier (PREFIX("os_error")), ".R",
3183 void_type_node
, 1, pchar_type_node
);
3184 /* The runtime_error function does not return. */
3185 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
3187 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3188 get_identifier (PREFIX("set_args")),
3189 void_type_node
, 2, integer_type_node
,
3190 build_pointer_type (pchar_type_node
));
3192 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3193 get_identifier (PREFIX("set_fpe")),
3194 void_type_node
, 1, integer_type_node
);
3196 /* Keep the array dimension in sync with the call, later in this file. */
3197 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3198 get_identifier (PREFIX("set_options")), "..R",
3199 void_type_node
, 2, integer_type_node
,
3200 build_pointer_type (integer_type_node
));
3202 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3203 get_identifier (PREFIX("set_convert")),
3204 void_type_node
, 1, integer_type_node
);
3206 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3207 get_identifier (PREFIX("set_record_marker")),
3208 void_type_node
, 1, integer_type_node
);
3210 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3211 get_identifier (PREFIX("set_max_subrecord_length")),
3212 void_type_node
, 1, integer_type_node
);
3214 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3215 get_identifier (PREFIX("internal_pack")), ".r",
3216 pvoid_type_node
, 1, pvoid_type_node
);
3218 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3219 get_identifier (PREFIX("internal_unpack")), ".wR",
3220 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3222 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3223 get_identifier (PREFIX("associated")), ".RR",
3224 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3225 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3226 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3228 /* Coarray library calls. */
3229 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
3231 tree pint_type
, pppchar_type
;
3233 pint_type
= build_pointer_type (integer_type_node
);
3235 = build_pointer_type (build_pointer_type (pchar_type_node
));
3237 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3238 get_identifier (PREFIX("caf_init")), void_type_node
,
3239 4, pint_type
, pppchar_type
, pint_type
, pint_type
);
3241 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3242 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3244 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3245 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node
, 6,
3246 size_type_node
, integer_type_node
, ppvoid_type_node
, pint_type
,
3247 pchar_type_node
, integer_type_node
);
3249 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3250 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node
, 4,
3251 ppvoid_type_node
, pint_type
, pchar_type_node
, integer_type_node
);
3253 gfor_fndecl_caf_critical
= gfc_build_library_function_decl (
3254 get_identifier (PREFIX("caf_critical")), void_type_node
, 0);
3256 gfor_fndecl_caf_end_critical
= gfc_build_library_function_decl (
3257 get_identifier (PREFIX("caf_end_critical")), void_type_node
, 0);
3259 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3260 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3261 3, pint_type
, build_pointer_type (pchar_type_node
), integer_type_node
);
3263 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3264 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3265 5, integer_type_node
, pint_type
, pint_type
,
3266 build_pointer_type (pchar_type_node
), integer_type_node
);
3268 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3269 get_identifier (PREFIX("caf_error_stop")),
3270 void_type_node
, 1, gfc_int4_type_node
);
3271 /* CAF's ERROR STOP doesn't return. */
3272 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3274 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3275 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3276 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3277 /* CAF's ERROR STOP doesn't return. */
3278 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3281 gfc_build_intrinsic_function_decls ();
3282 gfc_build_intrinsic_lib_fndecls ();
3283 gfc_build_io_library_fndecls ();
3287 /* Evaluate the length of dummy character variables. */
3290 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
3291 gfc_wrapped_block
*block
)
3295 gfc_finish_decl (cl
->backend_decl
);
3297 gfc_start_block (&init
);
3299 /* Evaluate the string length expression. */
3300 gfc_conv_string_length (cl
, NULL
, &init
);
3302 gfc_trans_vla_type_sizes (sym
, &init
);
3304 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3308 /* Allocate and cleanup an automatic character variable. */
3311 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3317 gcc_assert (sym
->backend_decl
);
3318 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
3320 gfc_init_block (&init
);
3322 /* Evaluate the string length expression. */
3323 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
3325 gfc_trans_vla_type_sizes (sym
, &init
);
3327 decl
= sym
->backend_decl
;
3329 /* Emit a DECL_EXPR for this variable, which will cause the
3330 gimplifier to allocate storage, and all that good stuff. */
3331 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
3332 gfc_add_expr_to_block (&init
, tmp
);
3334 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3337 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3340 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3344 gcc_assert (sym
->backend_decl
);
3345 gfc_start_block (&init
);
3347 /* Set the initial value to length. See the comments in
3348 function gfc_add_assign_aux_vars in this file. */
3349 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
3350 build_int_cst (gfc_charlen_type_node
, -2));
3352 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3356 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
3358 tree t
= *tp
, var
, val
;
3360 if (t
== NULL
|| t
== error_mark_node
)
3362 if (TREE_CONSTANT (t
) || DECL_P (t
))
3365 if (TREE_CODE (t
) == SAVE_EXPR
)
3367 if (SAVE_EXPR_RESOLVED_P (t
))
3369 *tp
= TREE_OPERAND (t
, 0);
3372 val
= TREE_OPERAND (t
, 0);
3377 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
3378 gfc_add_decl_to_function (var
);
3379 gfc_add_modify (body
, var
, val
);
3380 if (TREE_CODE (t
) == SAVE_EXPR
)
3381 TREE_OPERAND (t
, 0) = var
;
3386 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
3390 if (type
== NULL
|| type
== error_mark_node
)
3393 type
= TYPE_MAIN_VARIANT (type
);
3395 if (TREE_CODE (type
) == INTEGER_TYPE
)
3397 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
3398 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
3400 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3402 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
3403 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
3406 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3408 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
3409 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
3410 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
3411 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
3413 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3415 TYPE_SIZE (t
) = TYPE_SIZE (type
);
3416 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
3421 /* Make sure all type sizes and array domains are either constant,
3422 or variable or parameter decls. This is a simplified variant
3423 of gimplify_type_sizes, but we can't use it here, as none of the
3424 variables in the expressions have been gimplified yet.
3425 As type sizes and domains for various variable length arrays
3426 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3427 time, without this routine gimplify_type_sizes in the middle-end
3428 could result in the type sizes being gimplified earlier than where
3429 those variables are initialized. */
3432 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
3434 tree type
= TREE_TYPE (sym
->backend_decl
);
3436 if (TREE_CODE (type
) == FUNCTION_TYPE
3437 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
3439 if (! current_fake_result_decl
)
3442 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
3445 while (POINTER_TYPE_P (type
))
3446 type
= TREE_TYPE (type
);
3448 if (GFC_DESCRIPTOR_TYPE_P (type
))
3450 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3452 while (POINTER_TYPE_P (etype
))
3453 etype
= TREE_TYPE (etype
);
3455 gfc_trans_vla_type_sizes_1 (etype
, body
);
3458 gfc_trans_vla_type_sizes_1 (type
, body
);
3462 /* Initialize a derived type by building an lvalue from the symbol
3463 and using trans_assignment to do the work. Set dealloc to false
3464 if no deallocation prior the assignment is needed. */
3466 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
3474 gcc_assert (!sym
->attr
.allocatable
);
3475 gfc_set_sym_referenced (sym
);
3476 e
= gfc_lval_expr_from_sym (sym
);
3477 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3478 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3479 || sym
->ns
->proc_name
->attr
.entry_master
))
3481 present
= gfc_conv_expr_present (sym
);
3482 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
3483 tmp
, build_empty_stmt (input_location
));
3485 gfc_add_expr_to_block (block
, tmp
);
3490 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3491 them their default initializer, if they do not have allocatable
3492 components, they have their allocatable components deallocated. */
3495 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3498 gfc_formal_arglist
*f
;
3502 gfc_init_block (&init
);
3503 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
3504 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3505 && !f
->sym
->attr
.pointer
3506 && f
->sym
->ts
.type
== BT_DERIVED
)
3510 /* Note: Allocatables are excluded as they are already handled
3512 if (!f
->sym
->attr
.allocatable
3513 && gfc_is_finalizable (f
->sym
->ts
.u
.derived
, NULL
))
3518 gfc_init_block (&block
);
3519 f
->sym
->attr
.referenced
= 1;
3520 e
= gfc_lval_expr_from_sym (f
->sym
);
3521 gfc_add_finalizer_call (&block
, e
);
3523 tmp
= gfc_finish_block (&block
);
3526 if (tmp
== NULL_TREE
&& !f
->sym
->attr
.allocatable
3527 && f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3528 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3529 f
->sym
->backend_decl
,
3530 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3532 if (tmp
!= NULL_TREE
&& (f
->sym
->attr
.optional
3533 || f
->sym
->ns
->proc_name
->attr
.entry_master
))
3535 present
= gfc_conv_expr_present (f
->sym
);
3536 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3537 present
, tmp
, build_empty_stmt (input_location
));
3540 if (tmp
!= NULL_TREE
)
3541 gfc_add_expr_to_block (&init
, tmp
);
3542 else if (f
->sym
->value
&& !f
->sym
->attr
.allocatable
)
3543 gfc_init_default_dt (f
->sym
, &init
, true);
3545 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3546 && f
->sym
->ts
.type
== BT_CLASS
3547 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3548 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)
3553 gfc_init_block (&block
);
3554 f
->sym
->attr
.referenced
= 1;
3555 e
= gfc_lval_expr_from_sym (f
->sym
);
3556 gfc_add_finalizer_call (&block
, e
);
3558 tmp
= gfc_finish_block (&block
);
3560 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
3562 present
= gfc_conv_expr_present (f
->sym
);
3563 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3565 build_empty_stmt (input_location
));
3568 gfc_add_expr_to_block (&init
, tmp
);
3571 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3575 /* Generate function entry and exit code, and add it to the function body.
3577 Allocation and initialization of array variables.
3578 Allocation of character string variables.
3579 Initialization and possibly repacking of dummy arrays.
3580 Initialization of ASSIGN statement auxiliary variable.
3581 Initialization of ASSOCIATE names.
3582 Automatic deallocation. */
3585 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3589 gfc_formal_arglist
*f
;
3590 stmtblock_t tmpblock
;
3591 bool seen_trans_deferred_array
= false;
3597 /* Deal with implicit return variables. Explicit return variables will
3598 already have been added. */
3599 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
3601 if (!current_fake_result_decl
)
3603 gfc_entry_list
*el
= NULL
;
3604 if (proc_sym
->attr
.entry_master
)
3606 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
3607 if (el
->sym
!= el
->sym
->result
)
3610 /* TODO: move to the appropriate place in resolve.c. */
3611 if (warn_return_type
&& el
== NULL
)
3612 gfc_warning ("Return value of function '%s' at %L not set",
3613 proc_sym
->name
, &proc_sym
->declared_at
);
3615 else if (proc_sym
->as
)
3617 tree result
= TREE_VALUE (current_fake_result_decl
);
3618 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
3620 /* An automatic character length, pointer array result. */
3621 if (proc_sym
->ts
.type
== BT_CHARACTER
3622 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3623 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3625 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
3627 if (proc_sym
->ts
.deferred
)
3630 gfc_save_backend_locus (&loc
);
3631 gfc_set_backend_locus (&proc_sym
->declared_at
);
3632 gfc_start_block (&init
);
3633 /* Zero the string length on entry. */
3634 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
3635 build_int_cst (gfc_charlen_type_node
, 0));
3636 /* Null the pointer. */
3637 e
= gfc_lval_expr_from_sym (proc_sym
);
3638 gfc_init_se (&se
, NULL
);
3639 se
.want_pointer
= 1;
3640 gfc_conv_expr (&se
, e
);
3643 gfc_add_modify (&init
, tmp
,
3644 fold_convert (TREE_TYPE (se
.expr
),
3645 null_pointer_node
));
3646 gfc_restore_backend_locus (&loc
);
3648 /* Pass back the string length on exit. */
3649 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
3650 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3651 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3652 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3653 gfc_charlen_type_node
, tmp
,
3654 proc_sym
->ts
.u
.cl
->backend_decl
);
3655 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3657 else if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3658 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3661 gcc_assert (gfc_option
.flag_f2c
3662 && proc_sym
->ts
.type
== BT_COMPLEX
);
3665 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3666 should be done here so that the offsets and lbounds of arrays
3668 gfc_save_backend_locus (&loc
);
3669 gfc_set_backend_locus (&proc_sym
->declared_at
);
3670 init_intent_out_dt (proc_sym
, block
);
3671 gfc_restore_backend_locus (&loc
);
3673 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
3675 bool alloc_comp_or_fini
= (sym
->ts
.type
== BT_DERIVED
)
3676 && (sym
->ts
.u
.derived
->attr
.alloc_comp
3677 || gfc_is_finalizable (sym
->ts
.u
.derived
,
3682 if (sym
->attr
.subref_array_pointer
3683 && GFC_DECL_SPAN (sym
->backend_decl
)
3684 && !TREE_STATIC (GFC_DECL_SPAN (sym
->backend_decl
)))
3686 gfc_init_block (&tmpblock
);
3687 gfc_add_modify (&tmpblock
, GFC_DECL_SPAN (sym
->backend_decl
),
3688 build_int_cst (gfc_array_index_type
, 0));
3689 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3693 if (sym
->ts
.type
== BT_CLASS
3694 && (sym
->attr
.save
|| gfc_option
.flag_max_stack_var_size
== 0)
3695 && CLASS_DATA (sym
)->attr
.allocatable
)
3699 if (UNLIMITED_POLY (sym
))
3700 vptr
= null_pointer_node
;
3704 vsym
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3705 vptr
= gfc_get_symbol_decl (vsym
);
3706 vptr
= gfc_build_addr_expr (NULL
, vptr
);
3709 if (CLASS_DATA (sym
)->attr
.dimension
3710 || (CLASS_DATA (sym
)->attr
.codimension
3711 && gfc_option
.coarray
!= GFC_FCOARRAY_LIB
))
3713 tmp
= gfc_class_data_get (sym
->backend_decl
);
3714 tmp
= gfc_build_null_descriptor (TREE_TYPE (tmp
));
3717 tmp
= null_pointer_node
;
3719 DECL_INITIAL (sym
->backend_decl
)
3720 = gfc_class_set_static_fields (sym
->backend_decl
, vptr
, tmp
);
3721 TREE_CONSTANT (DECL_INITIAL (sym
->backend_decl
)) = 1;
3723 else if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3725 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3726 array_type tmp
= sym
->as
->type
;
3727 if (tmp
== AS_ASSUMED_SIZE
&& sym
->as
->cp_was_assumed
)
3732 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3733 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3734 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3736 if (TREE_STATIC (sym
->backend_decl
))
3738 gfc_save_backend_locus (&loc
);
3739 gfc_set_backend_locus (&sym
->declared_at
);
3740 gfc_trans_static_array_pointer (sym
);
3741 gfc_restore_backend_locus (&loc
);
3745 seen_trans_deferred_array
= true;
3746 gfc_trans_deferred_array (sym
, block
);
3749 else if (sym
->attr
.codimension
&& TREE_STATIC (sym
->backend_decl
))
3751 gfc_init_block (&tmpblock
);
3752 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
3754 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3758 else if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
3760 gfc_save_backend_locus (&loc
);
3761 gfc_set_backend_locus (&sym
->declared_at
);
3763 if (alloc_comp_or_fini
)
3765 seen_trans_deferred_array
= true;
3766 gfc_trans_deferred_array (sym
, block
);
3768 else if (sym
->ts
.type
== BT_DERIVED
3771 && sym
->attr
.save
== SAVE_NONE
)
3773 gfc_start_block (&tmpblock
);
3774 gfc_init_default_dt (sym
, &tmpblock
, false);
3775 gfc_add_init_cleanup (block
,
3776 gfc_finish_block (&tmpblock
),
3780 gfc_trans_auto_array_allocation (sym
->backend_decl
,
3782 gfc_restore_backend_locus (&loc
);
3786 case AS_ASSUMED_SIZE
:
3787 /* Must be a dummy parameter. */
3788 gcc_assert (sym
->attr
.dummy
|| sym
->as
->cp_was_assumed
);
3790 /* We should always pass assumed size arrays the g77 way. */
3791 if (sym
->attr
.dummy
)
3792 gfc_trans_g77_array (sym
, block
);
3795 case AS_ASSUMED_SHAPE
:
3796 /* Must be a dummy parameter. */
3797 gcc_assert (sym
->attr
.dummy
);
3799 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3802 case AS_ASSUMED_RANK
:
3804 seen_trans_deferred_array
= true;
3805 gfc_trans_deferred_array (sym
, block
);
3811 if (alloc_comp_or_fini
&& !seen_trans_deferred_array
)
3812 gfc_trans_deferred_array (sym
, block
);
3814 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3815 && (sym
->ts
.type
== BT_CLASS
3816 && CLASS_DATA (sym
)->attr
.class_pointer
))
3818 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3819 && (sym
->attr
.allocatable
3820 || (sym
->ts
.type
== BT_CLASS
3821 && CLASS_DATA (sym
)->attr
.allocatable
)))
3823 if (!sym
->attr
.save
&& gfc_option
.flag_max_stack_var_size
!= 0)
3825 tree descriptor
= NULL_TREE
;
3827 /* Nullify and automatic deallocation of allocatable
3829 e
= gfc_lval_expr_from_sym (sym
);
3830 if (sym
->ts
.type
== BT_CLASS
)
3831 gfc_add_data_component (e
);
3833 gfc_init_se (&se
, NULL
);
3834 if (sym
->ts
.type
!= BT_CLASS
3835 || sym
->ts
.u
.derived
->attr
.dimension
3836 || sym
->ts
.u
.derived
->attr
.codimension
)
3838 se
.want_pointer
= 1;
3839 gfc_conv_expr (&se
, e
);
3841 else if (sym
->ts
.type
== BT_CLASS
3842 && !CLASS_DATA (sym
)->attr
.dimension
3843 && !CLASS_DATA (sym
)->attr
.codimension
)
3845 se
.want_pointer
= 1;
3846 gfc_conv_expr (&se
, e
);
3850 gfc_conv_expr (&se
, e
);
3851 descriptor
= se
.expr
;
3852 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
3853 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
3857 gfc_save_backend_locus (&loc
);
3858 gfc_set_backend_locus (&sym
->declared_at
);
3859 gfc_start_block (&init
);
3861 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3863 /* Nullify when entering the scope. */
3864 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3865 TREE_TYPE (se
.expr
), se
.expr
,
3866 fold_convert (TREE_TYPE (se
.expr
),
3867 null_pointer_node
));
3868 if (sym
->attr
.optional
)
3870 tree present
= gfc_conv_expr_present (sym
);
3871 tmp
= build3_loc (input_location
, COND_EXPR
,
3872 void_type_node
, present
, tmp
,
3873 build_empty_stmt (input_location
));
3875 gfc_add_expr_to_block (&init
, tmp
);
3878 if ((sym
->attr
.dummy
|| sym
->attr
.result
)
3879 && sym
->ts
.type
== BT_CHARACTER
3880 && sym
->ts
.deferred
)
3882 /* Character length passed by reference. */
3883 tmp
= sym
->ts
.u
.cl
->passed_length
;
3884 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3885 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3887 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3888 /* Zero the string length when entering the scope. */
3889 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
,
3890 build_int_cst (gfc_charlen_type_node
, 0));
3895 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3896 gfc_charlen_type_node
,
3897 sym
->ts
.u
.cl
->backend_decl
, tmp
);
3898 if (sym
->attr
.optional
)
3900 tree present
= gfc_conv_expr_present (sym
);
3901 tmp2
= build3_loc (input_location
, COND_EXPR
,
3902 void_type_node
, present
, tmp2
,
3903 build_empty_stmt (input_location
));
3905 gfc_add_expr_to_block (&init
, tmp2
);
3908 gfc_restore_backend_locus (&loc
);
3910 /* Pass the final character length back. */
3911 if (sym
->attr
.intent
!= INTENT_IN
)
3913 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3914 gfc_charlen_type_node
, tmp
,
3915 sym
->ts
.u
.cl
->backend_decl
);
3916 if (sym
->attr
.optional
)
3918 tree present
= gfc_conv_expr_present (sym
);
3919 tmp
= build3_loc (input_location
, COND_EXPR
,
3920 void_type_node
, present
, tmp
,
3921 build_empty_stmt (input_location
));
3928 gfc_restore_backend_locus (&loc
);
3930 /* Deallocate when leaving the scope. Nullifying is not
3932 if (!sym
->attr
.result
&& !sym
->attr
.dummy
3933 && !sym
->ns
->proc_name
->attr
.is_main_program
)
3935 if (sym
->ts
.type
== BT_CLASS
3936 && CLASS_DATA (sym
)->attr
.codimension
)
3937 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
3938 NULL_TREE
, NULL_TREE
,
3939 NULL_TREE
, true, NULL
,
3943 gfc_expr
*expr
= gfc_lval_expr_from_sym (sym
);
3944 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, NULL_TREE
,
3945 true, expr
, sym
->ts
);
3946 gfc_free_expr (expr
);
3949 if (sym
->ts
.type
== BT_CLASS
)
3951 /* Initialize _vptr to declared type. */
3955 gfc_save_backend_locus (&loc
);
3956 gfc_set_backend_locus (&sym
->declared_at
);
3957 e
= gfc_lval_expr_from_sym (sym
);
3958 gfc_add_vptr_component (e
);
3959 gfc_init_se (&se
, NULL
);
3960 se
.want_pointer
= 1;
3961 gfc_conv_expr (&se
, e
);
3963 if (UNLIMITED_POLY (sym
))
3964 rhs
= build_int_cst (TREE_TYPE (se
.expr
), 0);
3967 vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3968 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
3969 gfc_get_symbol_decl (vtab
));
3971 gfc_add_modify (&init
, se
.expr
, rhs
);
3972 gfc_restore_backend_locus (&loc
);
3975 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3978 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
3983 /* If we get to here, all that should be left are pointers. */
3984 gcc_assert (sym
->attr
.pointer
);
3986 if (sym
->attr
.dummy
)
3988 gfc_start_block (&init
);
3990 /* Character length passed by reference. */
3991 tmp
= sym
->ts
.u
.cl
->passed_length
;
3992 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3993 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3994 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
3995 /* Pass the final character length back. */
3996 if (sym
->attr
.intent
!= INTENT_IN
)
3997 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3998 gfc_charlen_type_node
, tmp
,
3999 sym
->ts
.u
.cl
->backend_decl
);
4002 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4005 else if (sym
->ts
.deferred
)
4006 gfc_fatal_error ("Deferred type parameter not yet supported");
4007 else if (alloc_comp_or_fini
)
4008 gfc_trans_deferred_array (sym
, block
);
4009 else if (sym
->ts
.type
== BT_CHARACTER
)
4011 gfc_save_backend_locus (&loc
);
4012 gfc_set_backend_locus (&sym
->declared_at
);
4013 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4014 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
4016 gfc_trans_auto_character_variable (sym
, block
);
4017 gfc_restore_backend_locus (&loc
);
4019 else if (sym
->attr
.assign
)
4021 gfc_save_backend_locus (&loc
);
4022 gfc_set_backend_locus (&sym
->declared_at
);
4023 gfc_trans_assign_aux_var (sym
, block
);
4024 gfc_restore_backend_locus (&loc
);
4026 else if (sym
->ts
.type
== BT_DERIVED
4029 && sym
->attr
.save
== SAVE_NONE
)
4031 gfc_start_block (&tmpblock
);
4032 gfc_init_default_dt (sym
, &tmpblock
, false);
4033 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4036 else if (!(UNLIMITED_POLY(sym
)))
4040 gfc_init_block (&tmpblock
);
4042 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
4044 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
4046 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4047 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4048 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
4052 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
4053 && current_fake_result_decl
!= NULL
)
4055 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4056 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4057 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
4060 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
4063 static GTY ((param_is (struct module_htab_entry
))) htab_t module_htab
;
4065 /* Hash and equality functions for module_htab. */
4068 module_htab_do_hash (const void *x
)
4070 return htab_hash_string (((const struct module_htab_entry
*)x
)->name
);
4074 module_htab_eq (const void *x1
, const void *x2
)
4076 return strcmp ((((const struct module_htab_entry
*)x1
)->name
),
4077 (const char *)x2
) == 0;
4080 /* Hash and equality functions for module_htab's decls. */
4083 module_htab_decls_hash (const void *x
)
4085 const_tree t
= (const_tree
) x
;
4086 const_tree n
= DECL_NAME (t
);
4088 n
= TYPE_NAME (TREE_TYPE (t
));
4089 return htab_hash_string (IDENTIFIER_POINTER (n
));
4093 module_htab_decls_eq (const void *x1
, const void *x2
)
4095 const_tree t1
= (const_tree
) x1
;
4096 const_tree n1
= DECL_NAME (t1
);
4097 if (n1
== NULL_TREE
)
4098 n1
= TYPE_NAME (TREE_TYPE (t1
));
4099 return strcmp (IDENTIFIER_POINTER (n1
), (const char *) x2
) == 0;
4102 struct module_htab_entry
*
4103 gfc_find_module (const char *name
)
4108 module_htab
= htab_create_ggc (10, module_htab_do_hash
,
4109 module_htab_eq
, NULL
);
4111 slot
= htab_find_slot_with_hash (module_htab
, name
,
4112 htab_hash_string (name
), INSERT
);
4115 struct module_htab_entry
*entry
= ggc_alloc_cleared_module_htab_entry ();
4117 entry
->name
= gfc_get_string (name
);
4118 entry
->decls
= htab_create_ggc (10, module_htab_decls_hash
,
4119 module_htab_decls_eq
, NULL
);
4120 *slot
= (void *) entry
;
4122 return (struct module_htab_entry
*) *slot
;
4126 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
4131 if (DECL_NAME (decl
))
4132 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
4135 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
4136 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
4138 slot
= htab_find_slot_with_hash (entry
->decls
, name
,
4139 htab_hash_string (name
), INSERT
);
4141 *slot
= (void *) decl
;
4144 static struct module_htab_entry
*cur_module
;
4146 /* Output an initialized decl for a module variable. */
4149 gfc_create_module_variable (gfc_symbol
* sym
)
4153 /* Module functions with alternate entries are dealt with later and
4154 would get caught by the next condition. */
4155 if (sym
->attr
.entry
)
4158 /* Make sure we convert the types of the derived types from iso_c_binding
4160 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4161 && sym
->ts
.type
== BT_DERIVED
)
4162 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4164 if (sym
->attr
.flavor
== FL_DERIVED
4165 && sym
->backend_decl
4166 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
4168 decl
= sym
->backend_decl
;
4169 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4171 if (!sym
->attr
.use_assoc
)
4173 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
4174 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
4175 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
4176 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
4177 == sym
->ns
->proc_name
->backend_decl
);
4179 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4180 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
4181 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
4184 /* Only output variables, procedure pointers and array valued,
4185 or derived type, parameters. */
4186 if (sym
->attr
.flavor
!= FL_VARIABLE
4187 && !(sym
->attr
.flavor
== FL_PARAMETER
4188 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
4189 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4192 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
4194 decl
= sym
->backend_decl
;
4195 gcc_assert (DECL_FILE_SCOPE_P (decl
));
4196 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4197 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4198 gfc_module_add_decl (cur_module
, decl
);
4201 /* Don't generate variables from other modules. Variables from
4202 COMMONs will already have been generated. */
4203 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4206 /* Equivalenced variables arrive here after creation. */
4207 if (sym
->backend_decl
4208 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
4211 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
4212 internal_error ("backend decl for module variable %s already exists",
4215 /* We always want module variables to be created. */
4216 sym
->attr
.referenced
= 1;
4217 /* Create the decl. */
4218 decl
= gfc_get_symbol_decl (sym
);
4220 /* Create the variable. */
4222 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4223 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4224 rest_of_decl_compilation (decl
, 1, 0);
4225 gfc_module_add_decl (cur_module
, decl
);
4227 /* Also add length of strings. */
4228 if (sym
->ts
.type
== BT_CHARACTER
)
4232 length
= sym
->ts
.u
.cl
->backend_decl
;
4233 gcc_assert (length
|| sym
->attr
.proc_pointer
);
4234 if (length
&& !INTEGER_CST_P (length
))
4237 rest_of_decl_compilation (length
, 1, 0);
4241 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4242 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4243 has_coarray_vars
= true;
4246 /* Emit debug information for USE statements. */
4249 gfc_trans_use_stmts (gfc_namespace
* ns
)
4251 gfc_use_list
*use_stmt
;
4252 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
4254 struct module_htab_entry
*entry
4255 = gfc_find_module (use_stmt
->module_name
);
4256 gfc_use_rename
*rent
;
4258 if (entry
->namespace_decl
== NULL
)
4260 entry
->namespace_decl
4261 = build_decl (input_location
,
4263 get_identifier (use_stmt
->module_name
),
4265 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
4267 gfc_set_backend_locus (&use_stmt
->where
);
4268 if (!use_stmt
->only_flag
)
4269 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
4271 ns
->proc_name
->backend_decl
,
4273 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
4275 tree decl
, local_name
;
4278 if (rent
->op
!= INTRINSIC_NONE
)
4281 slot
= htab_find_slot_with_hash (entry
->decls
, rent
->use_name
,
4282 htab_hash_string (rent
->use_name
),
4288 st
= gfc_find_symtree (ns
->sym_root
,
4290 ? rent
->local_name
: rent
->use_name
);
4292 /* The following can happen if a derived type is renamed. */
4296 name
= xstrdup (rent
->local_name
[0]
4297 ? rent
->local_name
: rent
->use_name
);
4298 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
4299 st
= gfc_find_symtree (ns
->sym_root
, name
);
4304 /* Sometimes, generic interfaces wind up being over-ruled by a
4305 local symbol (see PR41062). */
4306 if (!st
->n
.sym
->attr
.use_assoc
)
4309 if (st
->n
.sym
->backend_decl
4310 && DECL_P (st
->n
.sym
->backend_decl
)
4311 && st
->n
.sym
->module
4312 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
4314 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
4315 || (TREE_CODE (st
->n
.sym
->backend_decl
)
4317 decl
= copy_node (st
->n
.sym
->backend_decl
);
4318 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4319 DECL_EXTERNAL (decl
) = 1;
4320 DECL_IGNORED_P (decl
) = 0;
4321 DECL_INITIAL (decl
) = NULL_TREE
;
4325 *slot
= error_mark_node
;
4326 htab_clear_slot (entry
->decls
, slot
);
4331 decl
= (tree
) *slot
;
4332 if (rent
->local_name
[0])
4333 local_name
= get_identifier (rent
->local_name
);
4335 local_name
= NULL_TREE
;
4336 gfc_set_backend_locus (&rent
->where
);
4337 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
4338 ns
->proc_name
->backend_decl
,
4339 !use_stmt
->only_flag
);
4345 /* Return true if expr is a constant initializer that gfc_conv_initializer
4349 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
4359 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
4361 else if (expr
->expr_type
== EXPR_STRUCTURE
)
4362 return check_constant_initializer (expr
, ts
, false, false);
4363 else if (expr
->expr_type
!= EXPR_ARRAY
)
4365 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4366 c
; c
= gfc_constructor_next (c
))
4370 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
4372 if (!check_constant_initializer (c
->expr
, ts
, false, false))
4375 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4380 else switch (ts
->type
)
4383 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4385 cm
= expr
->ts
.u
.derived
->components
;
4386 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4387 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4389 if (!c
->expr
|| cm
->attr
.allocatable
)
4391 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
4398 return expr
->expr_type
== EXPR_CONSTANT
;
4402 /* Emit debug info for parameters and unreferenced variables with
4406 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
4410 if (sym
->attr
.flavor
!= FL_PARAMETER
4411 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
4414 if (sym
->backend_decl
!= NULL
4415 || sym
->value
== NULL
4416 || sym
->attr
.use_assoc
4419 || sym
->attr
.function
4420 || sym
->attr
.intrinsic
4421 || sym
->attr
.pointer
4422 || sym
->attr
.allocatable
4423 || sym
->attr
.cray_pointee
4424 || sym
->attr
.threadprivate
4425 || sym
->attr
.is_bind_c
4426 || sym
->attr
.subref_array_pointer
4427 || sym
->attr
.assign
)
4430 if (sym
->ts
.type
== BT_CHARACTER
)
4432 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4433 if (sym
->ts
.u
.cl
->backend_decl
== NULL
4434 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
4437 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
4444 if (sym
->as
->type
!= AS_EXPLICIT
)
4446 for (n
= 0; n
< sym
->as
->rank
; n
++)
4447 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
4448 || sym
->as
->upper
[n
] == NULL
4449 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
4453 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
4454 sym
->attr
.dimension
, false))
4457 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
4460 /* Create the decl for the variable or constant. */
4461 decl
= build_decl (input_location
,
4462 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
4463 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
4464 if (sym
->attr
.flavor
== FL_PARAMETER
)
4465 TREE_READONLY (decl
) = 1;
4466 gfc_set_decl_location (decl
, &sym
->declared_at
);
4467 if (sym
->attr
.dimension
)
4468 GFC_DECL_PACKED_ARRAY (decl
) = 1;
4469 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4470 TREE_STATIC (decl
) = 1;
4471 TREE_USED (decl
) = 1;
4472 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
4473 TREE_PUBLIC (decl
) = 1;
4474 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
4476 sym
->attr
.dimension
,
4478 debug_hooks
->global_decl (decl
);
4483 generate_coarray_sym_init (gfc_symbol
*sym
)
4485 tree tmp
, size
, decl
, token
;
4487 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
4488 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
)
4491 decl
= sym
->backend_decl
;
4492 TREE_USED(decl
) = 1;
4493 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
4495 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4496 to make sure the variable is not optimized away. */
4497 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
4499 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
4501 /* Ensure that we do not have size=0 for zero-sized arrays. */
4502 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
4503 fold_convert (size_type_node
, size
),
4504 build_int_cst (size_type_node
, 1));
4506 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
4508 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
4509 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4510 fold_convert (size_type_node
, tmp
), size
);
4513 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
4514 token
= gfc_build_addr_expr (ppvoid_type_node
,
4515 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
4517 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 6, size
,
4518 build_int_cst (integer_type_node
,
4519 GFC_CAF_COARRAY_STATIC
), /* type. */
4520 token
, null_pointer_node
, /* token, stat. */
4521 null_pointer_node
, /* errgmsg, errmsg_len. */
4522 build_int_cst (integer_type_node
, 0));
4524 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
), tmp
));
4527 /* Handle "static" initializer. */
4530 sym
->attr
.pointer
= 1;
4531 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
4533 sym
->attr
.pointer
= 0;
4534 gfc_add_expr_to_block (&caf_init_block
, tmp
);
4539 /* Generate constructor function to initialize static, nonallocatable
4543 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
4545 tree fndecl
, tmp
, decl
, save_fn_decl
;
4547 save_fn_decl
= current_function_decl
;
4548 push_function_context ();
4550 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
4551 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
4552 create_tmp_var_name ("_caf_init"), tmp
);
4554 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
4555 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
4557 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
4558 DECL_ARTIFICIAL (decl
) = 1;
4559 DECL_IGNORED_P (decl
) = 1;
4560 DECL_CONTEXT (decl
) = fndecl
;
4561 DECL_RESULT (fndecl
) = decl
;
4564 current_function_decl
= fndecl
;
4565 announce_function (fndecl
);
4567 rest_of_decl_compilation (fndecl
, 0, 0);
4568 make_decl_rtl (fndecl
);
4569 allocate_struct_function (fndecl
, false);
4572 gfc_init_block (&caf_init_block
);
4574 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
4576 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
4580 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4582 DECL_SAVED_TREE (fndecl
)
4583 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4584 DECL_INITIAL (fndecl
));
4585 dump_function (TDI_original
, fndecl
);
4587 cfun
->function_end_locus
= input_location
;
4590 if (decl_function_context (fndecl
))
4591 (void) cgraph_create_node (fndecl
);
4593 cgraph_finalize_function (fndecl
, true);
4595 pop_function_context ();
4596 current_function_decl
= save_fn_decl
;
4600 /* Generate all the required code for module variables. */
4603 gfc_generate_module_vars (gfc_namespace
* ns
)
4605 module_namespace
= ns
;
4606 cur_module
= gfc_find_module (ns
->proc_name
->name
);
4608 /* Check if the frontend left the namespace in a reasonable state. */
4609 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
4611 /* Generate COMMON blocks. */
4612 gfc_trans_common (ns
);
4614 has_coarray_vars
= false;
4616 /* Create decls for all the module variables. */
4617 gfc_traverse_ns (ns
, gfc_create_module_variable
);
4619 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
4620 generate_coarray_init (ns
);
4624 gfc_trans_use_stmts (ns
);
4625 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
4630 gfc_generate_contained_functions (gfc_namespace
* parent
)
4634 /* We create all the prototypes before generating any code. */
4635 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4637 /* Skip namespaces from used modules. */
4638 if (ns
->parent
!= parent
)
4641 gfc_create_function_decl (ns
, false);
4644 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4646 /* Skip namespaces from used modules. */
4647 if (ns
->parent
!= parent
)
4650 gfc_generate_function_code (ns
);
4655 /* Drill down through expressions for the array specification bounds and
4656 character length calling generate_local_decl for all those variables
4657 that have not already been declared. */
4660 generate_local_decl (gfc_symbol
*);
4662 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4665 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
4666 int *f ATTRIBUTE_UNUSED
)
4668 if (e
->expr_type
!= EXPR_VARIABLE
4669 || sym
== e
->symtree
->n
.sym
4670 || e
->symtree
->n
.sym
->mark
4671 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
4674 generate_local_decl (e
->symtree
->n
.sym
);
4679 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
4681 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
4685 /* Check for dependencies in the character length and array spec. */
4688 generate_dependency_declarations (gfc_symbol
*sym
)
4692 if (sym
->ts
.type
== BT_CHARACTER
4694 && sym
->ts
.u
.cl
->length
4695 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4696 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
4698 if (sym
->as
&& sym
->as
->rank
)
4700 for (i
= 0; i
< sym
->as
->rank
; i
++)
4702 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
4703 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
4709 /* Generate decls for all local variables. We do this to ensure correct
4710 handling of expressions which only appear in the specification of
4714 generate_local_decl (gfc_symbol
* sym
)
4716 if (sym
->attr
.flavor
== FL_VARIABLE
)
4718 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4719 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4720 has_coarray_vars
= true;
4722 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
4723 generate_dependency_declarations (sym
);
4725 if (sym
->attr
.referenced
)
4726 gfc_get_symbol_decl (sym
);
4728 /* Warnings for unused dummy arguments. */
4729 else if (sym
->attr
.dummy
)
4731 /* INTENT(out) dummy arguments are likely meant to be set. */
4732 if (gfc_option
.warn_unused_dummy_argument
4733 && sym
->attr
.intent
== INTENT_OUT
)
4735 if (sym
->ts
.type
!= BT_DERIVED
)
4736 gfc_warning ("Dummy argument '%s' at %L was declared "
4737 "INTENT(OUT) but was not set", sym
->name
,
4739 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
))
4740 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4741 "declared INTENT(OUT) but was not set and "
4742 "does not have a default initializer",
4743 sym
->name
, &sym
->declared_at
);
4744 if (sym
->backend_decl
!= NULL_TREE
)
4745 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4747 else if (gfc_option
.warn_unused_dummy_argument
)
4749 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4751 if (sym
->backend_decl
!= NULL_TREE
)
4752 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4756 /* Warn for unused variables, but not if they're inside a common
4757 block or a namelist. */
4758 else if (warn_unused_variable
4759 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
4761 if (sym
->attr
.use_only
)
4763 gfc_warning ("Unused module variable '%s' which has been "
4764 "explicitly imported at %L", sym
->name
,
4766 if (sym
->backend_decl
!= NULL_TREE
)
4767 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4769 else if (!sym
->attr
.use_assoc
)
4771 gfc_warning ("Unused variable '%s' declared at %L",
4772 sym
->name
, &sym
->declared_at
);
4773 if (sym
->backend_decl
!= NULL_TREE
)
4774 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4778 /* For variable length CHARACTER parameters, the PARM_DECL already
4779 references the length variable, so force gfc_get_symbol_decl
4780 even when not referenced. If optimize > 0, it will be optimized
4781 away anyway. But do this only after emitting -Wunused-parameter
4782 warning if requested. */
4783 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
4784 && sym
->ts
.type
== BT_CHARACTER
4785 && sym
->ts
.u
.cl
->backend_decl
!= NULL
4786 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4788 sym
->attr
.referenced
= 1;
4789 gfc_get_symbol_decl (sym
);
4792 /* INTENT(out) dummy arguments and result variables with allocatable
4793 components are reset by default and need to be set referenced to
4794 generate the code for nullification and automatic lengths. */
4795 if (!sym
->attr
.referenced
4796 && sym
->ts
.type
== BT_DERIVED
4797 && sym
->ts
.u
.derived
->attr
.alloc_comp
4798 && !sym
->attr
.pointer
4799 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
4801 (sym
->attr
.result
&& sym
!= sym
->result
)))
4803 sym
->attr
.referenced
= 1;
4804 gfc_get_symbol_decl (sym
);
4807 /* Check for dependencies in the array specification and string
4808 length, adding the necessary declarations to the function. We
4809 mark the symbol now, as well as in traverse_ns, to prevent
4810 getting stuck in a circular dependency. */
4813 else if (sym
->attr
.flavor
== FL_PARAMETER
)
4815 if (warn_unused_parameter
4816 && !sym
->attr
.referenced
)
4818 if (!sym
->attr
.use_assoc
)
4819 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
4821 else if (sym
->attr
.use_only
)
4822 gfc_warning ("Unused parameter '%s' which has been explicitly "
4823 "imported at %L", sym
->name
, &sym
->declared_at
);
4826 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
4828 /* TODO: move to the appropriate place in resolve.c. */
4829 if (warn_return_type
4830 && sym
->attr
.function
4832 && sym
!= sym
->result
4833 && !sym
->result
->attr
.referenced
4834 && !sym
->attr
.use_assoc
4835 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
4837 gfc_warning ("Return value '%s' of function '%s' declared at "
4838 "%L not set", sym
->result
->name
, sym
->name
,
4839 &sym
->result
->declared_at
);
4841 /* Prevents "Unused variable" warning for RESULT variables. */
4842 sym
->result
->mark
= 1;
4846 if (sym
->attr
.dummy
== 1)
4848 /* Modify the tree type for scalar character dummy arguments of bind(c)
4849 procedures if they are passed by value. The tree type for them will
4850 be promoted to INTEGER_TYPE for the middle end, which appears to be
4851 what C would do with characters passed by-value. The value attribute
4852 implies the dummy is a scalar. */
4853 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
4854 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
4855 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
4856 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
4858 /* Unused procedure passed as dummy argument. */
4859 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4861 if (!sym
->attr
.referenced
)
4863 if (gfc_option
.warn_unused_dummy_argument
)
4864 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4868 /* Silence bogus "unused parameter" warnings from the
4870 if (sym
->backend_decl
!= NULL_TREE
)
4871 TREE_NO_WARNING (sym
->backend_decl
) = 1;
4875 /* Make sure we convert the types of the derived types from iso_c_binding
4877 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4878 && sym
->ts
.type
== BT_DERIVED
)
4879 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4883 generate_local_vars (gfc_namespace
* ns
)
4885 gfc_traverse_ns (ns
, generate_local_decl
);
4889 /* Generate a switch statement to jump to the correct entry point. Also
4890 creates the label decls for the entry points. */
4893 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
4900 gfc_init_block (&block
);
4901 for (; el
; el
= el
->next
)
4903 /* Add the case label. */
4904 label
= gfc_build_label_decl (NULL_TREE
);
4905 val
= build_int_cst (gfc_array_index_type
, el
->id
);
4906 tmp
= build_case_label (val
, NULL_TREE
, label
);
4907 gfc_add_expr_to_block (&block
, tmp
);
4909 /* And jump to the actual entry point. */
4910 label
= gfc_build_label_decl (NULL_TREE
);
4911 tmp
= build1_v (GOTO_EXPR
, label
);
4912 gfc_add_expr_to_block (&block
, tmp
);
4914 /* Save the label decl. */
4917 tmp
= gfc_finish_block (&block
);
4918 /* The first argument selects the entry point. */
4919 val
= DECL_ARGUMENTS (current_function_decl
);
4920 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
4921 val
, tmp
, NULL_TREE
);
4926 /* Add code to string lengths of actual arguments passed to a function against
4927 the expected lengths of the dummy arguments. */
4930 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
4932 gfc_formal_arglist
*formal
;
4934 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
4935 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
4936 && !formal
->sym
->ts
.deferred
)
4938 enum tree_code comparison
;
4943 const char *message
;
4949 gcc_assert (cl
->passed_length
!= NULL_TREE
);
4950 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
4952 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4953 string lengths must match exactly. Otherwise, it is only required
4954 that the actual string length is *at least* the expected one.
4955 Sequence association allows for a mismatch of the string length
4956 if the actual argument is (part of) an array, but only if the
4957 dummy argument is an array. (See "Sequence association" in
4958 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4959 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
4960 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
4961 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
4963 comparison
= NE_EXPR
;
4964 message
= _("Actual string length does not match the declared one"
4965 " for dummy argument '%s' (%ld/%ld)");
4967 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
4971 comparison
= LT_EXPR
;
4972 message
= _("Actual string length is shorter than the declared one"
4973 " for dummy argument '%s' (%ld/%ld)");
4976 /* Build the condition. For optional arguments, an actual length
4977 of 0 is also acceptable if the associated string is NULL, which
4978 means the argument was not passed. */
4979 cond
= fold_build2_loc (input_location
, comparison
, boolean_type_node
,
4980 cl
->passed_length
, cl
->backend_decl
);
4981 if (fsym
->attr
.optional
)
4987 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
4990 build_zero_cst (gfc_charlen_type_node
));
4991 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4992 fsym
->attr
.referenced
= 1;
4993 not_absent
= gfc_conv_expr_present (fsym
);
4995 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4996 boolean_type_node
, not_0length
,
4999 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5000 boolean_type_node
, cond
, absent_failed
);
5003 /* Build the runtime check. */
5004 argname
= gfc_build_cstring_const (fsym
->name
);
5005 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
5006 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
5008 fold_convert (long_integer_type_node
,
5010 fold_convert (long_integer_type_node
,
5016 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
5017 global variables for -fcoarray=lib. They are placed into the translation
5018 unit of the main program. Make sure that in one TU (the one of the main
5019 program), the first call to gfc_init_coarray_decl is done with true.
5020 Otherwise, expect link errors. */
5023 gfc_init_coarray_decl (bool main_tu
)
5025 if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
5028 if (gfort_gvar_caf_this_image
|| gfort_gvar_caf_num_images
)
5033 gfort_gvar_caf_this_image
5034 = build_decl (input_location
, VAR_DECL
,
5035 get_identifier (PREFIX("caf_this_image")),
5037 DECL_ARTIFICIAL (gfort_gvar_caf_this_image
) = 1;
5038 TREE_USED (gfort_gvar_caf_this_image
) = 1;
5039 TREE_PUBLIC (gfort_gvar_caf_this_image
) = 1;
5040 TREE_READONLY (gfort_gvar_caf_this_image
) = 0;
5043 TREE_STATIC (gfort_gvar_caf_this_image
) = 1;
5045 DECL_EXTERNAL (gfort_gvar_caf_this_image
) = 1;
5047 pushdecl_top_level (gfort_gvar_caf_this_image
);
5049 gfort_gvar_caf_num_images
5050 = build_decl (input_location
, VAR_DECL
,
5051 get_identifier (PREFIX("caf_num_images")),
5053 DECL_ARTIFICIAL (gfort_gvar_caf_num_images
) = 1;
5054 TREE_USED (gfort_gvar_caf_num_images
) = 1;
5055 TREE_PUBLIC (gfort_gvar_caf_num_images
) = 1;
5056 TREE_READONLY (gfort_gvar_caf_num_images
) = 0;
5059 TREE_STATIC (gfort_gvar_caf_num_images
) = 1;
5061 DECL_EXTERNAL (gfort_gvar_caf_num_images
) = 1;
5063 pushdecl_top_level (gfort_gvar_caf_num_images
);
5070 create_main_function (tree fndecl
)
5074 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
5077 old_context
= current_function_decl
;
5081 push_function_context ();
5082 saved_parent_function_decls
= saved_function_decls
;
5083 saved_function_decls
= NULL_TREE
;
5086 /* main() function must be declared with global scope. */
5087 gcc_assert (current_function_decl
== NULL_TREE
);
5089 /* Declare the function. */
5090 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
5091 build_pointer_type (pchar_type_node
),
5093 main_identifier_node
= get_identifier ("main");
5094 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
5095 main_identifier_node
, tmp
);
5096 DECL_EXTERNAL (ftn_main
) = 0;
5097 TREE_PUBLIC (ftn_main
) = 1;
5098 TREE_STATIC (ftn_main
) = 1;
5099 DECL_ATTRIBUTES (ftn_main
)
5100 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
5102 /* Setup the result declaration (for "return 0"). */
5103 result_decl
= build_decl (input_location
,
5104 RESULT_DECL
, NULL_TREE
, integer_type_node
);
5105 DECL_ARTIFICIAL (result_decl
) = 1;
5106 DECL_IGNORED_P (result_decl
) = 1;
5107 DECL_CONTEXT (result_decl
) = ftn_main
;
5108 DECL_RESULT (ftn_main
) = result_decl
;
5110 pushdecl (ftn_main
);
5112 /* Get the arguments. */
5114 arglist
= NULL_TREE
;
5115 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
5117 tmp
= TREE_VALUE (typelist
);
5118 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
5119 DECL_CONTEXT (argc
) = ftn_main
;
5120 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
5121 TREE_READONLY (argc
) = 1;
5122 gfc_finish_decl (argc
);
5123 arglist
= chainon (arglist
, argc
);
5125 typelist
= TREE_CHAIN (typelist
);
5126 tmp
= TREE_VALUE (typelist
);
5127 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
5128 DECL_CONTEXT (argv
) = ftn_main
;
5129 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
5130 TREE_READONLY (argv
) = 1;
5131 DECL_BY_REFERENCE (argv
) = 1;
5132 gfc_finish_decl (argv
);
5133 arglist
= chainon (arglist
, argv
);
5135 DECL_ARGUMENTS (ftn_main
) = arglist
;
5136 current_function_decl
= ftn_main
;
5137 announce_function (ftn_main
);
5139 rest_of_decl_compilation (ftn_main
, 1, 0);
5140 make_decl_rtl (ftn_main
);
5141 allocate_struct_function (ftn_main
, false);
5144 gfc_init_block (&body
);
5146 /* Call some libgfortran initialization routines, call then MAIN__(). */
5148 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
5149 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5151 tree pint_type
, pppchar_type
;
5152 pint_type
= build_pointer_type (integer_type_node
);
5154 = build_pointer_type (build_pointer_type (pchar_type_node
));
5156 gfc_init_coarray_decl (true);
5157 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 4,
5158 gfc_build_addr_expr (pint_type
, argc
),
5159 gfc_build_addr_expr (pppchar_type
, argv
),
5160 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_this_image
),
5161 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_num_images
));
5162 gfc_add_expr_to_block (&body
, tmp
);
5165 /* Call _gfortran_set_args (argc, argv). */
5166 TREE_USED (argc
) = 1;
5167 TREE_USED (argv
) = 1;
5168 tmp
= build_call_expr_loc (input_location
,
5169 gfor_fndecl_set_args
, 2, argc
, argv
);
5170 gfc_add_expr_to_block (&body
, tmp
);
5172 /* Add a call to set_options to set up the runtime library Fortran
5173 language standard parameters. */
5175 tree array_type
, array
, var
;
5176 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5178 /* Passing a new option to the library requires four modifications:
5179 + add it to the tree_cons list below
5180 + change the array size in the call to build_array_type
5181 + change the first argument to the library call
5182 gfor_fndecl_set_options
5183 + modify the library (runtime/compile_options.c)! */
5185 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5186 build_int_cst (integer_type_node
,
5187 gfc_option
.warn_std
));
5188 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5189 build_int_cst (integer_type_node
,
5190 gfc_option
.allow_std
));
5191 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5192 build_int_cst (integer_type_node
, pedantic
));
5193 /* TODO: This is the old -fdump-core option, which is unused but
5194 passed due to ABI compatibility; remove when bumping the
5196 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5197 build_int_cst (integer_type_node
,
5199 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5200 build_int_cst (integer_type_node
,
5201 gfc_option
.flag_backtrace
));
5202 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5203 build_int_cst (integer_type_node
,
5204 gfc_option
.flag_sign_zero
));
5205 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5206 build_int_cst (integer_type_node
,
5208 & GFC_RTCHECK_BOUNDS
)));
5209 /* TODO: This is the -frange-check option, which no longer affects
5210 library behavior; when bumping the library ABI this slot can be
5211 reused for something else. As it is the last element in the
5212 array, we can instead leave it out altogether. */
5213 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5214 build_int_cst (integer_type_node
, 0));
5215 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5216 build_int_cst (integer_type_node
,
5217 gfc_option
.fpe_summary
));
5219 array_type
= build_array_type (integer_type_node
,
5220 build_index_type (size_int (8)));
5221 array
= build_constructor (array_type
, v
);
5222 TREE_CONSTANT (array
) = 1;
5223 TREE_STATIC (array
) = 1;
5225 /* Create a static variable to hold the jump table. */
5226 var
= gfc_create_var (array_type
, "options");
5227 TREE_CONSTANT (var
) = 1;
5228 TREE_STATIC (var
) = 1;
5229 TREE_READONLY (var
) = 1;
5230 DECL_INITIAL (var
) = array
;
5231 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
5233 tmp
= build_call_expr_loc (input_location
,
5234 gfor_fndecl_set_options
, 2,
5235 build_int_cst (integer_type_node
, 9), var
);
5236 gfc_add_expr_to_block (&body
, tmp
);
5239 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5240 the library will raise a FPE when needed. */
5241 if (gfc_option
.fpe
!= 0)
5243 tmp
= build_call_expr_loc (input_location
,
5244 gfor_fndecl_set_fpe
, 1,
5245 build_int_cst (integer_type_node
,
5247 gfc_add_expr_to_block (&body
, tmp
);
5250 /* If this is the main program and an -fconvert option was provided,
5251 add a call to set_convert. */
5253 if (gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
5255 tmp
= build_call_expr_loc (input_location
,
5256 gfor_fndecl_set_convert
, 1,
5257 build_int_cst (integer_type_node
,
5258 gfc_option
.convert
));
5259 gfc_add_expr_to_block (&body
, tmp
);
5262 /* If this is the main program and an -frecord-marker option was provided,
5263 add a call to set_record_marker. */
5265 if (gfc_option
.record_marker
!= 0)
5267 tmp
= build_call_expr_loc (input_location
,
5268 gfor_fndecl_set_record_marker
, 1,
5269 build_int_cst (integer_type_node
,
5270 gfc_option
.record_marker
));
5271 gfc_add_expr_to_block (&body
, tmp
);
5274 if (gfc_option
.max_subrecord_length
!= 0)
5276 tmp
= build_call_expr_loc (input_location
,
5277 gfor_fndecl_set_max_subrecord_length
, 1,
5278 build_int_cst (integer_type_node
,
5279 gfc_option
.max_subrecord_length
));
5280 gfc_add_expr_to_block (&body
, tmp
);
5283 /* Call MAIN__(). */
5284 tmp
= build_call_expr_loc (input_location
,
5286 gfc_add_expr_to_block (&body
, tmp
);
5288 /* Mark MAIN__ as used. */
5289 TREE_USED (fndecl
) = 1;
5291 /* Coarray: Call _gfortran_caf_finalize(void). */
5292 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5294 /* Per F2008, 8.5.1 END of the main program implies a
5296 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
5297 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
5298 gfc_add_expr_to_block (&body
, tmp
);
5300 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
5301 gfc_add_expr_to_block (&body
, tmp
);
5305 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
5306 DECL_RESULT (ftn_main
),
5307 build_int_cst (integer_type_node
, 0));
5308 tmp
= build1_v (RETURN_EXPR
, tmp
);
5309 gfc_add_expr_to_block (&body
, tmp
);
5312 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
5315 /* Finish off this function and send it for code generation. */
5317 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
5319 DECL_SAVED_TREE (ftn_main
)
5320 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
5321 DECL_INITIAL (ftn_main
));
5323 /* Output the GENERIC tree. */
5324 dump_function (TDI_original
, ftn_main
);
5326 cgraph_finalize_function (ftn_main
, true);
5330 pop_function_context ();
5331 saved_function_decls
= saved_parent_function_decls
;
5333 current_function_decl
= old_context
;
5337 /* Get the result expression for a procedure. */
5340 get_proc_result (gfc_symbol
* sym
)
5342 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
5344 if (current_fake_result_decl
!= NULL
)
5345 return TREE_VALUE (current_fake_result_decl
);
5350 return sym
->result
->backend_decl
;
5354 /* Generate an appropriate return-statement for a procedure. */
5357 gfc_generate_return (void)
5363 sym
= current_procedure_symbol
;
5364 fndecl
= sym
->backend_decl
;
5366 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
5370 result
= get_proc_result (sym
);
5372 /* Set the return value to the dummy result variable. The
5373 types may be different for scalar default REAL functions
5374 with -ff2c, therefore we have to convert. */
5375 if (result
!= NULL_TREE
)
5377 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
5378 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5379 TREE_TYPE (result
), DECL_RESULT (fndecl
),
5384 return build1_v (RETURN_EXPR
, result
);
5388 /* Generate code for a function. */
5391 gfc_generate_function_code (gfc_namespace
* ns
)
5397 stmtblock_t init
, cleanup
;
5399 gfc_wrapped_block try_block
;
5400 tree recurcheckvar
= NULL_TREE
;
5402 gfc_symbol
*previous_procedure_symbol
;
5406 sym
= ns
->proc_name
;
5407 previous_procedure_symbol
= current_procedure_symbol
;
5408 current_procedure_symbol
= sym
;
5410 /* Check that the frontend isn't still using this. */
5411 gcc_assert (sym
->tlink
== NULL
);
5414 /* Create the declaration for functions with global scope. */
5415 if (!sym
->backend_decl
)
5416 gfc_create_function_decl (ns
, false);
5418 fndecl
= sym
->backend_decl
;
5419 old_context
= current_function_decl
;
5423 push_function_context ();
5424 saved_parent_function_decls
= saved_function_decls
;
5425 saved_function_decls
= NULL_TREE
;
5428 trans_function_start (sym
);
5430 gfc_init_block (&init
);
5432 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
5434 /* Copy length backend_decls to all entry point result
5439 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
5440 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
5441 for (el
= ns
->entries
; el
; el
= el
->next
)
5442 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
5445 /* Translate COMMON blocks. */
5446 gfc_trans_common (ns
);
5448 /* Null the parent fake result declaration if this namespace is
5449 a module function or an external procedures. */
5450 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5451 || ns
->parent
== NULL
)
5452 parent_fake_result_decl
= NULL_TREE
;
5454 gfc_generate_contained_functions (ns
);
5456 nonlocal_dummy_decls
= NULL
;
5457 nonlocal_dummy_decl_pset
= NULL
;
5459 has_coarray_vars
= false;
5460 generate_local_vars (ns
);
5462 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5463 generate_coarray_init (ns
);
5465 /* Keep the parent fake result declaration in module functions
5466 or external procedures. */
5467 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5468 || ns
->parent
== NULL
)
5469 current_fake_result_decl
= parent_fake_result_decl
;
5471 current_fake_result_decl
= NULL_TREE
;
5473 is_recursive
= sym
->attr
.recursive
5474 || (sym
->attr
.entry_master
5475 && sym
->ns
->entries
->sym
->attr
.recursive
);
5476 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5478 && !gfc_option
.flag_recursive
)
5482 asprintf (&msg
, "Recursive call to nonrecursive procedure '%s'",
5484 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
5485 TREE_STATIC (recurcheckvar
) = 1;
5486 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
5487 gfc_add_expr_to_block (&init
, recurcheckvar
);
5488 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
5489 &sym
->declared_at
, msg
);
5490 gfc_add_modify (&init
, recurcheckvar
, boolean_true_node
);
5494 /* Now generate the code for the body of this function. */
5495 gfc_init_block (&body
);
5497 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
5498 && sym
->attr
.subroutine
)
5500 tree alternate_return
;
5501 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
5502 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
5507 /* Jump to the correct entry point. */
5508 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
5509 gfc_add_expr_to_block (&body
, tmp
);
5512 /* If bounds-checking is enabled, generate code to check passed in actual
5513 arguments against the expected dummy argument attributes (e.g. string
5515 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
5516 add_argument_checking (&body
, sym
);
5518 tmp
= gfc_trans_code (ns
->code
);
5519 gfc_add_expr_to_block (&body
, tmp
);
5521 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
5523 tree result
= get_proc_result (sym
);
5525 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
5527 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
5528 && sym
->result
== sym
)
5529 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
5530 null_pointer_node
));
5531 else if (sym
->ts
.type
== BT_CLASS
5532 && CLASS_DATA (sym
)->attr
.allocatable
5533 && CLASS_DATA (sym
)->attr
.dimension
== 0
5534 && sym
->result
== sym
)
5536 tmp
= CLASS_DATA (sym
)->backend_decl
;
5537 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5538 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
5539 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
5540 null_pointer_node
));
5542 else if (sym
->ts
.type
== BT_DERIVED
5543 && sym
->ts
.u
.derived
->attr
.alloc_comp
5544 && !sym
->attr
.allocatable
)
5546 rank
= sym
->as
? sym
->as
->rank
: 0;
5547 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, result
, rank
);
5548 gfc_add_expr_to_block (&init
, tmp
);
5552 if (result
== NULL_TREE
)
5554 /* TODO: move to the appropriate place in resolve.c. */
5555 if (warn_return_type
&& sym
== sym
->result
)
5556 gfc_warning ("Return value of function '%s' at %L not set",
5557 sym
->name
, &sym
->declared_at
);
5558 if (warn_return_type
)
5559 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5562 gfc_add_expr_to_block (&body
, gfc_generate_return ());
5565 gfc_init_block (&cleanup
);
5567 /* Reset recursion-check variable. */
5568 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5570 && !gfc_option
.gfc_flag_openmp
5571 && recurcheckvar
!= NULL_TREE
)
5573 gfc_add_modify (&cleanup
, recurcheckvar
, boolean_false_node
);
5574 recurcheckvar
= NULL
;
5577 /* Finish the function body and add init and cleanup code. */
5578 tmp
= gfc_finish_block (&body
);
5579 gfc_start_wrapped_block (&try_block
, tmp
);
5580 /* Add code to create and cleanup arrays. */
5581 gfc_trans_deferred_vars (sym
, &try_block
);
5582 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
5583 gfc_finish_block (&cleanup
));
5585 /* Add all the decls we created during processing. */
5586 decl
= saved_function_decls
;
5591 next
= DECL_CHAIN (decl
);
5592 DECL_CHAIN (decl
) = NULL_TREE
;
5596 saved_function_decls
= NULL_TREE
;
5598 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
5601 /* Finish off this function and send it for code generation. */
5603 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5605 DECL_SAVED_TREE (fndecl
)
5606 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5607 DECL_INITIAL (fndecl
));
5609 if (nonlocal_dummy_decls
)
5611 BLOCK_VARS (DECL_INITIAL (fndecl
))
5612 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
5613 pointer_set_destroy (nonlocal_dummy_decl_pset
);
5614 nonlocal_dummy_decls
= NULL
;
5615 nonlocal_dummy_decl_pset
= NULL
;
5618 /* Output the GENERIC tree. */
5619 dump_function (TDI_original
, fndecl
);
5621 /* Store the end of the function, so that we get good line number
5622 info for the epilogue. */
5623 cfun
->function_end_locus
= input_location
;
5625 /* We're leaving the context of this function, so zap cfun.
5626 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5627 tree_rest_of_compilation. */
5632 pop_function_context ();
5633 saved_function_decls
= saved_parent_function_decls
;
5635 current_function_decl
= old_context
;
5637 if (decl_function_context (fndecl
) && gfc_option
.coarray
!= GFC_FCOARRAY_LIB
5638 && has_coarray_vars
)
5639 /* Register this function with cgraph just far enough to get it
5640 added to our parent's nested function list.
5641 If there are static coarrays in this function, the nested _caf_init
5642 function has already called cgraph_create_node, which also created
5643 the cgraph node for this function. */
5644 (void) cgraph_create_node (fndecl
);
5646 cgraph_finalize_function (fndecl
, true);
5648 gfc_trans_use_stmts (ns
);
5649 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5651 if (sym
->attr
.is_main_program
)
5652 create_main_function (fndecl
);
5654 current_procedure_symbol
= previous_procedure_symbol
;
5659 gfc_generate_constructors (void)
5661 gcc_assert (gfc_static_ctors
== NULL_TREE
);
5669 if (gfc_static_ctors
== NULL_TREE
)
5672 fnname
= get_file_function_name ("I");
5673 type
= build_function_type_list (void_type_node
, NULL_TREE
);
5675 fndecl
= build_decl (input_location
,
5676 FUNCTION_DECL
, fnname
, type
);
5677 TREE_PUBLIC (fndecl
) = 1;
5679 decl
= build_decl (input_location
,
5680 RESULT_DECL
, NULL_TREE
, void_type_node
);
5681 DECL_ARTIFICIAL (decl
) = 1;
5682 DECL_IGNORED_P (decl
) = 1;
5683 DECL_CONTEXT (decl
) = fndecl
;
5684 DECL_RESULT (fndecl
) = decl
;
5688 current_function_decl
= fndecl
;
5690 rest_of_decl_compilation (fndecl
, 1, 0);
5692 make_decl_rtl (fndecl
);
5694 allocate_struct_function (fndecl
, false);
5698 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
5700 tmp
= build_call_expr_loc (input_location
,
5701 TREE_VALUE (gfc_static_ctors
), 0);
5702 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
5708 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5709 DECL_SAVED_TREE (fndecl
)
5710 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5711 DECL_INITIAL (fndecl
));
5713 free_after_parsing (cfun
);
5714 free_after_compilation (cfun
);
5716 tree_rest_of_compilation (fndecl
);
5718 current_function_decl
= NULL_TREE
;
5722 /* Translates a BLOCK DATA program unit. This means emitting the
5723 commons contained therein plus their initializations. We also emit
5724 a globally visible symbol to make sure that each BLOCK DATA program
5725 unit remains unique. */
5728 gfc_generate_block_data (gfc_namespace
* ns
)
5733 /* Tell the backend the source location of the block data. */
5735 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
5737 gfc_set_backend_locus (&gfc_current_locus
);
5739 /* Process the DATA statements. */
5740 gfc_trans_common (ns
);
5742 /* Create a global symbol with the mane of the block data. This is to
5743 generate linker errors if the same name is used twice. It is never
5746 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
5748 id
= get_identifier ("__BLOCK_DATA__");
5750 decl
= build_decl (input_location
,
5751 VAR_DECL
, id
, gfc_array_index_type
);
5752 TREE_PUBLIC (decl
) = 1;
5753 TREE_STATIC (decl
) = 1;
5754 DECL_IGNORED_P (decl
) = 1;
5757 rest_of_decl_compilation (decl
, 1, 0);
5761 /* Process the local variables of a BLOCK construct. */
5764 gfc_process_block_locals (gfc_namespace
* ns
)
5768 gcc_assert (saved_local_decls
== NULL_TREE
);
5769 has_coarray_vars
= false;
5771 generate_local_vars (ns
);
5773 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5774 generate_coarray_init (ns
);
5776 decl
= saved_local_decls
;
5781 next
= DECL_CHAIN (decl
);
5782 DECL_CHAIN (decl
) = NULL_TREE
;
5786 saved_local_decls
= NULL_TREE
;
5790 #include "gt-fortran-trans-decl.h"