1 /* Backend function setup
2 Copyright (C) 2002-2014 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 "stringpool.h"
29 #include "stor-layout.h"
32 #include "tree-dump.h"
33 #include "gimple-expr.h" /* For create_tmp_var_raw. */
35 #include "diagnostic-core.h" /* For internal_error. */
36 #include "toplev.h" /* For announce_function. */
43 #include "pointer-set.h"
44 #include "constructor.h"
46 #include "trans-types.h"
47 #include "trans-array.h"
48 #include "trans-const.h"
49 /* Only for gfc_trans_code. Shouldn't need to include this. */
50 #include "trans-stmt.h"
52 #define MAX_LABEL_VALUE 99999
55 /* Holds the result of the function if no result variable specified. */
57 static GTY(()) tree current_fake_result_decl
;
58 static GTY(()) tree parent_fake_result_decl
;
61 /* Holds the variable DECLs for the current function. */
63 static GTY(()) tree saved_function_decls
;
64 static GTY(()) tree saved_parent_function_decls
;
66 static struct pointer_set_t
*nonlocal_dummy_decl_pset
;
67 static GTY(()) tree nonlocal_dummy_decls
;
69 /* Holds the variable DECLs that are locals. */
71 static GTY(()) tree saved_local_decls
;
73 /* The namespace of the module we're currently generating. Only used while
74 outputting decls for module variables. Do not rely on this being set. */
76 static gfc_namespace
*module_namespace
;
78 /* The currently processed procedure symbol. */
79 static gfc_symbol
* current_procedure_symbol
= NULL
;
82 /* With -fcoarray=lib: For generating the registering call
83 of static coarrays. */
84 static bool has_coarray_vars
;
85 static stmtblock_t caf_init_block
;
88 /* List of static constructor functions. */
90 tree gfc_static_ctors
;
93 /* Function declarations for builtin library functions. */
95 tree gfor_fndecl_pause_numeric
;
96 tree gfor_fndecl_pause_string
;
97 tree gfor_fndecl_stop_numeric
;
98 tree gfor_fndecl_stop_numeric_f08
;
99 tree gfor_fndecl_stop_string
;
100 tree gfor_fndecl_error_stop_numeric
;
101 tree gfor_fndecl_error_stop_string
;
102 tree gfor_fndecl_runtime_error
;
103 tree gfor_fndecl_runtime_error_at
;
104 tree gfor_fndecl_runtime_warning_at
;
105 tree gfor_fndecl_os_error
;
106 tree gfor_fndecl_generate_error
;
107 tree gfor_fndecl_set_args
;
108 tree gfor_fndecl_set_fpe
;
109 tree gfor_fndecl_set_options
;
110 tree gfor_fndecl_set_convert
;
111 tree gfor_fndecl_set_record_marker
;
112 tree gfor_fndecl_set_max_subrecord_length
;
113 tree gfor_fndecl_ctime
;
114 tree gfor_fndecl_fdate
;
115 tree gfor_fndecl_ttynam
;
116 tree gfor_fndecl_in_pack
;
117 tree gfor_fndecl_in_unpack
;
118 tree gfor_fndecl_associated
;
121 /* Coarray run-time library function decls. */
122 tree gfor_fndecl_caf_init
;
123 tree gfor_fndecl_caf_finalize
;
124 tree gfor_fndecl_caf_this_image
;
125 tree gfor_fndecl_caf_num_images
;
126 tree gfor_fndecl_caf_register
;
127 tree gfor_fndecl_caf_deregister
;
128 tree gfor_fndecl_caf_critical
;
129 tree gfor_fndecl_caf_end_critical
;
130 tree gfor_fndecl_caf_sync_all
;
131 tree gfor_fndecl_caf_sync_images
;
132 tree gfor_fndecl_caf_error_stop
;
133 tree gfor_fndecl_caf_error_stop_str
;
136 /* Math functions. Many other math functions are handled in
137 trans-intrinsic.c. */
139 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
140 tree gfor_fndecl_math_ishftc4
;
141 tree gfor_fndecl_math_ishftc8
;
142 tree gfor_fndecl_math_ishftc16
;
145 /* String functions. */
147 tree gfor_fndecl_compare_string
;
148 tree gfor_fndecl_concat_string
;
149 tree gfor_fndecl_string_len_trim
;
150 tree gfor_fndecl_string_index
;
151 tree gfor_fndecl_string_scan
;
152 tree gfor_fndecl_string_verify
;
153 tree gfor_fndecl_string_trim
;
154 tree gfor_fndecl_string_minmax
;
155 tree gfor_fndecl_adjustl
;
156 tree gfor_fndecl_adjustr
;
157 tree gfor_fndecl_select_string
;
158 tree gfor_fndecl_compare_string_char4
;
159 tree gfor_fndecl_concat_string_char4
;
160 tree gfor_fndecl_string_len_trim_char4
;
161 tree gfor_fndecl_string_index_char4
;
162 tree gfor_fndecl_string_scan_char4
;
163 tree gfor_fndecl_string_verify_char4
;
164 tree gfor_fndecl_string_trim_char4
;
165 tree gfor_fndecl_string_minmax_char4
;
166 tree gfor_fndecl_adjustl_char4
;
167 tree gfor_fndecl_adjustr_char4
;
168 tree gfor_fndecl_select_string_char4
;
171 /* Conversion between character kinds. */
172 tree gfor_fndecl_convert_char1_to_char4
;
173 tree gfor_fndecl_convert_char4_to_char1
;
176 /* Other misc. runtime library functions. */
177 tree gfor_fndecl_size0
;
178 tree gfor_fndecl_size1
;
179 tree gfor_fndecl_iargc
;
181 /* Intrinsic functions implemented in Fortran. */
182 tree gfor_fndecl_sc_kind
;
183 tree gfor_fndecl_si_kind
;
184 tree gfor_fndecl_sr_kind
;
186 /* BLAS gemm functions. */
187 tree gfor_fndecl_sgemm
;
188 tree gfor_fndecl_dgemm
;
189 tree gfor_fndecl_cgemm
;
190 tree gfor_fndecl_zgemm
;
194 gfc_add_decl_to_parent_function (tree decl
)
197 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
198 DECL_NONLOCAL (decl
) = 1;
199 DECL_CHAIN (decl
) = saved_parent_function_decls
;
200 saved_parent_function_decls
= decl
;
204 gfc_add_decl_to_function (tree decl
)
207 TREE_USED (decl
) = 1;
208 DECL_CONTEXT (decl
) = current_function_decl
;
209 DECL_CHAIN (decl
) = saved_function_decls
;
210 saved_function_decls
= decl
;
214 add_decl_as_local (tree decl
)
217 TREE_USED (decl
) = 1;
218 DECL_CONTEXT (decl
) = current_function_decl
;
219 DECL_CHAIN (decl
) = saved_local_decls
;
220 saved_local_decls
= decl
;
224 /* Build a backend label declaration. Set TREE_USED for named labels.
225 The context of the label is always the current_function_decl. All
226 labels are marked artificial. */
229 gfc_build_label_decl (tree label_id
)
231 /* 2^32 temporaries should be enough. */
232 static unsigned int tmp_num
= 1;
236 if (label_id
== NULL_TREE
)
238 /* Build an internal label name. */
239 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
240 label_id
= get_identifier (label_name
);
245 /* Build the LABEL_DECL node. Labels have no type. */
246 label_decl
= build_decl (input_location
,
247 LABEL_DECL
, label_id
, void_type_node
);
248 DECL_CONTEXT (label_decl
) = current_function_decl
;
249 DECL_MODE (label_decl
) = VOIDmode
;
251 /* We always define the label as used, even if the original source
252 file never references the label. We don't want all kinds of
253 spurious warnings for old-style Fortran code with too many
255 TREE_USED (label_decl
) = 1;
257 DECL_ARTIFICIAL (label_decl
) = 1;
262 /* Set the backend source location of a decl. */
265 gfc_set_decl_location (tree decl
, locus
* loc
)
267 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
271 /* Return the backend label declaration for a given label structure,
272 or create it if it doesn't exist yet. */
275 gfc_get_label_decl (gfc_st_label
* lp
)
277 if (lp
->backend_decl
)
278 return lp
->backend_decl
;
281 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
284 /* Validate the label declaration from the front end. */
285 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
287 /* Build a mangled name for the label. */
288 sprintf (label_name
, "__label_%.6d", lp
->value
);
290 /* Build the LABEL_DECL node. */
291 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
293 /* Tell the debugger where the label came from. */
294 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
295 gfc_set_decl_location (label_decl
, &lp
->where
);
297 DECL_ARTIFICIAL (label_decl
) = 1;
299 /* Store the label in the label list and return the LABEL_DECL. */
300 lp
->backend_decl
= label_decl
;
306 /* Convert a gfc_symbol to an identifier of the same name. */
309 gfc_sym_identifier (gfc_symbol
* sym
)
311 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
312 return (get_identifier ("MAIN__"));
314 return (get_identifier (sym
->name
));
318 /* Construct mangled name from symbol name. */
321 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
323 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
325 /* Prevent the mangling of identifiers that have an assigned
326 binding label (mainly those that are bind(c)). */
327 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
328 return get_identifier (sym
->binding_label
);
330 if (sym
->module
== NULL
)
331 return gfc_sym_identifier (sym
);
334 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
335 return get_identifier (name
);
340 /* Construct mangled function name from symbol name. */
343 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
346 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
348 /* It may be possible to simply use the binding label if it's
349 provided, and remove the other checks. Then we could use it
350 for other things if we wished. */
351 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
353 /* use the binding label rather than the mangled name */
354 return get_identifier (sym
->binding_label
);
356 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
357 || (sym
->module
!= NULL
&& (sym
->attr
.external
358 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
360 /* Main program is mangled into MAIN__. */
361 if (sym
->attr
.is_main_program
)
362 return get_identifier ("MAIN__");
364 /* Intrinsic procedures are never mangled. */
365 if (sym
->attr
.proc
== PROC_INTRINSIC
)
366 return get_identifier (sym
->name
);
368 if (gfc_option
.flag_underscoring
)
370 has_underscore
= strchr (sym
->name
, '_') != 0;
371 if (gfc_option
.flag_second_underscore
&& has_underscore
)
372 snprintf (name
, sizeof name
, "%s__", sym
->name
);
374 snprintf (name
, sizeof name
, "%s_", sym
->name
);
375 return get_identifier (name
);
378 return get_identifier (sym
->name
);
382 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
383 return get_identifier (name
);
389 gfc_set_decl_assembler_name (tree decl
, tree name
)
391 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
392 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
396 /* Returns true if a variable of specified size should go on the stack. */
399 gfc_can_put_var_on_stack (tree size
)
401 unsigned HOST_WIDE_INT low
;
403 if (!INTEGER_CST_P (size
))
406 if (gfc_option
.flag_max_stack_var_size
< 0)
409 if (TREE_INT_CST_HIGH (size
) != 0)
412 low
= TREE_INT_CST_LOW (size
);
413 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
416 /* TODO: Set a per-function stack size limit. */
422 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
423 an expression involving its corresponding pointer. There are
424 2 cases; one for variable size arrays, and one for everything else,
425 because variable-sized arrays require one fewer level of
429 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
431 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
434 /* Parameters need to be dereferenced. */
435 if (sym
->cp_pointer
->attr
.dummy
)
436 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
439 /* Check to see if we're dealing with a variable-sized array. */
440 if (sym
->attr
.dimension
441 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
443 /* These decls will be dereferenced later, so we don't dereference
445 value
= convert (TREE_TYPE (decl
), ptr_decl
);
449 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
451 value
= build_fold_indirect_ref_loc (input_location
,
455 SET_DECL_VALUE_EXPR (decl
, value
);
456 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
457 GFC_DECL_CRAY_POINTEE (decl
) = 1;
461 /* Finish processing of a declaration without an initial value. */
464 gfc_finish_decl (tree decl
)
466 gcc_assert (TREE_CODE (decl
) == PARM_DECL
467 || DECL_INITIAL (decl
) == NULL_TREE
);
469 if (TREE_CODE (decl
) != VAR_DECL
)
472 if (DECL_SIZE (decl
) == NULL_TREE
473 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
474 layout_decl (decl
, 0);
476 /* A few consistency checks. */
477 /* A static variable with an incomplete type is an error if it is
478 initialized. Also if it is not file scope. Otherwise, let it
479 through, but if it is not `extern' then it may cause an error
481 /* An automatic variable with an incomplete type is an error. */
483 /* We should know the storage size. */
484 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
485 || (TREE_STATIC (decl
)
486 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
487 : DECL_EXTERNAL (decl
)));
489 /* The storage size should be constant. */
490 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
492 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
496 /* Apply symbol attributes to a variable, and add it to the function scope. */
499 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
502 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
503 This is the equivalent of the TARGET variables.
504 We also need to set this if the variable is passed by reference in a
507 /* Set DECL_VALUE_EXPR for Cray Pointees. */
508 if (sym
->attr
.cray_pointee
)
509 gfc_finish_cray_pointee (decl
, sym
);
511 if (sym
->attr
.target
)
512 TREE_ADDRESSABLE (decl
) = 1;
513 /* If it wasn't used we wouldn't be getting it. */
514 TREE_USED (decl
) = 1;
516 if (sym
->attr
.flavor
== FL_PARAMETER
517 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
518 TREE_READONLY (decl
) = 1;
520 /* Chain this decl to the pending declarations. Don't do pushdecl()
521 because this would add them to the current scope rather than the
523 if (current_function_decl
!= NULL_TREE
)
525 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
526 || sym
->result
== sym
)
527 gfc_add_decl_to_function (decl
);
528 else if (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
529 /* This is a BLOCK construct. */
530 add_decl_as_local (decl
);
532 gfc_add_decl_to_parent_function (decl
);
535 if (sym
->attr
.cray_pointee
)
538 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
540 /* We need to put variables that are bind(c) into the common
541 segment of the object file, because this is what C would do.
542 gfortran would typically put them in either the BSS or
543 initialized data segments, and only mark them as common if
544 they were part of common blocks. However, if they are not put
545 into common space, then C cannot initialize global Fortran
546 variables that it interoperates with and the draft says that
547 either Fortran or C should be able to initialize it (but not
548 both, of course.) (J3/04-007, section 15.3). */
549 TREE_PUBLIC(decl
) = 1;
550 DECL_COMMON(decl
) = 1;
553 /* If a variable is USE associated, it's always external. */
554 if (sym
->attr
.use_assoc
)
556 DECL_EXTERNAL (decl
) = 1;
557 TREE_PUBLIC (decl
) = 1;
559 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
561 /* TODO: Don't set sym->module for result or dummy variables. */
562 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
564 if (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
)
565 TREE_PUBLIC (decl
) = 1;
566 TREE_STATIC (decl
) = 1;
569 /* Derived types are a bit peculiar because of the possibility of
570 a default initializer; this must be applied each time the variable
571 comes into scope it therefore need not be static. These variables
572 are SAVE_NONE but have an initializer. Otherwise explicitly
573 initialized variables are SAVE_IMPLICIT and explicitly saved are
575 if (!sym
->attr
.use_assoc
576 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
577 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
578 || (gfc_option
.coarray
== GFC_FCOARRAY_LIB
579 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
580 TREE_STATIC (decl
) = 1;
582 if (sym
->attr
.volatile_
)
584 TREE_THIS_VOLATILE (decl
) = 1;
585 TREE_SIDE_EFFECTS (decl
) = 1;
586 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
587 TREE_TYPE (decl
) = new_type
;
590 /* Keep variables larger than max-stack-var-size off stack. */
591 if (!sym
->ns
->proc_name
->attr
.recursive
592 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
593 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
594 /* Put variable length auto array pointers always into stack. */
595 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
596 || sym
->attr
.dimension
== 0
597 || sym
->as
->type
!= AS_EXPLICIT
599 || sym
->attr
.allocatable
)
600 && !DECL_ARTIFICIAL (decl
))
601 TREE_STATIC (decl
) = 1;
603 /* Handle threadprivate variables. */
604 if (sym
->attr
.threadprivate
605 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
606 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
610 /* Allocate the lang-specific part of a decl. */
613 gfc_allocate_lang_decl (tree decl
)
615 DECL_LANG_SPECIFIC (decl
) = ggc_alloc_cleared_lang_decl(sizeof
619 /* Remember a symbol to generate initialization/cleanup code at function
623 gfc_defer_symbol_init (gfc_symbol
* sym
)
629 /* Don't add a symbol twice. */
633 last
= head
= sym
->ns
->proc_name
;
636 /* Make sure that setup code for dummy variables which are used in the
637 setup of other variables is generated first. */
640 /* Find the first dummy arg seen after us, or the first non-dummy arg.
641 This is a circular list, so don't go past the head. */
643 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
649 /* Insert in between last and p. */
655 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
656 backend_decl for a module symbol, if it all ready exists. If the
657 module gsymbol does not exist, it is created. If the symbol does
658 not exist, it is added to the gsymbol namespace. Returns true if
659 an existing backend_decl is found. */
662 gfc_get_module_backend_decl (gfc_symbol
*sym
)
668 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
670 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
676 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
682 gsym
= gfc_get_gsymbol (sym
->module
);
683 gsym
->type
= GSYM_MODULE
;
684 gsym
->ns
= gfc_get_namespace (NULL
, 0);
687 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
691 else if (sym
->attr
.flavor
== FL_DERIVED
)
693 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
696 gcc_assert (s
->attr
.generic
);
697 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
698 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
705 if (!s
->backend_decl
)
706 s
->backend_decl
= gfc_get_derived_type (s
);
707 gfc_copy_dt_decls_ifequal (s
, sym
, true);
710 else if (s
->backend_decl
)
712 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
713 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
715 else if (sym
->ts
.type
== BT_CHARACTER
)
716 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
717 sym
->backend_decl
= s
->backend_decl
;
725 /* Create an array index type variable with function scope. */
728 create_index_var (const char * pfx
, int nest
)
732 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
734 gfc_add_decl_to_parent_function (decl
);
736 gfc_add_decl_to_function (decl
);
741 /* Create variables to hold all the non-constant bits of info for a
742 descriptorless array. Remember these in the lang-specific part of the
746 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
751 gfc_namespace
* procns
;
753 type
= TREE_TYPE (decl
);
755 /* We just use the descriptor, if there is one. */
756 if (GFC_DESCRIPTOR_TYPE_P (type
))
759 gcc_assert (GFC_ARRAY_TYPE_P (type
));
760 procns
= gfc_find_proc_namespace (sym
->ns
);
761 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
762 && !sym
->attr
.contained
;
764 if (sym
->attr
.codimension
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
765 && sym
->as
->type
!= AS_ASSUMED_SHAPE
766 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
770 token
= gfc_create_var_np (build_qualified_type (pvoid_type_node
,
773 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
774 DECL_ARTIFICIAL (token
) = 1;
775 TREE_STATIC (token
) = 1;
776 gfc_add_decl_to_function (token
);
779 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
781 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
783 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
784 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
786 /* Don't try to use the unknown bound for assumed shape arrays. */
787 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
788 && (sym
->as
->type
!= AS_ASSUMED_SIZE
789 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
791 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
792 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
795 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
797 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
798 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
801 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
802 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
804 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
806 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
807 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
809 /* Don't try to use the unknown ubound for the last coarray dimension. */
810 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
811 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
813 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
814 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
817 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
819 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
821 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
824 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
826 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
829 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
830 && sym
->as
->type
!= AS_ASSUMED_SIZE
)
832 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
833 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
836 if (POINTER_TYPE_P (type
))
838 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
839 gcc_assert (TYPE_LANG_SPECIFIC (type
)
840 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
841 type
= TREE_TYPE (type
);
844 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
848 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
849 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
850 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
852 TYPE_DOMAIN (type
) = range
;
856 if (TYPE_NAME (type
) != NULL_TREE
857 && GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1) != NULL_TREE
858 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1)) == VAR_DECL
)
860 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
862 for (dim
= 0; dim
< sym
->as
->rank
- 1; dim
++)
864 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
865 gtype
= TREE_TYPE (gtype
);
867 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
868 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
869 TYPE_NAME (type
) = NULL_TREE
;
872 if (TYPE_NAME (type
) == NULL_TREE
)
874 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
876 for (dim
= sym
->as
->rank
- 1; dim
>= 0; dim
--)
879 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
880 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
881 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
882 gtype
= build_array_type (gtype
, rtype
);
883 /* Ensure the bound variables aren't optimized out at -O0.
884 For -O1 and above they often will be optimized out, but
885 can be tracked by VTA. Also set DECL_NAMELESS, so that
886 the artificial lbound.N or ubound.N DECL_NAME doesn't
887 end up in debug info. */
888 if (lbound
&& TREE_CODE (lbound
) == VAR_DECL
889 && DECL_ARTIFICIAL (lbound
) && DECL_IGNORED_P (lbound
))
891 if (DECL_NAME (lbound
)
892 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
894 DECL_NAMELESS (lbound
) = 1;
895 DECL_IGNORED_P (lbound
) = 0;
897 if (ubound
&& TREE_CODE (ubound
) == VAR_DECL
898 && DECL_ARTIFICIAL (ubound
) && DECL_IGNORED_P (ubound
))
900 if (DECL_NAME (ubound
)
901 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
903 DECL_NAMELESS (ubound
) = 1;
904 DECL_IGNORED_P (ubound
) = 0;
907 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
908 TYPE_DECL
, NULL
, gtype
);
909 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
914 /* For some dummy arguments we don't use the actual argument directly.
915 Instead we create a local decl and use that. This allows us to perform
916 initialization, and construct full type information. */
919 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
929 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
930 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
933 /* Add to list of variables if not a fake result variable. */
934 if (sym
->attr
.result
|| sym
->attr
.dummy
)
935 gfc_defer_symbol_init (sym
);
937 type
= TREE_TYPE (dummy
);
938 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
939 && POINTER_TYPE_P (type
));
941 /* Do we know the element size? */
942 known_size
= sym
->ts
.type
!= BT_CHARACTER
943 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
945 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
947 /* For descriptorless arrays with known element size the actual
948 argument is sufficient. */
949 gcc_assert (GFC_ARRAY_TYPE_P (type
));
950 gfc_build_qualified_array (dummy
, sym
);
954 type
= TREE_TYPE (type
);
955 if (GFC_DESCRIPTOR_TYPE_P (type
))
957 /* Create a descriptorless array pointer. */
961 /* Even when -frepack-arrays is used, symbols with TARGET attribute
963 if (!gfc_option
.flag_repack_arrays
|| sym
->attr
.target
)
965 if (as
->type
== AS_ASSUMED_SIZE
)
966 packed
= PACKED_FULL
;
970 if (as
->type
== AS_EXPLICIT
)
972 packed
= PACKED_FULL
;
973 for (n
= 0; n
< as
->rank
; n
++)
977 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
978 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
980 packed
= PACKED_PARTIAL
;
986 packed
= PACKED_PARTIAL
;
989 type
= gfc_typenode_for_spec (&sym
->ts
);
990 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
995 /* We now have an expression for the element size, so create a fully
996 qualified type. Reset sym->backend decl or this will just return the
998 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
999 sym
->backend_decl
= NULL_TREE
;
1000 type
= gfc_sym_type (sym
);
1001 packed
= PACKED_FULL
;
1004 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1005 decl
= build_decl (input_location
,
1006 VAR_DECL
, get_identifier (name
), type
);
1008 DECL_ARTIFICIAL (decl
) = 1;
1009 DECL_NAMELESS (decl
) = 1;
1010 TREE_PUBLIC (decl
) = 0;
1011 TREE_STATIC (decl
) = 0;
1012 DECL_EXTERNAL (decl
) = 0;
1014 /* Avoid uninitialized warnings for optional dummy arguments. */
1015 if (sym
->attr
.optional
)
1016 TREE_NO_WARNING (decl
) = 1;
1018 /* We should never get deferred shape arrays here. We used to because of
1020 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
1022 if (packed
== PACKED_PARTIAL
)
1023 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
1024 else if (packed
== PACKED_FULL
)
1025 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1027 gfc_build_qualified_array (decl
, sym
);
1029 if (DECL_LANG_SPECIFIC (dummy
))
1030 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
1032 gfc_allocate_lang_decl (decl
);
1034 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
1036 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
1037 || sym
->attr
.contained
)
1038 gfc_add_decl_to_function (decl
);
1040 gfc_add_decl_to_parent_function (decl
);
1045 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1046 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1047 pointing to the artificial variable for debug info purposes. */
1050 gfc_nonlocal_dummy_array_decl (gfc_symbol
*sym
)
1054 if (! nonlocal_dummy_decl_pset
)
1055 nonlocal_dummy_decl_pset
= pointer_set_create ();
1057 if (pointer_set_insert (nonlocal_dummy_decl_pset
, sym
->backend_decl
))
1060 dummy
= GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
);
1061 decl
= build_decl (input_location
, VAR_DECL
, DECL_NAME (dummy
),
1062 TREE_TYPE (sym
->backend_decl
));
1063 DECL_ARTIFICIAL (decl
) = 0;
1064 TREE_USED (decl
) = 1;
1065 TREE_PUBLIC (decl
) = 0;
1066 TREE_STATIC (decl
) = 0;
1067 DECL_EXTERNAL (decl
) = 0;
1068 if (DECL_BY_REFERENCE (dummy
))
1069 DECL_BY_REFERENCE (decl
) = 1;
1070 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (sym
->backend_decl
);
1071 SET_DECL_VALUE_EXPR (decl
, sym
->backend_decl
);
1072 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
1073 DECL_CONTEXT (decl
) = DECL_CONTEXT (sym
->backend_decl
);
1074 DECL_CHAIN (decl
) = nonlocal_dummy_decls
;
1075 nonlocal_dummy_decls
= decl
;
1078 /* Return a constant or a variable to use as a string length. Does not
1079 add the decl to the current scope. */
1082 gfc_create_string_length (gfc_symbol
* sym
)
1084 gcc_assert (sym
->ts
.u
.cl
);
1085 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
1087 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1092 /* The string length variable shall be in static memory if it is either
1093 explicitly SAVED, a module variable or with -fno-automatic. Only
1094 relevant is "len=:" - otherwise, it is either a constant length or
1095 it is an automatic variable. */
1096 bool static_length
= sym
->attr
.save
1097 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1098 || (gfc_option
.flag_max_stack_var_size
== 0
1099 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1100 && !sym
->attr
.result
&& !sym
->attr
.function
);
1102 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1103 variables as some systems do not support the "." in the assembler name.
1104 For nonstatic variables, the "." does not appear in assembler. */
1108 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1111 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1113 else if (sym
->module
)
1114 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1116 name
= gfc_get_string (".%s", sym
->name
);
1118 length
= build_decl (input_location
,
1119 VAR_DECL
, get_identifier (name
),
1120 gfc_charlen_type_node
);
1121 DECL_ARTIFICIAL (length
) = 1;
1122 TREE_USED (length
) = 1;
1123 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1124 gfc_defer_symbol_init (sym
);
1126 sym
->ts
.u
.cl
->backend_decl
= length
;
1129 TREE_STATIC (length
) = 1;
1131 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1132 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1133 TREE_PUBLIC (length
) = 1;
1136 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1137 return sym
->ts
.u
.cl
->backend_decl
;
1140 /* If a variable is assigned a label, we add another two auxiliary
1144 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1150 gcc_assert (sym
->backend_decl
);
1152 decl
= sym
->backend_decl
;
1153 gfc_allocate_lang_decl (decl
);
1154 GFC_DECL_ASSIGN (decl
) = 1;
1155 length
= build_decl (input_location
,
1156 VAR_DECL
, create_tmp_var_name (sym
->name
),
1157 gfc_charlen_type_node
);
1158 addr
= build_decl (input_location
,
1159 VAR_DECL
, create_tmp_var_name (sym
->name
),
1161 gfc_finish_var_decl (length
, sym
);
1162 gfc_finish_var_decl (addr
, sym
);
1163 /* STRING_LENGTH is also used as flag. Less than -1 means that
1164 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1165 target label's address. Otherwise, value is the length of a format string
1166 and ASSIGN_ADDR is its address. */
1167 if (TREE_STATIC (length
))
1168 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1170 gfc_defer_symbol_init (sym
);
1172 GFC_DECL_STRING_LEN (decl
) = length
;
1173 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1178 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1183 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1184 if (sym_attr
.ext_attr
& (1 << id
))
1186 attr
= build_tree_list (
1187 get_identifier (ext_attr_list
[id
].middle_end_name
),
1189 list
= chainon (list
, attr
);
1196 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1199 /* Return the decl for a gfc_symbol, create it if it doesn't already
1203 gfc_get_symbol_decl (gfc_symbol
* sym
)
1206 tree length
= NULL_TREE
;
1209 bool intrinsic_array_parameter
= false;
1212 gcc_assert (sym
->attr
.referenced
1213 || sym
->attr
.flavor
== FL_PROCEDURE
1214 || sym
->attr
.use_assoc
1215 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1216 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1217 && sym
->backend_decl
));
1219 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1220 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1224 /* Make sure that the vtab for the declared type is completed. */
1225 if (sym
->ts
.type
== BT_CLASS
)
1227 gfc_component
*c
= CLASS_DATA (sym
);
1228 if (!c
->ts
.u
.derived
->backend_decl
)
1230 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1231 gfc_get_derived_type (sym
->ts
.u
.derived
);
1235 /* All deferred character length procedures need to retain the backend
1236 decl, which is a pointer to the character length in the caller's
1237 namespace and to declare a local character length. */
1238 if (!byref
&& sym
->attr
.function
1239 && sym
->ts
.type
== BT_CHARACTER
1241 && sym
->ts
.u
.cl
->passed_length
== NULL
1242 && sym
->ts
.u
.cl
->backend_decl
1243 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1245 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1246 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1247 length
= gfc_create_string_length (sym
);
1250 fun_or_res
= byref
&& (sym
->attr
.result
1251 || (sym
->attr
.function
&& sym
->ts
.deferred
));
1252 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || fun_or_res
)
1254 /* Return via extra parameter. */
1255 if (sym
->attr
.result
&& byref
1256 && !sym
->backend_decl
)
1259 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1260 /* For entry master function skip over the __entry
1262 if (sym
->ns
->proc_name
->attr
.entry_master
)
1263 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1266 /* Dummy variables should already have been created. */
1267 gcc_assert (sym
->backend_decl
);
1269 /* Create a character length variable. */
1270 if (sym
->ts
.type
== BT_CHARACTER
)
1272 /* For a deferred dummy, make a new string length variable. */
1273 if (sym
->ts
.deferred
1275 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1276 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1278 if (sym
->ts
.deferred
&& fun_or_res
1279 && sym
->ts
.u
.cl
->passed_length
== NULL
1280 && sym
->ts
.u
.cl
->backend_decl
)
1282 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1283 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1286 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1287 length
= gfc_create_string_length (sym
);
1289 length
= sym
->ts
.u
.cl
->backend_decl
;
1290 if (TREE_CODE (length
) == VAR_DECL
1291 && DECL_FILE_SCOPE_P (length
))
1293 /* Add the string length to the same context as the symbol. */
1294 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1295 gfc_add_decl_to_function (length
);
1297 gfc_add_decl_to_parent_function (length
);
1299 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1300 DECL_CONTEXT (length
));
1302 gfc_defer_symbol_init (sym
);
1306 /* Use a copy of the descriptor for dummy arrays. */
1307 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1308 && !TREE_USED (sym
->backend_decl
))
1310 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1311 /* Prevent the dummy from being detected as unused if it is copied. */
1312 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1313 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1314 sym
->backend_decl
= decl
;
1317 TREE_USED (sym
->backend_decl
) = 1;
1318 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1320 gfc_add_assign_aux_vars (sym
);
1323 if (sym
->attr
.dimension
1324 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1325 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1326 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1327 gfc_nonlocal_dummy_array_decl (sym
);
1329 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1330 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1332 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1333 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1334 return sym
->backend_decl
;
1337 if (sym
->backend_decl
)
1338 return sym
->backend_decl
;
1340 /* Special case for array-valued named constants from intrinsic
1341 procedures; those are inlined. */
1342 if (sym
->attr
.use_assoc
&& sym
->from_intmod
1343 && sym
->attr
.flavor
== FL_PARAMETER
)
1344 intrinsic_array_parameter
= true;
1346 /* If use associated compilation, use the module
1348 if ((sym
->attr
.flavor
== FL_VARIABLE
1349 || sym
->attr
.flavor
== FL_PARAMETER
)
1350 && sym
->attr
.use_assoc
1351 && !intrinsic_array_parameter
1353 && gfc_get_module_backend_decl (sym
))
1355 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1356 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1357 return sym
->backend_decl
;
1360 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1362 /* Catch functions. Only used for actual parameters,
1363 procedure pointers and procptr initialization targets. */
1364 if (sym
->attr
.use_assoc
|| sym
->attr
.intrinsic
1365 || sym
->attr
.if_source
!= IFSRC_DECL
)
1367 decl
= gfc_get_extern_function_decl (sym
);
1368 gfc_set_decl_location (decl
, &sym
->declared_at
);
1372 if (!sym
->backend_decl
)
1373 build_function_decl (sym
, false);
1374 decl
= sym
->backend_decl
;
1379 if (sym
->attr
.intrinsic
)
1380 internal_error ("intrinsic variable which isn't a procedure");
1382 /* Create string length decl first so that they can be used in the
1383 type declaration. */
1384 if (sym
->ts
.type
== BT_CHARACTER
)
1385 length
= gfc_create_string_length (sym
);
1387 /* Create the decl for the variable. */
1388 decl
= build_decl (sym
->declared_at
.lb
->location
,
1389 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1391 /* Add attributes to variables. Functions are handled elsewhere. */
1392 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1393 decl_attributes (&decl
, attributes
, 0);
1395 /* Symbols from modules should have their assembler names mangled.
1396 This is done here rather than in gfc_finish_var_decl because it
1397 is different for string length variables. */
1400 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1401 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1402 DECL_IGNORED_P (decl
) = 1;
1405 if (sym
->attr
.select_type_temporary
)
1407 DECL_ARTIFICIAL (decl
) = 1;
1408 DECL_IGNORED_P (decl
) = 1;
1411 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1413 /* Create variables to hold the non-constant bits of array info. */
1414 gfc_build_qualified_array (decl
, sym
);
1416 if (sym
->attr
.contiguous
1417 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1418 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1421 /* Remember this variable for allocation/cleanup. */
1422 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1423 || (sym
->ts
.type
== BT_CLASS
&&
1424 (CLASS_DATA (sym
)->attr
.dimension
1425 || CLASS_DATA (sym
)->attr
.allocatable
))
1426 || (sym
->ts
.type
== BT_DERIVED
1427 && (sym
->ts
.u
.derived
->attr
.alloc_comp
1428 || (!sym
->attr
.pointer
&& !sym
->attr
.artificial
&& !sym
->attr
.save
1429 && !sym
->ns
->proc_name
->attr
.is_main_program
1430 && gfc_is_finalizable (sym
->ts
.u
.derived
, NULL
))))
1431 /* This applies a derived type default initializer. */
1432 || (sym
->ts
.type
== BT_DERIVED
1433 && sym
->attr
.save
== SAVE_NONE
1435 && !sym
->attr
.allocatable
1436 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1437 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1438 gfc_defer_symbol_init (sym
);
1440 gfc_finish_var_decl (decl
, sym
);
1442 if (sym
->ts
.type
== BT_CHARACTER
)
1444 /* Character variables need special handling. */
1445 gfc_allocate_lang_decl (decl
);
1447 if (TREE_CODE (length
) != INTEGER_CST
)
1449 gfc_finish_var_decl (length
, sym
);
1450 gcc_assert (!sym
->value
);
1453 else if (sym
->attr
.subref_array_pointer
)
1455 /* We need the span for these beasts. */
1456 gfc_allocate_lang_decl (decl
);
1459 if (sym
->attr
.subref_array_pointer
)
1462 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1463 span
= build_decl (input_location
,
1464 VAR_DECL
, create_tmp_var_name ("span"),
1465 gfc_array_index_type
);
1466 gfc_finish_var_decl (span
, sym
);
1467 TREE_STATIC (span
) = TREE_STATIC (decl
);
1468 DECL_ARTIFICIAL (span
) = 1;
1470 GFC_DECL_SPAN (decl
) = span
;
1471 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1474 if (sym
->ts
.type
== BT_CLASS
)
1475 GFC_DECL_CLASS(decl
) = 1;
1477 sym
->backend_decl
= decl
;
1479 if (sym
->attr
.assign
)
1480 gfc_add_assign_aux_vars (sym
);
1482 if (intrinsic_array_parameter
)
1484 TREE_STATIC (decl
) = 1;
1485 DECL_EXTERNAL (decl
) = 0;
1488 if (TREE_STATIC (decl
)
1489 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1490 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1491 || gfc_option
.flag_max_stack_var_size
== 0
1492 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1493 && (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
1494 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
))
1496 /* Add static initializer. For procedures, it is only needed if
1497 SAVE is specified otherwise they need to be reinitialized
1498 every time the procedure is entered. The TREE_STATIC is
1499 in this case due to -fmax-stack-var-size=. */
1501 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1502 TREE_TYPE (decl
), sym
->attr
.dimension
1503 || (sym
->attr
.codimension
1504 && sym
->attr
.allocatable
),
1505 sym
->attr
.pointer
|| sym
->attr
.allocatable
1506 || sym
->ts
.type
== BT_CLASS
,
1507 sym
->attr
.proc_pointer
);
1510 if (!TREE_STATIC (decl
)
1511 && POINTER_TYPE_P (TREE_TYPE (decl
))
1512 && !sym
->attr
.pointer
1513 && !sym
->attr
.allocatable
1514 && !sym
->attr
.proc_pointer
1515 && !sym
->attr
.select_type_temporary
)
1516 DECL_BY_REFERENCE (decl
) = 1;
1519 || (sym
->name
[0] == '_' && strncmp ("__def_init", sym
->name
, 10) == 0))
1520 TREE_READONLY (decl
) = 1;
1526 /* Substitute a temporary variable in place of the real one. */
1529 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1531 save
->attr
= sym
->attr
;
1532 save
->decl
= sym
->backend_decl
;
1534 gfc_clear_attr (&sym
->attr
);
1535 sym
->attr
.referenced
= 1;
1536 sym
->attr
.flavor
= FL_VARIABLE
;
1538 sym
->backend_decl
= decl
;
1542 /* Restore the original variable. */
1545 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1547 sym
->attr
= save
->attr
;
1548 sym
->backend_decl
= save
->decl
;
1552 /* Declare a procedure pointer. */
1555 get_proc_pointer_decl (gfc_symbol
*sym
)
1560 decl
= sym
->backend_decl
;
1564 decl
= build_decl (input_location
,
1565 VAR_DECL
, get_identifier (sym
->name
),
1566 build_pointer_type (gfc_get_function_type (sym
)));
1570 /* Apply name mangling. */
1571 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1572 if (sym
->attr
.use_assoc
)
1573 DECL_IGNORED_P (decl
) = 1;
1576 if ((sym
->ns
->proc_name
1577 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1578 || sym
->attr
.contained
)
1579 gfc_add_decl_to_function (decl
);
1580 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1581 gfc_add_decl_to_parent_function (decl
);
1583 sym
->backend_decl
= decl
;
1585 /* If a variable is USE associated, it's always external. */
1586 if (sym
->attr
.use_assoc
)
1588 DECL_EXTERNAL (decl
) = 1;
1589 TREE_PUBLIC (decl
) = 1;
1591 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1593 /* This is the declaration of a module variable. */
1594 TREE_PUBLIC (decl
) = 1;
1595 TREE_STATIC (decl
) = 1;
1598 if (!sym
->attr
.use_assoc
1599 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1600 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1601 TREE_STATIC (decl
) = 1;
1603 if (TREE_STATIC (decl
) && sym
->value
)
1605 /* Add static initializer. */
1606 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1608 sym
->attr
.dimension
,
1612 /* Handle threadprivate procedure pointers. */
1613 if (sym
->attr
.threadprivate
1614 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
1615 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
1617 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1618 decl_attributes (&decl
, attributes
, 0);
1624 /* Get a basic decl for an external function. */
1627 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1633 gfc_intrinsic_sym
*isym
;
1635 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1640 if (sym
->backend_decl
)
1641 return sym
->backend_decl
;
1643 /* We should never be creating external decls for alternate entry points.
1644 The procedure may be an alternate entry point, but we don't want/need
1646 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1648 if (sym
->attr
.proc_pointer
)
1649 return get_proc_pointer_decl (sym
);
1651 /* See if this is an external procedure from the same file. If so,
1652 return the backend_decl. */
1653 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
1654 ? sym
->binding_label
: sym
->name
);
1656 if (gsym
&& !gsym
->defined
)
1659 /* This can happen because of C binding. */
1660 if (gsym
&& gsym
->ns
&& gsym
->ns
->proc_name
1661 && gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1664 if ((!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
1665 && !sym
->backend_decl
1667 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1668 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
1670 if (!gsym
->ns
->proc_name
->backend_decl
)
1672 /* By construction, the external function cannot be
1673 a contained procedure. */
1676 gfc_save_backend_locus (&old_loc
);
1679 gfc_create_function_decl (gsym
->ns
, true);
1682 gfc_restore_backend_locus (&old_loc
);
1685 /* If the namespace has entries, the proc_name is the
1686 entry master. Find the entry and use its backend_decl.
1687 otherwise, use the proc_name backend_decl. */
1688 if (gsym
->ns
->entries
)
1690 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1692 for (; entry
; entry
= entry
->next
)
1694 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1696 sym
->backend_decl
= entry
->sym
->backend_decl
;
1702 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1704 if (sym
->backend_decl
)
1706 /* Avoid problems of double deallocation of the backend declaration
1707 later in gfc_trans_use_stmts; cf. PR 45087. */
1708 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
1709 sym
->attr
.use_assoc
= 0;
1711 return sym
->backend_decl
;
1715 /* See if this is a module procedure from the same file. If so,
1716 return the backend_decl. */
1718 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1721 if (gsym
&& gsym
->ns
1722 && (gsym
->type
== GSYM_MODULE
1723 || (gsym
->ns
->proc_name
&& gsym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
1728 if (gsym
->type
== GSYM_MODULE
)
1729 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1731 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &s
);
1733 if (s
&& s
->backend_decl
)
1735 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1736 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
1738 else if (sym
->ts
.type
== BT_CHARACTER
)
1739 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1740 sym
->backend_decl
= s
->backend_decl
;
1741 return sym
->backend_decl
;
1745 if (sym
->attr
.intrinsic
)
1747 /* Call the resolution function to get the actual name. This is
1748 a nasty hack which relies on the resolution functions only looking
1749 at the first argument. We pass NULL for the second argument
1750 otherwise things like AINT get confused. */
1751 isym
= gfc_find_function (sym
->name
);
1752 gcc_assert (isym
->resolve
.f0
!= NULL
);
1754 memset (&e
, 0, sizeof (e
));
1755 e
.expr_type
= EXPR_FUNCTION
;
1757 memset (&argexpr
, 0, sizeof (argexpr
));
1758 gcc_assert (isym
->formal
);
1759 argexpr
.ts
= isym
->formal
->ts
;
1761 if (isym
->formal
->next
== NULL
)
1762 isym
->resolve
.f1 (&e
, &argexpr
);
1765 if (isym
->formal
->next
->next
== NULL
)
1766 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1769 if (isym
->formal
->next
->next
->next
== NULL
)
1770 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1773 /* All specific intrinsics take less than 5 arguments. */
1774 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1775 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1780 if (gfc_option
.flag_f2c
1781 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1782 || e
.ts
.type
== BT_COMPLEX
))
1784 /* Specific which needs a different implementation if f2c
1785 calling conventions are used. */
1786 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1789 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1791 name
= get_identifier (s
);
1792 mangled_name
= name
;
1796 name
= gfc_sym_identifier (sym
);
1797 mangled_name
= gfc_sym_mangled_function_id (sym
);
1800 type
= gfc_get_function_type (sym
);
1801 fndecl
= build_decl (input_location
,
1802 FUNCTION_DECL
, name
, type
);
1804 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1805 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1806 the opposite of declaring a function as static in C). */
1807 DECL_EXTERNAL (fndecl
) = 1;
1808 TREE_PUBLIC (fndecl
) = 1;
1810 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1811 decl_attributes (&fndecl
, attributes
, 0);
1813 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
1815 /* Set the context of this decl. */
1816 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1818 /* TODO: Add external decls to the appropriate scope. */
1819 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1823 /* Global declaration, e.g. intrinsic subroutine. */
1824 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1827 /* Set attributes for PURE functions. A call to PURE function in the
1828 Fortran 95 sense is both pure and without side effects in the C
1830 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
1832 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1833 DECL_PURE_P (fndecl
) = 1;
1834 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1835 parameters and don't use alternate returns (is this
1836 allowed?). In that case, calls to them are meaningless, and
1837 can be optimized away. See also in build_function_decl(). */
1838 TREE_SIDE_EFFECTS (fndecl
) = 0;
1841 /* Mark non-returning functions. */
1842 if (sym
->attr
.noreturn
)
1843 TREE_THIS_VOLATILE(fndecl
) = 1;
1845 sym
->backend_decl
= fndecl
;
1847 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1848 pushdecl_top_level (fndecl
);
1854 /* Create a declaration for a procedure. For external functions (in the C
1855 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1856 a master function with alternate entry points. */
1859 build_function_decl (gfc_symbol
* sym
, bool global
)
1861 tree fndecl
, type
, attributes
;
1862 symbol_attribute attr
;
1864 gfc_formal_arglist
*f
;
1866 gcc_assert (!sym
->attr
.external
);
1868 if (sym
->backend_decl
)
1871 /* Set the line and filename. sym->declared_at seems to point to the
1872 last statement for subroutines, but it'll do for now. */
1873 gfc_set_backend_locus (&sym
->declared_at
);
1875 /* Allow only one nesting level. Allow public declarations. */
1876 gcc_assert (current_function_decl
== NULL_TREE
1877 || DECL_FILE_SCOPE_P (current_function_decl
)
1878 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
1879 == NAMESPACE_DECL
));
1881 type
= gfc_get_function_type (sym
);
1882 fndecl
= build_decl (input_location
,
1883 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1887 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1888 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1889 the opposite of declaring a function as static in C). */
1890 DECL_EXTERNAL (fndecl
) = 0;
1892 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
1893 && (sym
->ns
->default_access
== ACCESS_PRIVATE
1894 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
1895 && gfc_option
.flag_module_private
)))
1896 sym
->attr
.access
= ACCESS_PRIVATE
;
1898 if (!current_function_decl
1899 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
1900 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
1901 || sym
->attr
.public_used
))
1902 TREE_PUBLIC (fndecl
) = 1;
1904 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
1905 TREE_USED (fndecl
) = 1;
1907 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
1908 decl_attributes (&fndecl
, attributes
, 0);
1910 /* Figure out the return type of the declared function, and build a
1911 RESULT_DECL for it. If this is a subroutine with alternate
1912 returns, build a RESULT_DECL for it. */
1913 result_decl
= NULL_TREE
;
1914 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1917 if (gfc_return_by_reference (sym
))
1918 type
= void_type_node
;
1921 if (sym
->result
!= sym
)
1922 result_decl
= gfc_sym_identifier (sym
->result
);
1924 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1929 /* Look for alternate return placeholders. */
1930 int has_alternate_returns
= 0;
1931 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
1935 has_alternate_returns
= 1;
1940 if (has_alternate_returns
)
1941 type
= integer_type_node
;
1943 type
= void_type_node
;
1946 result_decl
= build_decl (input_location
,
1947 RESULT_DECL
, result_decl
, type
);
1948 DECL_ARTIFICIAL (result_decl
) = 1;
1949 DECL_IGNORED_P (result_decl
) = 1;
1950 DECL_CONTEXT (result_decl
) = fndecl
;
1951 DECL_RESULT (fndecl
) = result_decl
;
1953 /* Don't call layout_decl for a RESULT_DECL.
1954 layout_decl (result_decl, 0); */
1956 /* TREE_STATIC means the function body is defined here. */
1957 TREE_STATIC (fndecl
) = 1;
1959 /* Set attributes for PURE functions. A call to a PURE function in the
1960 Fortran 95 sense is both pure and without side effects in the C
1962 if (attr
.pure
|| attr
.implicit_pure
)
1964 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1965 including an alternate return. In that case it can also be
1966 marked as PURE. See also in gfc_get_extern_function_decl(). */
1967 if (attr
.function
&& !gfc_return_by_reference (sym
))
1968 DECL_PURE_P (fndecl
) = 1;
1969 TREE_SIDE_EFFECTS (fndecl
) = 0;
1973 /* Layout the function declaration and put it in the binding level
1974 of the current function. */
1977 pushdecl_top_level (fndecl
);
1981 /* Perform name mangling if this is a top level or module procedure. */
1982 if (current_function_decl
== NULL_TREE
)
1983 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
1985 sym
->backend_decl
= fndecl
;
1989 /* Create the DECL_ARGUMENTS for a procedure. */
1992 create_function_arglist (gfc_symbol
* sym
)
1995 gfc_formal_arglist
*f
;
1996 tree typelist
, hidden_typelist
;
1997 tree arglist
, hidden_arglist
;
2001 fndecl
= sym
->backend_decl
;
2003 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2004 the new FUNCTION_DECL node. */
2005 arglist
= NULL_TREE
;
2006 hidden_arglist
= NULL_TREE
;
2007 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
2009 if (sym
->attr
.entry_master
)
2011 type
= TREE_VALUE (typelist
);
2012 parm
= build_decl (input_location
,
2013 PARM_DECL
, get_identifier ("__entry"), type
);
2015 DECL_CONTEXT (parm
) = fndecl
;
2016 DECL_ARG_TYPE (parm
) = type
;
2017 TREE_READONLY (parm
) = 1;
2018 gfc_finish_decl (parm
);
2019 DECL_ARTIFICIAL (parm
) = 1;
2021 arglist
= chainon (arglist
, parm
);
2022 typelist
= TREE_CHAIN (typelist
);
2025 if (gfc_return_by_reference (sym
))
2027 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2029 if (sym
->ts
.type
== BT_CHARACTER
)
2031 /* Length of character result. */
2032 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2034 length
= build_decl (input_location
,
2036 get_identifier (".__result"),
2038 if (!sym
->ts
.u
.cl
->length
)
2040 sym
->ts
.u
.cl
->backend_decl
= length
;
2041 TREE_USED (length
) = 1;
2043 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2044 DECL_CONTEXT (length
) = fndecl
;
2045 DECL_ARG_TYPE (length
) = len_type
;
2046 TREE_READONLY (length
) = 1;
2047 DECL_ARTIFICIAL (length
) = 1;
2048 gfc_finish_decl (length
);
2049 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2050 || sym
->ts
.u
.cl
->backend_decl
== length
)
2055 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2057 tree len
= build_decl (input_location
,
2059 get_identifier ("..__result"),
2060 gfc_charlen_type_node
);
2061 DECL_ARTIFICIAL (len
) = 1;
2062 TREE_USED (len
) = 1;
2063 sym
->ts
.u
.cl
->backend_decl
= len
;
2066 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2067 arg
= sym
->result
? sym
->result
: sym
;
2068 backend_decl
= arg
->backend_decl
;
2069 /* Temporary clear it, so that gfc_sym_type creates complete
2071 arg
->backend_decl
= NULL
;
2072 type
= gfc_sym_type (arg
);
2073 arg
->backend_decl
= backend_decl
;
2074 type
= build_reference_type (type
);
2078 parm
= build_decl (input_location
,
2079 PARM_DECL
, get_identifier ("__result"), type
);
2081 DECL_CONTEXT (parm
) = fndecl
;
2082 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2083 TREE_READONLY (parm
) = 1;
2084 DECL_ARTIFICIAL (parm
) = 1;
2085 gfc_finish_decl (parm
);
2087 arglist
= chainon (arglist
, parm
);
2088 typelist
= TREE_CHAIN (typelist
);
2090 if (sym
->ts
.type
== BT_CHARACTER
)
2092 gfc_allocate_lang_decl (parm
);
2093 arglist
= chainon (arglist
, length
);
2094 typelist
= TREE_CHAIN (typelist
);
2098 hidden_typelist
= typelist
;
2099 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2100 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2101 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2103 for (f
= gfc_sym_get_dummy_args (sym
); f
; f
= f
->next
)
2105 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2107 /* Ignore alternate returns. */
2111 type
= TREE_VALUE (typelist
);
2113 if (f
->sym
->ts
.type
== BT_CHARACTER
2114 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2116 tree len_type
= TREE_VALUE (hidden_typelist
);
2117 tree length
= NULL_TREE
;
2118 if (!f
->sym
->ts
.deferred
)
2119 gcc_assert (len_type
== gfc_charlen_type_node
);
2121 gcc_assert (POINTER_TYPE_P (len_type
));
2123 strcpy (&name
[1], f
->sym
->name
);
2125 length
= build_decl (input_location
,
2126 PARM_DECL
, get_identifier (name
), len_type
);
2128 hidden_arglist
= chainon (hidden_arglist
, length
);
2129 DECL_CONTEXT (length
) = fndecl
;
2130 DECL_ARTIFICIAL (length
) = 1;
2131 DECL_ARG_TYPE (length
) = len_type
;
2132 TREE_READONLY (length
) = 1;
2133 gfc_finish_decl (length
);
2135 /* Remember the passed value. */
2136 if (!f
->sym
->ts
.u
.cl
|| f
->sym
->ts
.u
.cl
->passed_length
)
2138 /* This can happen if the same type is used for multiple
2139 arguments. We need to copy cl as otherwise
2140 cl->passed_length gets overwritten. */
2141 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2143 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2145 /* Use the passed value for assumed length variables. */
2146 if (!f
->sym
->ts
.u
.cl
->length
)
2148 TREE_USED (length
) = 1;
2149 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2150 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2153 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2155 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2156 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2158 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2159 gfc_create_string_length (f
->sym
);
2161 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2162 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2163 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2165 type
= gfc_sym_type (f
->sym
);
2168 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2169 hence, the optional status cannot be transferred via a NULL pointer.
2170 Thus, we will use a hidden argument in that case. */
2171 else if (f
->sym
->attr
.optional
&& f
->sym
->attr
.value
2172 && !f
->sym
->attr
.dimension
&& f
->sym
->ts
.type
!= BT_CLASS
2173 && f
->sym
->ts
.type
!= BT_DERIVED
)
2176 strcpy (&name
[1], f
->sym
->name
);
2178 tmp
= build_decl (input_location
,
2179 PARM_DECL
, get_identifier (name
),
2182 hidden_arglist
= chainon (hidden_arglist
, tmp
);
2183 DECL_CONTEXT (tmp
) = fndecl
;
2184 DECL_ARTIFICIAL (tmp
) = 1;
2185 DECL_ARG_TYPE (tmp
) = boolean_type_node
;
2186 TREE_READONLY (tmp
) = 1;
2187 gfc_finish_decl (tmp
);
2190 /* For non-constant length array arguments, make sure they use
2191 a different type node from TYPE_ARG_TYPES type. */
2192 if (f
->sym
->attr
.dimension
2193 && type
== TREE_VALUE (typelist
)
2194 && TREE_CODE (type
) == POINTER_TYPE
2195 && GFC_ARRAY_TYPE_P (type
)
2196 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2197 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2199 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2200 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2202 type
= gfc_sym_type (f
->sym
);
2205 if (f
->sym
->attr
.proc_pointer
)
2206 type
= build_pointer_type (type
);
2208 if (f
->sym
->attr
.volatile_
)
2209 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2211 /* Build the argument declaration. */
2212 parm
= build_decl (input_location
,
2213 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2215 if (f
->sym
->attr
.volatile_
)
2217 TREE_THIS_VOLATILE (parm
) = 1;
2218 TREE_SIDE_EFFECTS (parm
) = 1;
2221 /* Fill in arg stuff. */
2222 DECL_CONTEXT (parm
) = fndecl
;
2223 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2224 /* All implementation args are read-only. */
2225 TREE_READONLY (parm
) = 1;
2226 if (POINTER_TYPE_P (type
)
2227 && (!f
->sym
->attr
.proc_pointer
2228 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2229 DECL_BY_REFERENCE (parm
) = 1;
2231 gfc_finish_decl (parm
);
2233 f
->sym
->backend_decl
= parm
;
2235 /* Coarrays which are descriptorless or assumed-shape pass with
2236 -fcoarray=lib the token and the offset as hidden arguments. */
2237 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
2238 && ((f
->sym
->ts
.type
!= BT_CLASS
&& f
->sym
->attr
.codimension
2239 && !f
->sym
->attr
.allocatable
)
2240 || (f
->sym
->ts
.type
== BT_CLASS
2241 && CLASS_DATA (f
->sym
)->attr
.codimension
2242 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)))
2248 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2249 && !sym
->attr
.is_bind_c
);
2250 caf_type
= f
->sym
->ts
.type
== BT_CLASS
2251 ? TREE_TYPE (CLASS_DATA (f
->sym
)->backend_decl
)
2252 : TREE_TYPE (f
->sym
->backend_decl
);
2254 token
= build_decl (input_location
, PARM_DECL
,
2255 create_tmp_var_name ("caf_token"),
2256 build_qualified_type (pvoid_type_node
,
2257 TYPE_QUAL_RESTRICT
));
2258 if ((f
->sym
->ts
.type
!= BT_CLASS
2259 && f
->sym
->as
->type
!= AS_DEFERRED
)
2260 || (f
->sym
->ts
.type
== BT_CLASS
2261 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2263 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2264 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2265 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2266 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2267 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2271 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2272 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2275 DECL_CONTEXT (token
) = fndecl
;
2276 DECL_ARTIFICIAL (token
) = 1;
2277 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2278 TREE_READONLY (token
) = 1;
2279 hidden_arglist
= chainon (hidden_arglist
, token
);
2280 gfc_finish_decl (token
);
2282 offset
= build_decl (input_location
, PARM_DECL
,
2283 create_tmp_var_name ("caf_offset"),
2284 gfc_array_index_type
);
2286 if ((f
->sym
->ts
.type
!= BT_CLASS
2287 && f
->sym
->as
->type
!= AS_DEFERRED
)
2288 || (f
->sym
->ts
.type
== BT_CLASS
2289 && CLASS_DATA (f
->sym
)->as
->type
!= AS_DEFERRED
))
2291 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2293 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2297 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2298 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2300 DECL_CONTEXT (offset
) = fndecl
;
2301 DECL_ARTIFICIAL (offset
) = 1;
2302 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2303 TREE_READONLY (offset
) = 1;
2304 hidden_arglist
= chainon (hidden_arglist
, offset
);
2305 gfc_finish_decl (offset
);
2308 arglist
= chainon (arglist
, parm
);
2309 typelist
= TREE_CHAIN (typelist
);
2312 /* Add the hidden string length parameters, unless the procedure
2314 if (!sym
->attr
.is_bind_c
)
2315 arglist
= chainon (arglist
, hidden_arglist
);
2317 gcc_assert (hidden_typelist
== NULL_TREE
2318 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2319 DECL_ARGUMENTS (fndecl
) = arglist
;
2322 /* Do the setup necessary before generating the body of a function. */
2325 trans_function_start (gfc_symbol
* sym
)
2329 fndecl
= sym
->backend_decl
;
2331 /* Let GCC know the current scope is this function. */
2332 current_function_decl
= fndecl
;
2334 /* Let the world know what we're about to do. */
2335 announce_function (fndecl
);
2337 if (DECL_FILE_SCOPE_P (fndecl
))
2339 /* Create RTL for function declaration. */
2340 rest_of_decl_compilation (fndecl
, 1, 0);
2343 /* Create RTL for function definition. */
2344 make_decl_rtl (fndecl
);
2346 allocate_struct_function (fndecl
, false);
2348 /* function.c requires a push at the start of the function. */
2352 /* Create thunks for alternate entry points. */
2355 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2357 gfc_formal_arglist
*formal
;
2358 gfc_formal_arglist
*thunk_formal
;
2360 gfc_symbol
*thunk_sym
;
2366 /* This should always be a toplevel function. */
2367 gcc_assert (current_function_decl
== NULL_TREE
);
2369 gfc_save_backend_locus (&old_loc
);
2370 for (el
= ns
->entries
; el
; el
= el
->next
)
2372 vec
<tree
, va_gc
> *args
= NULL
;
2373 vec
<tree
, va_gc
> *string_args
= NULL
;
2375 thunk_sym
= el
->sym
;
2377 build_function_decl (thunk_sym
, global
);
2378 create_function_arglist (thunk_sym
);
2380 trans_function_start (thunk_sym
);
2382 thunk_fndecl
= thunk_sym
->backend_decl
;
2384 gfc_init_block (&body
);
2386 /* Pass extra parameter identifying this entry point. */
2387 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2388 vec_safe_push (args
, tmp
);
2390 if (thunk_sym
->attr
.function
)
2392 if (gfc_return_by_reference (ns
->proc_name
))
2394 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2395 vec_safe_push (args
, ref
);
2396 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2397 vec_safe_push (args
, DECL_CHAIN (ref
));
2401 for (formal
= gfc_sym_get_dummy_args (ns
->proc_name
); formal
;
2402 formal
= formal
->next
)
2404 /* Ignore alternate returns. */
2405 if (formal
->sym
== NULL
)
2408 /* We don't have a clever way of identifying arguments, so resort to
2409 a brute-force search. */
2410 for (thunk_formal
= gfc_sym_get_dummy_args (thunk_sym
);
2412 thunk_formal
= thunk_formal
->next
)
2414 if (thunk_formal
->sym
== formal
->sym
)
2420 /* Pass the argument. */
2421 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2422 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2423 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2425 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2426 vec_safe_push (string_args
, tmp
);
2431 /* Pass NULL for a missing argument. */
2432 vec_safe_push (args
, null_pointer_node
);
2433 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2435 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2436 vec_safe_push (string_args
, tmp
);
2441 /* Call the master function. */
2442 vec_safe_splice (args
, string_args
);
2443 tmp
= ns
->proc_name
->backend_decl
;
2444 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2445 if (ns
->proc_name
->attr
.mixed_entry_master
)
2447 tree union_decl
, field
;
2448 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2450 union_decl
= build_decl (input_location
,
2451 VAR_DECL
, get_identifier ("__result"),
2452 TREE_TYPE (master_type
));
2453 DECL_ARTIFICIAL (union_decl
) = 1;
2454 DECL_EXTERNAL (union_decl
) = 0;
2455 TREE_PUBLIC (union_decl
) = 0;
2456 TREE_USED (union_decl
) = 1;
2457 layout_decl (union_decl
, 0);
2458 pushdecl (union_decl
);
2460 DECL_CONTEXT (union_decl
) = current_function_decl
;
2461 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2462 TREE_TYPE (union_decl
), union_decl
, tmp
);
2463 gfc_add_expr_to_block (&body
, tmp
);
2465 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2466 field
; field
= DECL_CHAIN (field
))
2467 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2468 thunk_sym
->result
->name
) == 0)
2470 gcc_assert (field
!= NULL_TREE
);
2471 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2472 TREE_TYPE (field
), union_decl
, field
,
2474 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2475 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2476 DECL_RESULT (current_function_decl
), tmp
);
2477 tmp
= build1_v (RETURN_EXPR
, tmp
);
2479 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2482 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2483 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2484 DECL_RESULT (current_function_decl
), tmp
);
2485 tmp
= build1_v (RETURN_EXPR
, tmp
);
2487 gfc_add_expr_to_block (&body
, tmp
);
2489 /* Finish off this function and send it for code generation. */
2490 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2493 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2494 DECL_SAVED_TREE (thunk_fndecl
)
2495 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2496 DECL_INITIAL (thunk_fndecl
));
2498 /* Output the GENERIC tree. */
2499 dump_function (TDI_original
, thunk_fndecl
);
2501 /* Store the end of the function, so that we get good line number
2502 info for the epilogue. */
2503 cfun
->function_end_locus
= input_location
;
2505 /* We're leaving the context of this function, so zap cfun.
2506 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2507 tree_rest_of_compilation. */
2510 current_function_decl
= NULL_TREE
;
2512 cgraph_finalize_function (thunk_fndecl
, true);
2514 /* We share the symbols in the formal argument list with other entry
2515 points and the master function. Clear them so that they are
2516 recreated for each function. */
2517 for (formal
= gfc_sym_get_dummy_args (thunk_sym
); formal
;
2518 formal
= formal
->next
)
2519 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2521 formal
->sym
->backend_decl
= NULL_TREE
;
2522 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2523 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2526 if (thunk_sym
->attr
.function
)
2528 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2529 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2530 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2531 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2535 gfc_restore_backend_locus (&old_loc
);
2539 /* Create a decl for a function, and create any thunks for alternate entry
2540 points. If global is true, generate the function in the global binding
2541 level, otherwise in the current binding level (which can be global). */
2544 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
2546 /* Create a declaration for the master function. */
2547 build_function_decl (ns
->proc_name
, global
);
2549 /* Compile the entry thunks. */
2551 build_entry_thunks (ns
, global
);
2553 /* Now create the read argument list. */
2554 create_function_arglist (ns
->proc_name
);
2557 /* Return the decl used to hold the function return value. If
2558 parent_flag is set, the context is the parent_scope. */
2561 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2565 tree this_fake_result_decl
;
2566 tree this_function_decl
;
2568 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2572 this_fake_result_decl
= parent_fake_result_decl
;
2573 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2577 this_fake_result_decl
= current_fake_result_decl
;
2578 this_function_decl
= current_function_decl
;
2582 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2583 && sym
->ns
->proc_name
->attr
.entry_master
2584 && sym
!= sym
->ns
->proc_name
)
2587 if (this_fake_result_decl
!= NULL
)
2588 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2589 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2592 return TREE_VALUE (t
);
2593 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2596 this_fake_result_decl
= parent_fake_result_decl
;
2598 this_fake_result_decl
= current_fake_result_decl
;
2600 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2604 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2605 field
; field
= DECL_CHAIN (field
))
2606 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2610 gcc_assert (field
!= NULL_TREE
);
2611 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2612 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
2615 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2617 gfc_add_decl_to_parent_function (var
);
2619 gfc_add_decl_to_function (var
);
2621 SET_DECL_VALUE_EXPR (var
, decl
);
2622 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2623 GFC_DECL_RESULT (var
) = 1;
2625 TREE_CHAIN (this_fake_result_decl
)
2626 = tree_cons (get_identifier (sym
->name
), var
,
2627 TREE_CHAIN (this_fake_result_decl
));
2631 if (this_fake_result_decl
!= NULL_TREE
)
2632 return TREE_VALUE (this_fake_result_decl
);
2634 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2639 if (sym
->ts
.type
== BT_CHARACTER
)
2641 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2642 length
= gfc_create_string_length (sym
);
2644 length
= sym
->ts
.u
.cl
->backend_decl
;
2645 if (TREE_CODE (length
) == VAR_DECL
2646 && DECL_CONTEXT (length
) == NULL_TREE
)
2647 gfc_add_decl_to_function (length
);
2650 if (gfc_return_by_reference (sym
))
2652 decl
= DECL_ARGUMENTS (this_function_decl
);
2654 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2655 && sym
->ns
->proc_name
->attr
.entry_master
)
2656 decl
= DECL_CHAIN (decl
);
2658 TREE_USED (decl
) = 1;
2660 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2664 sprintf (name
, "__result_%.20s",
2665 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2667 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2668 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2669 VAR_DECL
, get_identifier (name
),
2670 gfc_sym_type (sym
));
2672 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2673 VAR_DECL
, get_identifier (name
),
2674 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2675 DECL_ARTIFICIAL (decl
) = 1;
2676 DECL_EXTERNAL (decl
) = 0;
2677 TREE_PUBLIC (decl
) = 0;
2678 TREE_USED (decl
) = 1;
2679 GFC_DECL_RESULT (decl
) = 1;
2680 TREE_ADDRESSABLE (decl
) = 1;
2682 layout_decl (decl
, 0);
2685 gfc_add_decl_to_parent_function (decl
);
2687 gfc_add_decl_to_function (decl
);
2691 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2693 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2699 /* Builds a function decl. The remaining parameters are the types of the
2700 function arguments. Negative nargs indicates a varargs function. */
2703 build_library_function_decl_1 (tree name
, const char *spec
,
2704 tree rettype
, int nargs
, va_list p
)
2706 vec
<tree
, va_gc
> *arglist
;
2711 /* Library functions must be declared with global scope. */
2712 gcc_assert (current_function_decl
== NULL_TREE
);
2714 /* Create a list of the argument types. */
2715 vec_alloc (arglist
, abs (nargs
));
2716 for (n
= abs (nargs
); n
> 0; n
--)
2718 tree argtype
= va_arg (p
, tree
);
2719 arglist
->quick_push (argtype
);
2722 /* Build the function type and decl. */
2724 fntype
= build_function_type_vec (rettype
, arglist
);
2726 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
2729 tree attr_args
= build_tree_list (NULL_TREE
,
2730 build_string (strlen (spec
), spec
));
2731 tree attrs
= tree_cons (get_identifier ("fn spec"),
2732 attr_args
, TYPE_ATTRIBUTES (fntype
));
2733 fntype
= build_type_attribute_variant (fntype
, attrs
);
2735 fndecl
= build_decl (input_location
,
2736 FUNCTION_DECL
, name
, fntype
);
2738 /* Mark this decl as external. */
2739 DECL_EXTERNAL (fndecl
) = 1;
2740 TREE_PUBLIC (fndecl
) = 1;
2744 rest_of_decl_compilation (fndecl
, 1, 0);
2749 /* Builds a function decl. The remaining parameters are the types of the
2750 function arguments. Negative nargs indicates a varargs function. */
2753 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2757 va_start (args
, nargs
);
2758 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
2763 /* Builds a function decl. The remaining parameters are the types of the
2764 function arguments. Negative nargs indicates a varargs function.
2765 The SPEC parameter specifies the function argument and return type
2766 specification according to the fnspec function type attribute. */
2769 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
2770 tree rettype
, int nargs
, ...)
2774 va_start (args
, nargs
);
2775 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
2781 gfc_build_intrinsic_function_decls (void)
2783 tree gfc_int4_type_node
= gfc_get_int_type (4);
2784 tree gfc_int8_type_node
= gfc_get_int_type (8);
2785 tree gfc_int16_type_node
= gfc_get_int_type (16);
2786 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2787 tree pchar1_type_node
= gfc_get_pchar_type (1);
2788 tree pchar4_type_node
= gfc_get_pchar_type (4);
2790 /* String functions. */
2791 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
2792 get_identifier (PREFIX("compare_string")), "..R.R",
2793 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
2794 gfc_charlen_type_node
, pchar1_type_node
);
2795 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
2796 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
2798 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
2799 get_identifier (PREFIX("concat_string")), "..W.R.R",
2800 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
2801 gfc_charlen_type_node
, pchar1_type_node
,
2802 gfc_charlen_type_node
, pchar1_type_node
);
2803 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
2805 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
2806 get_identifier (PREFIX("string_len_trim")), "..R",
2807 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
2808 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
2809 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
2811 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
2812 get_identifier (PREFIX("string_index")), "..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_index
) = 1;
2816 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
2818 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
2819 get_identifier (PREFIX("string_scan")), "..R.R.",
2820 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2821 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2822 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
2823 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
2825 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
2826 get_identifier (PREFIX("string_verify")), "..R.R.",
2827 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2828 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2829 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
2830 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
2832 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
2833 get_identifier (PREFIX("string_trim")), ".Ww.R",
2834 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2835 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
2838 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
2839 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2840 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2841 build_pointer_type (pchar1_type_node
), integer_type_node
,
2844 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
2845 get_identifier (PREFIX("adjustl")), ".W.R",
2846 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2848 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
2850 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
2851 get_identifier (PREFIX("adjustr")), ".W.R",
2852 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2854 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
2856 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
2857 get_identifier (PREFIX("select_string")), ".R.R.",
2858 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2859 pchar1_type_node
, gfc_charlen_type_node
);
2860 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
2861 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
2863 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
2864 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2865 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
2866 gfc_charlen_type_node
, pchar4_type_node
);
2867 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
2868 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
2870 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
2871 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2872 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
2873 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
2875 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
2877 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
2878 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2879 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
2880 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
2881 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
2883 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
2884 get_identifier (PREFIX("string_index_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_index_char4
) = 1;
2888 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
2890 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
2891 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2892 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2893 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2894 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
2895 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
2897 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
2898 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2899 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2900 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2901 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
2902 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
2904 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
2905 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2906 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2907 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
2910 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
2911 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2912 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2913 build_pointer_type (pchar4_type_node
), integer_type_node
,
2916 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
2917 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2918 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2920 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
2922 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
2923 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2924 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2926 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
2928 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
2929 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2930 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2931 pvoid_type_node
, gfc_charlen_type_node
);
2932 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
2933 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
2936 /* Conversion between character kinds. */
2938 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
2939 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2940 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
2941 gfc_charlen_type_node
, pchar1_type_node
);
2943 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
2944 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2945 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
2946 gfc_charlen_type_node
, pchar4_type_node
);
2948 /* Misc. functions. */
2950 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
2951 get_identifier (PREFIX("ttynam")), ".W",
2952 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2955 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
2956 get_identifier (PREFIX("fdate")), ".W",
2957 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
2959 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
2960 get_identifier (PREFIX("ctime")), ".W",
2961 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2962 gfc_int8_type_node
);
2964 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
2965 get_identifier (PREFIX("selected_char_kind")), "..R",
2966 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
2967 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
2968 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
2970 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
2971 get_identifier (PREFIX("selected_int_kind")), ".R",
2972 gfc_int4_type_node
, 1, pvoid_type_node
);
2973 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
2974 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
2976 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
2977 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2978 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
2980 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
2981 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
2983 /* Power functions. */
2985 tree ctype
, rtype
, itype
, jtype
;
2986 int rkind
, ikind
, jkind
;
2989 static int ikinds
[NIKINDS
] = {4, 8, 16};
2990 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2991 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2993 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2995 itype
= gfc_get_int_type (ikinds
[ikind
]);
2997 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2999 jtype
= gfc_get_int_type (ikinds
[jkind
]);
3002 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
3004 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
3005 gfc_build_library_function_decl (get_identifier (name
),
3006 jtype
, 2, jtype
, itype
);
3007 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3008 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
3012 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
3014 rtype
= gfc_get_real_type (rkinds
[rkind
]);
3017 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
3019 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
3020 gfc_build_library_function_decl (get_identifier (name
),
3021 rtype
, 2, rtype
, itype
);
3022 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3023 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
3026 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
3029 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
3031 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
3032 gfc_build_library_function_decl (get_identifier (name
),
3033 ctype
, 2,ctype
, itype
);
3034 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3035 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
3043 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
3044 get_identifier (PREFIX("ishftc4")),
3045 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
3046 gfc_int4_type_node
);
3047 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
3048 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
3050 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
3051 get_identifier (PREFIX("ishftc8")),
3052 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
3053 gfc_int4_type_node
);
3054 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
3055 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
3057 if (gfc_int16_type_node
)
3059 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
3060 get_identifier (PREFIX("ishftc16")),
3061 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3062 gfc_int4_type_node
);
3063 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3064 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3067 /* BLAS functions. */
3069 tree pint
= build_pointer_type (integer_type_node
);
3070 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3071 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3072 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3073 tree pz
= build_pointer_type
3074 (gfc_get_complex_type (gfc_default_double_kind
));
3076 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3078 (gfc_option
.flag_underscoring
? "sgemm_"
3080 void_type_node
, 15, pchar_type_node
,
3081 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3082 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3084 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3086 (gfc_option
.flag_underscoring
? "dgemm_"
3088 void_type_node
, 15, pchar_type_node
,
3089 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3090 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3092 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3094 (gfc_option
.flag_underscoring
? "cgemm_"
3096 void_type_node
, 15, pchar_type_node
,
3097 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3098 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3100 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3102 (gfc_option
.flag_underscoring
? "zgemm_"
3104 void_type_node
, 15, pchar_type_node
,
3105 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3106 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3110 /* Other functions. */
3111 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3112 get_identifier (PREFIX("size0")), ".R",
3113 gfc_array_index_type
, 1, pvoid_type_node
);
3114 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3115 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3117 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3118 get_identifier (PREFIX("size1")), ".R",
3119 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3120 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3121 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3123 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3124 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3125 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3129 /* Make prototypes for runtime library functions. */
3132 gfc_build_builtin_function_decls (void)
3134 tree gfc_int4_type_node
= gfc_get_int_type (4);
3136 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3137 get_identifier (PREFIX("stop_numeric")),
3138 void_type_node
, 1, gfc_int4_type_node
);
3139 /* STOP doesn't return. */
3140 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3142 gfor_fndecl_stop_numeric_f08
= gfc_build_library_function_decl (
3143 get_identifier (PREFIX("stop_numeric_f08")),
3144 void_type_node
, 1, gfc_int4_type_node
);
3145 /* STOP doesn't return. */
3146 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08
) = 1;
3148 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3149 get_identifier (PREFIX("stop_string")), ".R.",
3150 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3151 /* STOP doesn't return. */
3152 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3154 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3155 get_identifier (PREFIX("error_stop_numeric")),
3156 void_type_node
, 1, gfc_int4_type_node
);
3157 /* ERROR STOP doesn't return. */
3158 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3160 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3161 get_identifier (PREFIX("error_stop_string")), ".R.",
3162 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3163 /* ERROR STOP doesn't return. */
3164 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3166 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3167 get_identifier (PREFIX("pause_numeric")),
3168 void_type_node
, 1, gfc_int4_type_node
);
3170 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3171 get_identifier (PREFIX("pause_string")), ".R.",
3172 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3174 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3175 get_identifier (PREFIX("runtime_error")), ".R",
3176 void_type_node
, -1, pchar_type_node
);
3177 /* The runtime_error function does not return. */
3178 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3180 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3181 get_identifier (PREFIX("runtime_error_at")), ".RR",
3182 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3183 /* The runtime_error_at function does not return. */
3184 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3186 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3187 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3188 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3190 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3191 get_identifier (PREFIX("generate_error")), ".R.R",
3192 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3195 gfor_fndecl_os_error
= gfc_build_library_function_decl_with_spec (
3196 get_identifier (PREFIX("os_error")), ".R",
3197 void_type_node
, 1, pchar_type_node
);
3198 /* The runtime_error function does not return. */
3199 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
3201 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3202 get_identifier (PREFIX("set_args")),
3203 void_type_node
, 2, integer_type_node
,
3204 build_pointer_type (pchar_type_node
));
3206 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3207 get_identifier (PREFIX("set_fpe")),
3208 void_type_node
, 1, integer_type_node
);
3210 /* Keep the array dimension in sync with the call, later in this file. */
3211 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3212 get_identifier (PREFIX("set_options")), "..R",
3213 void_type_node
, 2, integer_type_node
,
3214 build_pointer_type (integer_type_node
));
3216 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3217 get_identifier (PREFIX("set_convert")),
3218 void_type_node
, 1, integer_type_node
);
3220 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3221 get_identifier (PREFIX("set_record_marker")),
3222 void_type_node
, 1, integer_type_node
);
3224 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3225 get_identifier (PREFIX("set_max_subrecord_length")),
3226 void_type_node
, 1, integer_type_node
);
3228 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3229 get_identifier (PREFIX("internal_pack")), ".r",
3230 pvoid_type_node
, 1, pvoid_type_node
);
3232 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3233 get_identifier (PREFIX("internal_unpack")), ".wR",
3234 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3236 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3237 get_identifier (PREFIX("associated")), ".RR",
3238 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3239 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3240 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3242 /* Coarray library calls. */
3243 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
3245 tree pint_type
, pppchar_type
;
3247 pint_type
= build_pointer_type (integer_type_node
);
3249 = build_pointer_type (build_pointer_type (pchar_type_node
));
3251 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3252 get_identifier (PREFIX("caf_init")), void_type_node
,
3253 4, pint_type
, pppchar_type
, pint_type
, pint_type
);
3255 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3256 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3258 gfor_fndecl_caf_this_image
= gfc_build_library_function_decl (
3259 get_identifier (PREFIX("caf_this_image")), integer_type_node
,
3260 1, integer_type_node
);
3262 gfor_fndecl_caf_num_images
= gfc_build_library_function_decl (
3263 get_identifier (PREFIX("caf_num_images")), integer_type_node
,
3264 2, integer_type_node
, boolean_type_node
);
3266 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3267 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node
, 6,
3268 size_type_node
, integer_type_node
, ppvoid_type_node
, pint_type
,
3269 pchar_type_node
, integer_type_node
);
3271 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3272 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node
, 4,
3273 ppvoid_type_node
, pint_type
, pchar_type_node
, integer_type_node
);
3275 gfor_fndecl_caf_critical
= gfc_build_library_function_decl (
3276 get_identifier (PREFIX("caf_critical")), void_type_node
, 0);
3278 gfor_fndecl_caf_end_critical
= gfc_build_library_function_decl (
3279 get_identifier (PREFIX("caf_end_critical")), void_type_node
, 0);
3281 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3282 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3283 3, pint_type
, build_pointer_type (pchar_type_node
), integer_type_node
);
3285 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3286 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3287 5, integer_type_node
, pint_type
, pint_type
,
3288 build_pointer_type (pchar_type_node
), integer_type_node
);
3290 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3291 get_identifier (PREFIX("caf_error_stop")),
3292 void_type_node
, 1, gfc_int4_type_node
);
3293 /* CAF's ERROR STOP doesn't return. */
3294 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3296 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3297 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3298 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3299 /* CAF's ERROR STOP doesn't return. */
3300 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3303 gfc_build_intrinsic_function_decls ();
3304 gfc_build_intrinsic_lib_fndecls ();
3305 gfc_build_io_library_fndecls ();
3309 /* Evaluate the length of dummy character variables. */
3312 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
3313 gfc_wrapped_block
*block
)
3317 gfc_finish_decl (cl
->backend_decl
);
3319 gfc_start_block (&init
);
3321 /* Evaluate the string length expression. */
3322 gfc_conv_string_length (cl
, NULL
, &init
);
3324 gfc_trans_vla_type_sizes (sym
, &init
);
3326 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3330 /* Allocate and cleanup an automatic character variable. */
3333 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3339 gcc_assert (sym
->backend_decl
);
3340 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
3342 gfc_init_block (&init
);
3344 /* Evaluate the string length expression. */
3345 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
3347 gfc_trans_vla_type_sizes (sym
, &init
);
3349 decl
= sym
->backend_decl
;
3351 /* Emit a DECL_EXPR for this variable, which will cause the
3352 gimplifier to allocate storage, and all that good stuff. */
3353 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
3354 gfc_add_expr_to_block (&init
, tmp
);
3356 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3359 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3362 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3366 gcc_assert (sym
->backend_decl
);
3367 gfc_start_block (&init
);
3369 /* Set the initial value to length. See the comments in
3370 function gfc_add_assign_aux_vars in this file. */
3371 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
3372 build_int_cst (gfc_charlen_type_node
, -2));
3374 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3378 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
3380 tree t
= *tp
, var
, val
;
3382 if (t
== NULL
|| t
== error_mark_node
)
3384 if (TREE_CONSTANT (t
) || DECL_P (t
))
3387 if (TREE_CODE (t
) == SAVE_EXPR
)
3389 if (SAVE_EXPR_RESOLVED_P (t
))
3391 *tp
= TREE_OPERAND (t
, 0);
3394 val
= TREE_OPERAND (t
, 0);
3399 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
3400 gfc_add_decl_to_function (var
);
3401 gfc_add_modify (body
, var
, val
);
3402 if (TREE_CODE (t
) == SAVE_EXPR
)
3403 TREE_OPERAND (t
, 0) = var
;
3408 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
3412 if (type
== NULL
|| type
== error_mark_node
)
3415 type
= TYPE_MAIN_VARIANT (type
);
3417 if (TREE_CODE (type
) == INTEGER_TYPE
)
3419 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
3420 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
3422 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3424 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
3425 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
3428 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3430 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
3431 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
3432 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
3433 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
3435 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3437 TYPE_SIZE (t
) = TYPE_SIZE (type
);
3438 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
3443 /* Make sure all type sizes and array domains are either constant,
3444 or variable or parameter decls. This is a simplified variant
3445 of gimplify_type_sizes, but we can't use it here, as none of the
3446 variables in the expressions have been gimplified yet.
3447 As type sizes and domains for various variable length arrays
3448 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3449 time, without this routine gimplify_type_sizes in the middle-end
3450 could result in the type sizes being gimplified earlier than where
3451 those variables are initialized. */
3454 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
3456 tree type
= TREE_TYPE (sym
->backend_decl
);
3458 if (TREE_CODE (type
) == FUNCTION_TYPE
3459 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
3461 if (! current_fake_result_decl
)
3464 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
3467 while (POINTER_TYPE_P (type
))
3468 type
= TREE_TYPE (type
);
3470 if (GFC_DESCRIPTOR_TYPE_P (type
))
3472 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3474 while (POINTER_TYPE_P (etype
))
3475 etype
= TREE_TYPE (etype
);
3477 gfc_trans_vla_type_sizes_1 (etype
, body
);
3480 gfc_trans_vla_type_sizes_1 (type
, body
);
3484 /* Initialize a derived type by building an lvalue from the symbol
3485 and using trans_assignment to do the work. Set dealloc to false
3486 if no deallocation prior the assignment is needed. */
3488 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
3496 gcc_assert (!sym
->attr
.allocatable
);
3497 gfc_set_sym_referenced (sym
);
3498 e
= gfc_lval_expr_from_sym (sym
);
3499 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3500 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3501 || sym
->ns
->proc_name
->attr
.entry_master
))
3503 present
= gfc_conv_expr_present (sym
);
3504 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
3505 tmp
, build_empty_stmt (input_location
));
3507 gfc_add_expr_to_block (block
, tmp
);
3512 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3513 them their default initializer, if they do not have allocatable
3514 components, they have their allocatable components deallocated. */
3517 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3520 gfc_formal_arglist
*f
;
3524 gfc_init_block (&init
);
3525 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
3526 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3527 && !f
->sym
->attr
.pointer
3528 && f
->sym
->ts
.type
== BT_DERIVED
)
3532 /* Note: Allocatables are excluded as they are already handled
3534 if (!f
->sym
->attr
.allocatable
3535 && gfc_is_finalizable (f
->sym
->ts
.u
.derived
, NULL
))
3540 gfc_init_block (&block
);
3541 f
->sym
->attr
.referenced
= 1;
3542 e
= gfc_lval_expr_from_sym (f
->sym
);
3543 gfc_add_finalizer_call (&block
, e
);
3545 tmp
= gfc_finish_block (&block
);
3548 if (tmp
== NULL_TREE
&& !f
->sym
->attr
.allocatable
3549 && f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3550 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3551 f
->sym
->backend_decl
,
3552 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3554 if (tmp
!= NULL_TREE
&& (f
->sym
->attr
.optional
3555 || f
->sym
->ns
->proc_name
->attr
.entry_master
))
3557 present
= gfc_conv_expr_present (f
->sym
);
3558 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3559 present
, tmp
, build_empty_stmt (input_location
));
3562 if (tmp
!= NULL_TREE
)
3563 gfc_add_expr_to_block (&init
, tmp
);
3564 else if (f
->sym
->value
&& !f
->sym
->attr
.allocatable
)
3565 gfc_init_default_dt (f
->sym
, &init
, true);
3567 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3568 && f
->sym
->ts
.type
== BT_CLASS
3569 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3570 && !CLASS_DATA (f
->sym
)->attr
.allocatable
)
3575 gfc_init_block (&block
);
3576 f
->sym
->attr
.referenced
= 1;
3577 e
= gfc_lval_expr_from_sym (f
->sym
);
3578 gfc_add_finalizer_call (&block
, e
);
3580 tmp
= gfc_finish_block (&block
);
3582 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
3584 present
= gfc_conv_expr_present (f
->sym
);
3585 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3587 build_empty_stmt (input_location
));
3590 gfc_add_expr_to_block (&init
, tmp
);
3593 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3597 /* Generate function entry and exit code, and add it to the function body.
3599 Allocation and initialization of array variables.
3600 Allocation of character string variables.
3601 Initialization and possibly repacking of dummy arrays.
3602 Initialization of ASSIGN statement auxiliary variable.
3603 Initialization of ASSOCIATE names.
3604 Automatic deallocation. */
3607 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3611 gfc_formal_arglist
*f
;
3612 stmtblock_t tmpblock
;
3613 bool seen_trans_deferred_array
= false;
3619 /* Deal with implicit return variables. Explicit return variables will
3620 already have been added. */
3621 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
3623 if (!current_fake_result_decl
)
3625 gfc_entry_list
*el
= NULL
;
3626 if (proc_sym
->attr
.entry_master
)
3628 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
3629 if (el
->sym
!= el
->sym
->result
)
3632 /* TODO: move to the appropriate place in resolve.c. */
3633 if (warn_return_type
&& el
== NULL
)
3634 gfc_warning ("Return value of function '%s' at %L not set",
3635 proc_sym
->name
, &proc_sym
->declared_at
);
3637 else if (proc_sym
->as
)
3639 tree result
= TREE_VALUE (current_fake_result_decl
);
3640 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
3642 /* An automatic character length, pointer array result. */
3643 if (proc_sym
->ts
.type
== BT_CHARACTER
3644 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3645 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3647 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
3649 if (proc_sym
->ts
.deferred
)
3652 gfc_save_backend_locus (&loc
);
3653 gfc_set_backend_locus (&proc_sym
->declared_at
);
3654 gfc_start_block (&init
);
3655 /* Zero the string length on entry. */
3656 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
3657 build_int_cst (gfc_charlen_type_node
, 0));
3658 /* Null the pointer. */
3659 e
= gfc_lval_expr_from_sym (proc_sym
);
3660 gfc_init_se (&se
, NULL
);
3661 se
.want_pointer
= 1;
3662 gfc_conv_expr (&se
, e
);
3665 gfc_add_modify (&init
, tmp
,
3666 fold_convert (TREE_TYPE (se
.expr
),
3667 null_pointer_node
));
3668 gfc_restore_backend_locus (&loc
);
3670 /* Pass back the string length on exit. */
3671 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
3672 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3673 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3674 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3675 gfc_charlen_type_node
, tmp
,
3676 proc_sym
->ts
.u
.cl
->backend_decl
);
3677 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3679 else if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3680 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3683 gcc_assert (gfc_option
.flag_f2c
3684 && proc_sym
->ts
.type
== BT_COMPLEX
);
3687 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3688 should be done here so that the offsets and lbounds of arrays
3690 gfc_save_backend_locus (&loc
);
3691 gfc_set_backend_locus (&proc_sym
->declared_at
);
3692 init_intent_out_dt (proc_sym
, block
);
3693 gfc_restore_backend_locus (&loc
);
3695 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
3697 bool alloc_comp_or_fini
= (sym
->ts
.type
== BT_DERIVED
)
3698 && (sym
->ts
.u
.derived
->attr
.alloc_comp
3699 || gfc_is_finalizable (sym
->ts
.u
.derived
,
3704 if (sym
->attr
.subref_array_pointer
3705 && GFC_DECL_SPAN (sym
->backend_decl
)
3706 && !TREE_STATIC (GFC_DECL_SPAN (sym
->backend_decl
)))
3708 gfc_init_block (&tmpblock
);
3709 gfc_add_modify (&tmpblock
, GFC_DECL_SPAN (sym
->backend_decl
),
3710 build_int_cst (gfc_array_index_type
, 0));
3711 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3715 if (sym
->ts
.type
== BT_CLASS
3716 && (sym
->attr
.save
|| gfc_option
.flag_max_stack_var_size
== 0)
3717 && CLASS_DATA (sym
)->attr
.allocatable
)
3721 if (UNLIMITED_POLY (sym
))
3722 vptr
= null_pointer_node
;
3726 vsym
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3727 vptr
= gfc_get_symbol_decl (vsym
);
3728 vptr
= gfc_build_addr_expr (NULL
, vptr
);
3731 if (CLASS_DATA (sym
)->attr
.dimension
3732 || (CLASS_DATA (sym
)->attr
.codimension
3733 && gfc_option
.coarray
!= GFC_FCOARRAY_LIB
))
3735 tmp
= gfc_class_data_get (sym
->backend_decl
);
3736 tmp
= gfc_build_null_descriptor (TREE_TYPE (tmp
));
3739 tmp
= null_pointer_node
;
3741 DECL_INITIAL (sym
->backend_decl
)
3742 = gfc_class_set_static_fields (sym
->backend_decl
, vptr
, tmp
);
3743 TREE_CONSTANT (DECL_INITIAL (sym
->backend_decl
)) = 1;
3745 else if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3747 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3748 array_type tmp
= sym
->as
->type
;
3749 if (tmp
== AS_ASSUMED_SIZE
&& sym
->as
->cp_was_assumed
)
3754 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3755 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3756 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3758 if (TREE_STATIC (sym
->backend_decl
))
3760 gfc_save_backend_locus (&loc
);
3761 gfc_set_backend_locus (&sym
->declared_at
);
3762 gfc_trans_static_array_pointer (sym
);
3763 gfc_restore_backend_locus (&loc
);
3767 seen_trans_deferred_array
= true;
3768 gfc_trans_deferred_array (sym
, block
);
3771 else if (sym
->attr
.codimension
&& TREE_STATIC (sym
->backend_decl
))
3773 gfc_init_block (&tmpblock
);
3774 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
3776 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3780 else if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
3782 gfc_save_backend_locus (&loc
);
3783 gfc_set_backend_locus (&sym
->declared_at
);
3785 if (alloc_comp_or_fini
)
3787 seen_trans_deferred_array
= true;
3788 gfc_trans_deferred_array (sym
, block
);
3790 else if (sym
->ts
.type
== BT_DERIVED
3793 && sym
->attr
.save
== SAVE_NONE
)
3795 gfc_start_block (&tmpblock
);
3796 gfc_init_default_dt (sym
, &tmpblock
, false);
3797 gfc_add_init_cleanup (block
,
3798 gfc_finish_block (&tmpblock
),
3802 gfc_trans_auto_array_allocation (sym
->backend_decl
,
3804 gfc_restore_backend_locus (&loc
);
3808 case AS_ASSUMED_SIZE
:
3809 /* Must be a dummy parameter. */
3810 gcc_assert (sym
->attr
.dummy
|| sym
->as
->cp_was_assumed
);
3812 /* We should always pass assumed size arrays the g77 way. */
3813 if (sym
->attr
.dummy
)
3814 gfc_trans_g77_array (sym
, block
);
3817 case AS_ASSUMED_SHAPE
:
3818 /* Must be a dummy parameter. */
3819 gcc_assert (sym
->attr
.dummy
);
3821 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3824 case AS_ASSUMED_RANK
:
3826 seen_trans_deferred_array
= true;
3827 gfc_trans_deferred_array (sym
, block
);
3833 if (alloc_comp_or_fini
&& !seen_trans_deferred_array
)
3834 gfc_trans_deferred_array (sym
, block
);
3836 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3837 && (sym
->ts
.type
== BT_CLASS
3838 && CLASS_DATA (sym
)->attr
.class_pointer
))
3840 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3841 && (sym
->attr
.allocatable
3842 || (sym
->ts
.type
== BT_CLASS
3843 && CLASS_DATA (sym
)->attr
.allocatable
)))
3845 if (!sym
->attr
.save
&& gfc_option
.flag_max_stack_var_size
!= 0)
3847 tree descriptor
= NULL_TREE
;
3849 /* Nullify and automatic deallocation of allocatable
3851 e
= gfc_lval_expr_from_sym (sym
);
3852 if (sym
->ts
.type
== BT_CLASS
)
3853 gfc_add_data_component (e
);
3855 gfc_init_se (&se
, NULL
);
3856 if (sym
->ts
.type
!= BT_CLASS
3857 || sym
->ts
.u
.derived
->attr
.dimension
3858 || sym
->ts
.u
.derived
->attr
.codimension
)
3860 se
.want_pointer
= 1;
3861 gfc_conv_expr (&se
, e
);
3863 else if (sym
->ts
.type
== BT_CLASS
3864 && !CLASS_DATA (sym
)->attr
.dimension
3865 && !CLASS_DATA (sym
)->attr
.codimension
)
3867 se
.want_pointer
= 1;
3868 gfc_conv_expr (&se
, e
);
3872 gfc_conv_expr (&se
, e
);
3873 descriptor
= se
.expr
;
3874 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
3875 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
3879 gfc_save_backend_locus (&loc
);
3880 gfc_set_backend_locus (&sym
->declared_at
);
3881 gfc_start_block (&init
);
3883 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3885 /* Nullify when entering the scope. */
3886 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3887 TREE_TYPE (se
.expr
), se
.expr
,
3888 fold_convert (TREE_TYPE (se
.expr
),
3889 null_pointer_node
));
3890 if (sym
->attr
.optional
)
3892 tree present
= gfc_conv_expr_present (sym
);
3893 tmp
= build3_loc (input_location
, COND_EXPR
,
3894 void_type_node
, present
, tmp
,
3895 build_empty_stmt (input_location
));
3897 gfc_add_expr_to_block (&init
, tmp
);
3900 if ((sym
->attr
.dummy
|| sym
->attr
.result
)
3901 && sym
->ts
.type
== BT_CHARACTER
3902 && sym
->ts
.deferred
)
3904 /* Character length passed by reference. */
3905 tmp
= sym
->ts
.u
.cl
->passed_length
;
3906 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3907 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3909 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3910 /* Zero the string length when entering the scope. */
3911 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
,
3912 build_int_cst (gfc_charlen_type_node
, 0));
3917 tmp2
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3918 gfc_charlen_type_node
,
3919 sym
->ts
.u
.cl
->backend_decl
, tmp
);
3920 if (sym
->attr
.optional
)
3922 tree present
= gfc_conv_expr_present (sym
);
3923 tmp2
= build3_loc (input_location
, COND_EXPR
,
3924 void_type_node
, present
, tmp2
,
3925 build_empty_stmt (input_location
));
3927 gfc_add_expr_to_block (&init
, tmp2
);
3930 gfc_restore_backend_locus (&loc
);
3932 /* Pass the final character length back. */
3933 if (sym
->attr
.intent
!= INTENT_IN
)
3935 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3936 gfc_charlen_type_node
, tmp
,
3937 sym
->ts
.u
.cl
->backend_decl
);
3938 if (sym
->attr
.optional
)
3940 tree present
= gfc_conv_expr_present (sym
);
3941 tmp
= build3_loc (input_location
, COND_EXPR
,
3942 void_type_node
, present
, tmp
,
3943 build_empty_stmt (input_location
));
3950 gfc_restore_backend_locus (&loc
);
3952 /* Deallocate when leaving the scope. Nullifying is not
3954 if (!sym
->attr
.result
&& !sym
->attr
.dummy
3955 && !sym
->ns
->proc_name
->attr
.is_main_program
)
3957 if (sym
->ts
.type
== BT_CLASS
3958 && CLASS_DATA (sym
)->attr
.codimension
)
3959 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
3960 NULL_TREE
, NULL_TREE
,
3961 NULL_TREE
, true, NULL
,
3965 gfc_expr
*expr
= gfc_lval_expr_from_sym (sym
);
3966 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, NULL_TREE
,
3967 true, expr
, sym
->ts
);
3968 gfc_free_expr (expr
);
3971 if (sym
->ts
.type
== BT_CLASS
)
3973 /* Initialize _vptr to declared type. */
3977 gfc_save_backend_locus (&loc
);
3978 gfc_set_backend_locus (&sym
->declared_at
);
3979 e
= gfc_lval_expr_from_sym (sym
);
3980 gfc_add_vptr_component (e
);
3981 gfc_init_se (&se
, NULL
);
3982 se
.want_pointer
= 1;
3983 gfc_conv_expr (&se
, e
);
3985 if (UNLIMITED_POLY (sym
))
3986 rhs
= build_int_cst (TREE_TYPE (se
.expr
), 0);
3989 vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3990 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
3991 gfc_get_symbol_decl (vtab
));
3993 gfc_add_modify (&init
, se
.expr
, rhs
);
3994 gfc_restore_backend_locus (&loc
);
3997 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4000 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
4005 /* If we get to here, all that should be left are pointers. */
4006 gcc_assert (sym
->attr
.pointer
);
4008 if (sym
->attr
.dummy
)
4010 gfc_start_block (&init
);
4012 /* Character length passed by reference. */
4013 tmp
= sym
->ts
.u
.cl
->passed_length
;
4014 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4015 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
4016 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
4017 /* Pass the final character length back. */
4018 if (sym
->attr
.intent
!= INTENT_IN
)
4019 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
4020 gfc_charlen_type_node
, tmp
,
4021 sym
->ts
.u
.cl
->backend_decl
);
4024 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
4027 else if (sym
->ts
.deferred
)
4028 gfc_fatal_error ("Deferred type parameter not yet supported");
4029 else if (alloc_comp_or_fini
)
4030 gfc_trans_deferred_array (sym
, block
);
4031 else if (sym
->ts
.type
== BT_CHARACTER
)
4033 gfc_save_backend_locus (&loc
);
4034 gfc_set_backend_locus (&sym
->declared_at
);
4035 if (sym
->attr
.dummy
|| sym
->attr
.result
)
4036 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
4038 gfc_trans_auto_character_variable (sym
, block
);
4039 gfc_restore_backend_locus (&loc
);
4041 else if (sym
->attr
.assign
)
4043 gfc_save_backend_locus (&loc
);
4044 gfc_set_backend_locus (&sym
->declared_at
);
4045 gfc_trans_assign_aux_var (sym
, block
);
4046 gfc_restore_backend_locus (&loc
);
4048 else if (sym
->ts
.type
== BT_DERIVED
4051 && sym
->attr
.save
== SAVE_NONE
)
4053 gfc_start_block (&tmpblock
);
4054 gfc_init_default_dt (sym
, &tmpblock
, false);
4055 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
4058 else if (!(UNLIMITED_POLY(sym
)))
4062 gfc_init_block (&tmpblock
);
4064 for (f
= gfc_sym_get_dummy_args (proc_sym
); f
; f
= f
->next
)
4066 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
4068 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4069 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4070 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
4074 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
4075 && current_fake_result_decl
!= NULL
)
4077 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
4078 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
4079 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
4082 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
4085 static GTY ((param_is (struct module_htab_entry
))) htab_t module_htab
;
4087 /* Hash and equality functions for module_htab. */
4090 module_htab_do_hash (const void *x
)
4092 return htab_hash_string (((const struct module_htab_entry
*)x
)->name
);
4096 module_htab_eq (const void *x1
, const void *x2
)
4098 return strcmp ((((const struct module_htab_entry
*)x1
)->name
),
4099 (const char *)x2
) == 0;
4102 /* Hash and equality functions for module_htab's decls. */
4105 module_htab_decls_hash (const void *x
)
4107 const_tree t
= (const_tree
) x
;
4108 const_tree n
= DECL_NAME (t
);
4110 n
= TYPE_NAME (TREE_TYPE (t
));
4111 return htab_hash_string (IDENTIFIER_POINTER (n
));
4115 module_htab_decls_eq (const void *x1
, const void *x2
)
4117 const_tree t1
= (const_tree
) x1
;
4118 const_tree n1
= DECL_NAME (t1
);
4119 if (n1
== NULL_TREE
)
4120 n1
= TYPE_NAME (TREE_TYPE (t1
));
4121 return strcmp (IDENTIFIER_POINTER (n1
), (const char *) x2
) == 0;
4124 struct module_htab_entry
*
4125 gfc_find_module (const char *name
)
4130 module_htab
= htab_create_ggc (10, module_htab_do_hash
,
4131 module_htab_eq
, NULL
);
4133 slot
= htab_find_slot_with_hash (module_htab
, name
,
4134 htab_hash_string (name
), INSERT
);
4137 struct module_htab_entry
*entry
= ggc_alloc_cleared_module_htab_entry ();
4139 entry
->name
= gfc_get_string (name
);
4140 entry
->decls
= htab_create_ggc (10, module_htab_decls_hash
,
4141 module_htab_decls_eq
, NULL
);
4142 *slot
= (void *) entry
;
4144 return (struct module_htab_entry
*) *slot
;
4148 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
4153 if (DECL_NAME (decl
))
4154 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
4157 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
4158 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
4160 slot
= htab_find_slot_with_hash (entry
->decls
, name
,
4161 htab_hash_string (name
), INSERT
);
4163 *slot
= (void *) decl
;
4166 static struct module_htab_entry
*cur_module
;
4169 /* Generate debugging symbols for namelists. This function must come after
4170 generate_local_decl to ensure that the variables in the namelist are
4171 already declared. */
4174 generate_namelist_decl (gfc_symbol
* sym
)
4178 vec
<constructor_elt
, va_gc
> *nml_decls
= NULL
;
4180 gcc_assert (sym
->attr
.flavor
== FL_NAMELIST
);
4181 for (nml
= sym
->namelist
; nml
; nml
= nml
->next
)
4183 if (nml
->sym
->backend_decl
== NULL_TREE
)
4185 nml
->sym
->attr
.referenced
= 1;
4186 nml
->sym
->backend_decl
= gfc_get_symbol_decl (nml
->sym
);
4188 DECL_IGNORED_P (nml
->sym
->backend_decl
) = 0;
4189 CONSTRUCTOR_APPEND_ELT (nml_decls
, NULL_TREE
, nml
->sym
->backend_decl
);
4192 decl
= make_node (NAMELIST_DECL
);
4193 TREE_TYPE (decl
) = void_type_node
;
4194 NAMELIST_DECL_ASSOCIATED_DECL (decl
) = build_constructor (NULL_TREE
, nml_decls
);
4195 DECL_NAME (decl
) = get_identifier (sym
->name
);
4200 /* Output an initialized decl for a module variable. */
4203 gfc_create_module_variable (gfc_symbol
* sym
)
4207 /* Module functions with alternate entries are dealt with later and
4208 would get caught by the next condition. */
4209 if (sym
->attr
.entry
)
4212 /* Make sure we convert the types of the derived types from iso_c_binding
4214 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4215 && sym
->ts
.type
== BT_DERIVED
)
4216 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4218 if (sym
->attr
.flavor
== FL_DERIVED
4219 && sym
->backend_decl
4220 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
4222 decl
= sym
->backend_decl
;
4223 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4225 if (!sym
->attr
.use_assoc
)
4227 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
4228 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
4229 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
4230 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
4231 == sym
->ns
->proc_name
->backend_decl
);
4233 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4234 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
4235 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
4238 /* Only output variables, procedure pointers and array valued,
4239 or derived type, parameters. */
4240 if (sym
->attr
.flavor
!= FL_VARIABLE
4241 && !(sym
->attr
.flavor
== FL_PARAMETER
4242 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
4243 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4246 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
4248 decl
= sym
->backend_decl
;
4249 gcc_assert (DECL_FILE_SCOPE_P (decl
));
4250 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4251 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4252 gfc_module_add_decl (cur_module
, decl
);
4255 /* Don't generate variables from other modules. Variables from
4256 COMMONs will already have been generated. */
4257 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4260 /* Equivalenced variables arrive here after creation. */
4261 if (sym
->backend_decl
4262 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
4265 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
4266 internal_error ("backend decl for module variable %s already exists",
4269 if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
4270 && (sym
->attr
.access
== ACCESS_UNKNOWN
4271 && (sym
->ns
->default_access
== ACCESS_PRIVATE
4272 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
4273 && gfc_option
.flag_module_private
))))
4274 sym
->attr
.access
= ACCESS_PRIVATE
;
4276 if (warn_unused_variable
&& !sym
->attr
.referenced
4277 && sym
->attr
.access
== ACCESS_PRIVATE
)
4278 gfc_warning ("Unused PRIVATE module variable '%s' declared at %L",
4279 sym
->name
, &sym
->declared_at
);
4281 /* We always want module variables to be created. */
4282 sym
->attr
.referenced
= 1;
4283 /* Create the decl. */
4284 decl
= gfc_get_symbol_decl (sym
);
4286 /* Create the variable. */
4288 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4289 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4290 rest_of_decl_compilation (decl
, 1, 0);
4291 gfc_module_add_decl (cur_module
, decl
);
4293 /* Also add length of strings. */
4294 if (sym
->ts
.type
== BT_CHARACTER
)
4298 length
= sym
->ts
.u
.cl
->backend_decl
;
4299 gcc_assert (length
|| sym
->attr
.proc_pointer
);
4300 if (length
&& !INTEGER_CST_P (length
))
4303 rest_of_decl_compilation (length
, 1, 0);
4307 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4308 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4309 has_coarray_vars
= true;
4312 /* Emit debug information for USE statements. */
4315 gfc_trans_use_stmts (gfc_namespace
* ns
)
4317 gfc_use_list
*use_stmt
;
4318 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
4320 struct module_htab_entry
*entry
4321 = gfc_find_module (use_stmt
->module_name
);
4322 gfc_use_rename
*rent
;
4324 if (entry
->namespace_decl
== NULL
)
4326 entry
->namespace_decl
4327 = build_decl (input_location
,
4329 get_identifier (use_stmt
->module_name
),
4331 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
4333 gfc_set_backend_locus (&use_stmt
->where
);
4334 if (!use_stmt
->only_flag
)
4335 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
4337 ns
->proc_name
->backend_decl
,
4339 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
4341 tree decl
, local_name
;
4344 if (rent
->op
!= INTRINSIC_NONE
)
4347 slot
= htab_find_slot_with_hash (entry
->decls
, rent
->use_name
,
4348 htab_hash_string (rent
->use_name
),
4354 st
= gfc_find_symtree (ns
->sym_root
,
4356 ? rent
->local_name
: rent
->use_name
);
4358 /* The following can happen if a derived type is renamed. */
4362 name
= xstrdup (rent
->local_name
[0]
4363 ? rent
->local_name
: rent
->use_name
);
4364 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
4365 st
= gfc_find_symtree (ns
->sym_root
, name
);
4370 /* Sometimes, generic interfaces wind up being over-ruled by a
4371 local symbol (see PR41062). */
4372 if (!st
->n
.sym
->attr
.use_assoc
)
4375 if (st
->n
.sym
->backend_decl
4376 && DECL_P (st
->n
.sym
->backend_decl
)
4377 && st
->n
.sym
->module
4378 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
4380 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
4381 || (TREE_CODE (st
->n
.sym
->backend_decl
)
4383 decl
= copy_node (st
->n
.sym
->backend_decl
);
4384 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4385 DECL_EXTERNAL (decl
) = 1;
4386 DECL_IGNORED_P (decl
) = 0;
4387 DECL_INITIAL (decl
) = NULL_TREE
;
4389 else if (st
->n
.sym
->attr
.flavor
== FL_NAMELIST
4390 && st
->n
.sym
->attr
.use_only
4391 && st
->n
.sym
->module
4392 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
)
4395 decl
= generate_namelist_decl (st
->n
.sym
);
4396 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4397 DECL_EXTERNAL (decl
) = 1;
4398 DECL_IGNORED_P (decl
) = 0;
4399 DECL_INITIAL (decl
) = NULL_TREE
;
4403 *slot
= error_mark_node
;
4404 htab_clear_slot (entry
->decls
, slot
);
4409 decl
= (tree
) *slot
;
4410 if (rent
->local_name
[0])
4411 local_name
= get_identifier (rent
->local_name
);
4413 local_name
= NULL_TREE
;
4414 gfc_set_backend_locus (&rent
->where
);
4415 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
4416 ns
->proc_name
->backend_decl
,
4417 !use_stmt
->only_flag
);
4423 /* Return true if expr is a constant initializer that gfc_conv_initializer
4427 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
4437 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
4439 else if (expr
->expr_type
== EXPR_STRUCTURE
)
4440 return check_constant_initializer (expr
, ts
, false, false);
4441 else if (expr
->expr_type
!= EXPR_ARRAY
)
4443 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4444 c
; c
= gfc_constructor_next (c
))
4448 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
4450 if (!check_constant_initializer (c
->expr
, ts
, false, false))
4453 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4458 else switch (ts
->type
)
4461 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4463 cm
= expr
->ts
.u
.derived
->components
;
4464 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4465 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4467 if (!c
->expr
|| cm
->attr
.allocatable
)
4469 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
4476 return expr
->expr_type
== EXPR_CONSTANT
;
4480 /* Emit debug info for parameters and unreferenced variables with
4484 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
4488 if (sym
->attr
.flavor
!= FL_PARAMETER
4489 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
4492 if (sym
->backend_decl
!= NULL
4493 || sym
->value
== NULL
4494 || sym
->attr
.use_assoc
4497 || sym
->attr
.function
4498 || sym
->attr
.intrinsic
4499 || sym
->attr
.pointer
4500 || sym
->attr
.allocatable
4501 || sym
->attr
.cray_pointee
4502 || sym
->attr
.threadprivate
4503 || sym
->attr
.is_bind_c
4504 || sym
->attr
.subref_array_pointer
4505 || sym
->attr
.assign
)
4508 if (sym
->ts
.type
== BT_CHARACTER
)
4510 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4511 if (sym
->ts
.u
.cl
->backend_decl
== NULL
4512 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
4515 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
4522 if (sym
->as
->type
!= AS_EXPLICIT
)
4524 for (n
= 0; n
< sym
->as
->rank
; n
++)
4525 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
4526 || sym
->as
->upper
[n
] == NULL
4527 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
4531 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
4532 sym
->attr
.dimension
, false))
4535 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
4538 /* Create the decl for the variable or constant. */
4539 decl
= build_decl (input_location
,
4540 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
4541 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
4542 if (sym
->attr
.flavor
== FL_PARAMETER
)
4543 TREE_READONLY (decl
) = 1;
4544 gfc_set_decl_location (decl
, &sym
->declared_at
);
4545 if (sym
->attr
.dimension
)
4546 GFC_DECL_PACKED_ARRAY (decl
) = 1;
4547 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4548 TREE_STATIC (decl
) = 1;
4549 TREE_USED (decl
) = 1;
4550 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
4551 TREE_PUBLIC (decl
) = 1;
4552 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
4554 sym
->attr
.dimension
,
4556 debug_hooks
->global_decl (decl
);
4561 generate_coarray_sym_init (gfc_symbol
*sym
)
4563 tree tmp
, size
, decl
, token
;
4565 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
4566 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
)
4569 decl
= sym
->backend_decl
;
4570 TREE_USED(decl
) = 1;
4571 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
4573 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4574 to make sure the variable is not optimized away. */
4575 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
4577 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
4579 /* Ensure that we do not have size=0 for zero-sized arrays. */
4580 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
4581 fold_convert (size_type_node
, size
),
4582 build_int_cst (size_type_node
, 1));
4584 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
4586 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
4587 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4588 fold_convert (size_type_node
, tmp
), size
);
4591 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
4592 token
= gfc_build_addr_expr (ppvoid_type_node
,
4593 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
4595 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 6, size
,
4596 build_int_cst (integer_type_node
,
4597 GFC_CAF_COARRAY_STATIC
), /* type. */
4598 token
, null_pointer_node
, /* token, stat. */
4599 null_pointer_node
, /* errgmsg, errmsg_len. */
4600 build_int_cst (integer_type_node
, 0));
4602 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
), tmp
));
4605 /* Handle "static" initializer. */
4608 sym
->attr
.pointer
= 1;
4609 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
4611 sym
->attr
.pointer
= 0;
4612 gfc_add_expr_to_block (&caf_init_block
, tmp
);
4617 /* Generate constructor function to initialize static, nonallocatable
4621 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
4623 tree fndecl
, tmp
, decl
, save_fn_decl
;
4625 save_fn_decl
= current_function_decl
;
4626 push_function_context ();
4628 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
4629 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
4630 create_tmp_var_name ("_caf_init"), tmp
);
4632 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
4633 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
4635 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
4636 DECL_ARTIFICIAL (decl
) = 1;
4637 DECL_IGNORED_P (decl
) = 1;
4638 DECL_CONTEXT (decl
) = fndecl
;
4639 DECL_RESULT (fndecl
) = decl
;
4642 current_function_decl
= fndecl
;
4643 announce_function (fndecl
);
4645 rest_of_decl_compilation (fndecl
, 0, 0);
4646 make_decl_rtl (fndecl
);
4647 allocate_struct_function (fndecl
, false);
4650 gfc_init_block (&caf_init_block
);
4652 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
4654 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
4658 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4660 DECL_SAVED_TREE (fndecl
)
4661 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4662 DECL_INITIAL (fndecl
));
4663 dump_function (TDI_original
, fndecl
);
4665 cfun
->function_end_locus
= input_location
;
4668 if (decl_function_context (fndecl
))
4669 (void) cgraph_create_node (fndecl
);
4671 cgraph_finalize_function (fndecl
, true);
4673 pop_function_context ();
4674 current_function_decl
= save_fn_decl
;
4679 create_module_nml_decl (gfc_symbol
*sym
)
4681 if (sym
->attr
.flavor
== FL_NAMELIST
)
4683 tree decl
= generate_namelist_decl (sym
);
4685 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4686 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4687 rest_of_decl_compilation (decl
, 1, 0);
4688 gfc_module_add_decl (cur_module
, decl
);
4693 /* Generate all the required code for module variables. */
4696 gfc_generate_module_vars (gfc_namespace
* ns
)
4698 module_namespace
= ns
;
4699 cur_module
= gfc_find_module (ns
->proc_name
->name
);
4701 /* Check if the frontend left the namespace in a reasonable state. */
4702 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
4704 /* Generate COMMON blocks. */
4705 gfc_trans_common (ns
);
4707 has_coarray_vars
= false;
4709 /* Create decls for all the module variables. */
4710 gfc_traverse_ns (ns
, gfc_create_module_variable
);
4711 gfc_traverse_ns (ns
, create_module_nml_decl
);
4713 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
4714 generate_coarray_init (ns
);
4718 gfc_trans_use_stmts (ns
);
4719 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
4724 gfc_generate_contained_functions (gfc_namespace
* parent
)
4728 /* We create all the prototypes before generating any code. */
4729 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4731 /* Skip namespaces from used modules. */
4732 if (ns
->parent
!= parent
)
4735 gfc_create_function_decl (ns
, false);
4738 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4740 /* Skip namespaces from used modules. */
4741 if (ns
->parent
!= parent
)
4744 gfc_generate_function_code (ns
);
4749 /* Drill down through expressions for the array specification bounds and
4750 character length calling generate_local_decl for all those variables
4751 that have not already been declared. */
4754 generate_local_decl (gfc_symbol
*);
4756 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4759 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
4760 int *f ATTRIBUTE_UNUSED
)
4762 if (e
->expr_type
!= EXPR_VARIABLE
4763 || sym
== e
->symtree
->n
.sym
4764 || e
->symtree
->n
.sym
->mark
4765 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
4768 generate_local_decl (e
->symtree
->n
.sym
);
4773 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
4775 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
4779 /* Check for dependencies in the character length and array spec. */
4782 generate_dependency_declarations (gfc_symbol
*sym
)
4786 if (sym
->ts
.type
== BT_CHARACTER
4788 && sym
->ts
.u
.cl
->length
4789 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4790 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
4792 if (sym
->as
&& sym
->as
->rank
)
4794 for (i
= 0; i
< sym
->as
->rank
; i
++)
4796 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
4797 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
4803 /* Generate decls for all local variables. We do this to ensure correct
4804 handling of expressions which only appear in the specification of
4808 generate_local_decl (gfc_symbol
* sym
)
4810 if (sym
->attr
.flavor
== FL_VARIABLE
)
4812 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4813 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4814 has_coarray_vars
= true;
4816 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
4817 generate_dependency_declarations (sym
);
4819 if (sym
->attr
.referenced
)
4820 gfc_get_symbol_decl (sym
);
4822 /* Warnings for unused dummy arguments. */
4823 else if (sym
->attr
.dummy
&& !sym
->attr
.in_namelist
)
4825 /* INTENT(out) dummy arguments are likely meant to be set. */
4826 if (gfc_option
.warn_unused_dummy_argument
4827 && sym
->attr
.intent
== INTENT_OUT
)
4829 if (sym
->ts
.type
!= BT_DERIVED
)
4830 gfc_warning ("Dummy argument '%s' at %L was declared "
4831 "INTENT(OUT) but was not set", sym
->name
,
4833 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
)
4834 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
4835 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4836 "declared INTENT(OUT) but was not set and "
4837 "does not have a default initializer",
4838 sym
->name
, &sym
->declared_at
);
4839 if (sym
->backend_decl
!= NULL_TREE
)
4840 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4842 else if (gfc_option
.warn_unused_dummy_argument
)
4844 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4846 if (sym
->backend_decl
!= NULL_TREE
)
4847 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4851 /* Warn for unused variables, but not if they're inside a common
4852 block or a namelist. */
4853 else if (warn_unused_variable
4854 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
4856 if (sym
->attr
.use_only
)
4858 gfc_warning ("Unused module variable '%s' which has been "
4859 "explicitly imported at %L", sym
->name
,
4861 if (sym
->backend_decl
!= NULL_TREE
)
4862 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4864 else if (!sym
->attr
.use_assoc
)
4866 gfc_warning ("Unused variable '%s' declared at %L",
4867 sym
->name
, &sym
->declared_at
);
4868 if (sym
->backend_decl
!= NULL_TREE
)
4869 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4873 /* For variable length CHARACTER parameters, the PARM_DECL already
4874 references the length variable, so force gfc_get_symbol_decl
4875 even when not referenced. If optimize > 0, it will be optimized
4876 away anyway. But do this only after emitting -Wunused-parameter
4877 warning if requested. */
4878 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
4879 && sym
->ts
.type
== BT_CHARACTER
4880 && sym
->ts
.u
.cl
->backend_decl
!= NULL
4881 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4883 sym
->attr
.referenced
= 1;
4884 gfc_get_symbol_decl (sym
);
4887 /* INTENT(out) dummy arguments and result variables with allocatable
4888 components are reset by default and need to be set referenced to
4889 generate the code for nullification and automatic lengths. */
4890 if (!sym
->attr
.referenced
4891 && sym
->ts
.type
== BT_DERIVED
4892 && sym
->ts
.u
.derived
->attr
.alloc_comp
4893 && !sym
->attr
.pointer
4894 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
4896 (sym
->attr
.result
&& sym
!= sym
->result
)))
4898 sym
->attr
.referenced
= 1;
4899 gfc_get_symbol_decl (sym
);
4902 /* Check for dependencies in the array specification and string
4903 length, adding the necessary declarations to the function. We
4904 mark the symbol now, as well as in traverse_ns, to prevent
4905 getting stuck in a circular dependency. */
4908 else if (sym
->attr
.flavor
== FL_PARAMETER
)
4910 if (warn_unused_parameter
4911 && !sym
->attr
.referenced
)
4913 if (!sym
->attr
.use_assoc
)
4914 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
4916 else if (sym
->attr
.use_only
)
4917 gfc_warning ("Unused parameter '%s' which has been explicitly "
4918 "imported at %L", sym
->name
, &sym
->declared_at
);
4921 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
4923 /* TODO: move to the appropriate place in resolve.c. */
4924 if (warn_return_type
4925 && sym
->attr
.function
4927 && sym
!= sym
->result
4928 && !sym
->result
->attr
.referenced
4929 && !sym
->attr
.use_assoc
4930 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
4932 gfc_warning ("Return value '%s' of function '%s' declared at "
4933 "%L not set", sym
->result
->name
, sym
->name
,
4934 &sym
->result
->declared_at
);
4936 /* Prevents "Unused variable" warning for RESULT variables. */
4937 sym
->result
->mark
= 1;
4941 if (sym
->attr
.dummy
== 1)
4943 /* Modify the tree type for scalar character dummy arguments of bind(c)
4944 procedures if they are passed by value. The tree type for them will
4945 be promoted to INTEGER_TYPE for the middle end, which appears to be
4946 what C would do with characters passed by-value. The value attribute
4947 implies the dummy is a scalar. */
4948 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
4949 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
4950 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
4951 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
4953 /* Unused procedure passed as dummy argument. */
4954 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4956 if (!sym
->attr
.referenced
)
4958 if (gfc_option
.warn_unused_dummy_argument
)
4959 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4963 /* Silence bogus "unused parameter" warnings from the
4965 if (sym
->backend_decl
!= NULL_TREE
)
4966 TREE_NO_WARNING (sym
->backend_decl
) = 1;
4970 /* Make sure we convert the types of the derived types from iso_c_binding
4972 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4973 && sym
->ts
.type
== BT_DERIVED
)
4974 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4979 generate_local_nml_decl (gfc_symbol
* sym
)
4981 if (sym
->attr
.flavor
== FL_NAMELIST
&& !sym
->attr
.use_assoc
)
4983 tree decl
= generate_namelist_decl (sym
);
4990 generate_local_vars (gfc_namespace
* ns
)
4992 gfc_traverse_ns (ns
, generate_local_decl
);
4993 gfc_traverse_ns (ns
, generate_local_nml_decl
);
4997 /* Generate a switch statement to jump to the correct entry point. Also
4998 creates the label decls for the entry points. */
5001 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
5008 gfc_init_block (&block
);
5009 for (; el
; el
= el
->next
)
5011 /* Add the case label. */
5012 label
= gfc_build_label_decl (NULL_TREE
);
5013 val
= build_int_cst (gfc_array_index_type
, el
->id
);
5014 tmp
= build_case_label (val
, NULL_TREE
, label
);
5015 gfc_add_expr_to_block (&block
, tmp
);
5017 /* And jump to the actual entry point. */
5018 label
= gfc_build_label_decl (NULL_TREE
);
5019 tmp
= build1_v (GOTO_EXPR
, label
);
5020 gfc_add_expr_to_block (&block
, tmp
);
5022 /* Save the label decl. */
5025 tmp
= gfc_finish_block (&block
);
5026 /* The first argument selects the entry point. */
5027 val
= DECL_ARGUMENTS (current_function_decl
);
5028 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
5029 val
, tmp
, NULL_TREE
);
5034 /* Add code to string lengths of actual arguments passed to a function against
5035 the expected lengths of the dummy arguments. */
5038 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
5040 gfc_formal_arglist
*formal
;
5042 for (formal
= gfc_sym_get_dummy_args (sym
); formal
; formal
= formal
->next
)
5043 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
5044 && !formal
->sym
->ts
.deferred
)
5046 enum tree_code comparison
;
5051 const char *message
;
5057 gcc_assert (cl
->passed_length
!= NULL_TREE
);
5058 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
5060 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5061 string lengths must match exactly. Otherwise, it is only required
5062 that the actual string length is *at least* the expected one.
5063 Sequence association allows for a mismatch of the string length
5064 if the actual argument is (part of) an array, but only if the
5065 dummy argument is an array. (See "Sequence association" in
5066 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5067 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
5068 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
5069 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
5071 comparison
= NE_EXPR
;
5072 message
= _("Actual string length does not match the declared one"
5073 " for dummy argument '%s' (%ld/%ld)");
5075 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
5079 comparison
= LT_EXPR
;
5080 message
= _("Actual string length is shorter than the declared one"
5081 " for dummy argument '%s' (%ld/%ld)");
5084 /* Build the condition. For optional arguments, an actual length
5085 of 0 is also acceptable if the associated string is NULL, which
5086 means the argument was not passed. */
5087 cond
= fold_build2_loc (input_location
, comparison
, boolean_type_node
,
5088 cl
->passed_length
, cl
->backend_decl
);
5089 if (fsym
->attr
.optional
)
5095 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
5098 build_zero_cst (gfc_charlen_type_node
));
5099 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5100 fsym
->attr
.referenced
= 1;
5101 not_absent
= gfc_conv_expr_present (fsym
);
5103 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
5104 boolean_type_node
, not_0length
,
5107 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
5108 boolean_type_node
, cond
, absent_failed
);
5111 /* Build the runtime check. */
5112 argname
= gfc_build_cstring_const (fsym
->name
);
5113 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
5114 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
5116 fold_convert (long_integer_type_node
,
5118 fold_convert (long_integer_type_node
,
5125 create_main_function (tree fndecl
)
5129 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
5132 old_context
= current_function_decl
;
5136 push_function_context ();
5137 saved_parent_function_decls
= saved_function_decls
;
5138 saved_function_decls
= NULL_TREE
;
5141 /* main() function must be declared with global scope. */
5142 gcc_assert (current_function_decl
== NULL_TREE
);
5144 /* Declare the function. */
5145 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
5146 build_pointer_type (pchar_type_node
),
5148 main_identifier_node
= get_identifier ("main");
5149 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
5150 main_identifier_node
, tmp
);
5151 DECL_EXTERNAL (ftn_main
) = 0;
5152 TREE_PUBLIC (ftn_main
) = 1;
5153 TREE_STATIC (ftn_main
) = 1;
5154 DECL_ATTRIBUTES (ftn_main
)
5155 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
5157 /* Setup the result declaration (for "return 0"). */
5158 result_decl
= build_decl (input_location
,
5159 RESULT_DECL
, NULL_TREE
, integer_type_node
);
5160 DECL_ARTIFICIAL (result_decl
) = 1;
5161 DECL_IGNORED_P (result_decl
) = 1;
5162 DECL_CONTEXT (result_decl
) = ftn_main
;
5163 DECL_RESULT (ftn_main
) = result_decl
;
5165 pushdecl (ftn_main
);
5167 /* Get the arguments. */
5169 arglist
= NULL_TREE
;
5170 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
5172 tmp
= TREE_VALUE (typelist
);
5173 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
5174 DECL_CONTEXT (argc
) = ftn_main
;
5175 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
5176 TREE_READONLY (argc
) = 1;
5177 gfc_finish_decl (argc
);
5178 arglist
= chainon (arglist
, argc
);
5180 typelist
= TREE_CHAIN (typelist
);
5181 tmp
= TREE_VALUE (typelist
);
5182 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
5183 DECL_CONTEXT (argv
) = ftn_main
;
5184 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
5185 TREE_READONLY (argv
) = 1;
5186 DECL_BY_REFERENCE (argv
) = 1;
5187 gfc_finish_decl (argv
);
5188 arglist
= chainon (arglist
, argv
);
5190 DECL_ARGUMENTS (ftn_main
) = arglist
;
5191 current_function_decl
= ftn_main
;
5192 announce_function (ftn_main
);
5194 rest_of_decl_compilation (ftn_main
, 1, 0);
5195 make_decl_rtl (ftn_main
);
5196 allocate_struct_function (ftn_main
, false);
5199 gfc_init_block (&body
);
5201 /* Call some libgfortran initialization routines, call then MAIN__(). */
5203 /* Call _gfortran_caf_init (*argc, ***argv). */
5204 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5206 tree pint_type
, pppchar_type
;
5207 pint_type
= build_pointer_type (integer_type_node
);
5209 = build_pointer_type (build_pointer_type (pchar_type_node
));
5211 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 2,
5212 gfc_build_addr_expr (pint_type
, argc
),
5213 gfc_build_addr_expr (pppchar_type
, argv
));
5214 gfc_add_expr_to_block (&body
, tmp
);
5217 /* Call _gfortran_set_args (argc, argv). */
5218 TREE_USED (argc
) = 1;
5219 TREE_USED (argv
) = 1;
5220 tmp
= build_call_expr_loc (input_location
,
5221 gfor_fndecl_set_args
, 2, argc
, argv
);
5222 gfc_add_expr_to_block (&body
, tmp
);
5224 /* Add a call to set_options to set up the runtime library Fortran
5225 language standard parameters. */
5227 tree array_type
, array
, var
;
5228 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5230 /* Passing a new option to the library requires four modifications:
5231 + add it to the tree_cons list below
5232 + change the array size in the call to build_array_type
5233 + change the first argument to the library call
5234 gfor_fndecl_set_options
5235 + modify the library (runtime/compile_options.c)! */
5237 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5238 build_int_cst (integer_type_node
,
5239 gfc_option
.warn_std
));
5240 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5241 build_int_cst (integer_type_node
,
5242 gfc_option
.allow_std
));
5243 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5244 build_int_cst (integer_type_node
, pedantic
));
5245 /* TODO: This is the old -fdump-core option, which is unused but
5246 passed due to ABI compatibility; remove when bumping the
5248 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5249 build_int_cst (integer_type_node
,
5251 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5252 build_int_cst (integer_type_node
,
5253 gfc_option
.flag_backtrace
));
5254 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5255 build_int_cst (integer_type_node
,
5256 gfc_option
.flag_sign_zero
));
5257 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5258 build_int_cst (integer_type_node
,
5260 & GFC_RTCHECK_BOUNDS
)));
5261 /* TODO: This is the -frange-check option, which no longer affects
5262 library behavior; when bumping the library ABI this slot can be
5263 reused for something else. As it is the last element in the
5264 array, we can instead leave it out altogether. */
5265 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5266 build_int_cst (integer_type_node
, 0));
5267 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5268 build_int_cst (integer_type_node
,
5269 gfc_option
.fpe_summary
));
5271 array_type
= build_array_type (integer_type_node
,
5272 build_index_type (size_int (8)));
5273 array
= build_constructor (array_type
, v
);
5274 TREE_CONSTANT (array
) = 1;
5275 TREE_STATIC (array
) = 1;
5277 /* Create a static variable to hold the jump table. */
5278 var
= gfc_create_var (array_type
, "options");
5279 TREE_CONSTANT (var
) = 1;
5280 TREE_STATIC (var
) = 1;
5281 TREE_READONLY (var
) = 1;
5282 DECL_INITIAL (var
) = array
;
5283 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
5285 tmp
= build_call_expr_loc (input_location
,
5286 gfor_fndecl_set_options
, 2,
5287 build_int_cst (integer_type_node
, 9), var
);
5288 gfc_add_expr_to_block (&body
, tmp
);
5291 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5292 the library will raise a FPE when needed. */
5293 if (gfc_option
.fpe
!= 0)
5295 tmp
= build_call_expr_loc (input_location
,
5296 gfor_fndecl_set_fpe
, 1,
5297 build_int_cst (integer_type_node
,
5299 gfc_add_expr_to_block (&body
, tmp
);
5302 /* If this is the main program and an -fconvert option was provided,
5303 add a call to set_convert. */
5305 if (gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
5307 tmp
= build_call_expr_loc (input_location
,
5308 gfor_fndecl_set_convert
, 1,
5309 build_int_cst (integer_type_node
,
5310 gfc_option
.convert
));
5311 gfc_add_expr_to_block (&body
, tmp
);
5314 /* If this is the main program and an -frecord-marker option was provided,
5315 add a call to set_record_marker. */
5317 if (gfc_option
.record_marker
!= 0)
5319 tmp
= build_call_expr_loc (input_location
,
5320 gfor_fndecl_set_record_marker
, 1,
5321 build_int_cst (integer_type_node
,
5322 gfc_option
.record_marker
));
5323 gfc_add_expr_to_block (&body
, tmp
);
5326 if (gfc_option
.max_subrecord_length
!= 0)
5328 tmp
= build_call_expr_loc (input_location
,
5329 gfor_fndecl_set_max_subrecord_length
, 1,
5330 build_int_cst (integer_type_node
,
5331 gfc_option
.max_subrecord_length
));
5332 gfc_add_expr_to_block (&body
, tmp
);
5335 /* Call MAIN__(). */
5336 tmp
= build_call_expr_loc (input_location
,
5338 gfc_add_expr_to_block (&body
, tmp
);
5340 /* Mark MAIN__ as used. */
5341 TREE_USED (fndecl
) = 1;
5343 /* Coarray: Call _gfortran_caf_finalize(void). */
5344 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5346 /* Per F2008, 8.5.1 END of the main program implies a
5348 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
5349 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
5350 gfc_add_expr_to_block (&body
, tmp
);
5352 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
5353 gfc_add_expr_to_block (&body
, tmp
);
5357 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
5358 DECL_RESULT (ftn_main
),
5359 build_int_cst (integer_type_node
, 0));
5360 tmp
= build1_v (RETURN_EXPR
, tmp
);
5361 gfc_add_expr_to_block (&body
, tmp
);
5364 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
5367 /* Finish off this function and send it for code generation. */
5369 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
5371 DECL_SAVED_TREE (ftn_main
)
5372 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
5373 DECL_INITIAL (ftn_main
));
5375 /* Output the GENERIC tree. */
5376 dump_function (TDI_original
, ftn_main
);
5378 cgraph_finalize_function (ftn_main
, true);
5382 pop_function_context ();
5383 saved_function_decls
= saved_parent_function_decls
;
5385 current_function_decl
= old_context
;
5389 /* Get the result expression for a procedure. */
5392 get_proc_result (gfc_symbol
* sym
)
5394 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
5396 if (current_fake_result_decl
!= NULL
)
5397 return TREE_VALUE (current_fake_result_decl
);
5402 return sym
->result
->backend_decl
;
5406 /* Generate an appropriate return-statement for a procedure. */
5409 gfc_generate_return (void)
5415 sym
= current_procedure_symbol
;
5416 fndecl
= sym
->backend_decl
;
5418 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
5422 result
= get_proc_result (sym
);
5424 /* Set the return value to the dummy result variable. The
5425 types may be different for scalar default REAL functions
5426 with -ff2c, therefore we have to convert. */
5427 if (result
!= NULL_TREE
)
5429 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
5430 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5431 TREE_TYPE (result
), DECL_RESULT (fndecl
),
5436 return build1_v (RETURN_EXPR
, result
);
5440 /* Generate code for a function. */
5443 gfc_generate_function_code (gfc_namespace
* ns
)
5449 stmtblock_t init
, cleanup
;
5451 gfc_wrapped_block try_block
;
5452 tree recurcheckvar
= NULL_TREE
;
5454 gfc_symbol
*previous_procedure_symbol
;
5458 sym
= ns
->proc_name
;
5459 previous_procedure_symbol
= current_procedure_symbol
;
5460 current_procedure_symbol
= sym
;
5462 /* Check that the frontend isn't still using this. */
5463 gcc_assert (sym
->tlink
== NULL
);
5466 /* Create the declaration for functions with global scope. */
5467 if (!sym
->backend_decl
)
5468 gfc_create_function_decl (ns
, false);
5470 fndecl
= sym
->backend_decl
;
5471 old_context
= current_function_decl
;
5475 push_function_context ();
5476 saved_parent_function_decls
= saved_function_decls
;
5477 saved_function_decls
= NULL_TREE
;
5480 trans_function_start (sym
);
5482 gfc_init_block (&init
);
5484 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
5486 /* Copy length backend_decls to all entry point result
5491 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
5492 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
5493 for (el
= ns
->entries
; el
; el
= el
->next
)
5494 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
5497 /* Translate COMMON blocks. */
5498 gfc_trans_common (ns
);
5500 /* Null the parent fake result declaration if this namespace is
5501 a module function or an external procedures. */
5502 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5503 || ns
->parent
== NULL
)
5504 parent_fake_result_decl
= NULL_TREE
;
5506 gfc_generate_contained_functions (ns
);
5508 nonlocal_dummy_decls
= NULL
;
5509 nonlocal_dummy_decl_pset
= NULL
;
5511 has_coarray_vars
= false;
5512 generate_local_vars (ns
);
5514 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5515 generate_coarray_init (ns
);
5517 /* Keep the parent fake result declaration in module functions
5518 or external procedures. */
5519 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5520 || ns
->parent
== NULL
)
5521 current_fake_result_decl
= parent_fake_result_decl
;
5523 current_fake_result_decl
= NULL_TREE
;
5525 is_recursive
= sym
->attr
.recursive
5526 || (sym
->attr
.entry_master
5527 && sym
->ns
->entries
->sym
->attr
.recursive
);
5528 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5530 && !gfc_option
.flag_recursive
)
5534 asprintf (&msg
, "Recursive call to nonrecursive procedure '%s'",
5536 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
5537 TREE_STATIC (recurcheckvar
) = 1;
5538 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
5539 gfc_add_expr_to_block (&init
, recurcheckvar
);
5540 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
5541 &sym
->declared_at
, msg
);
5542 gfc_add_modify (&init
, recurcheckvar
, boolean_true_node
);
5546 /* Now generate the code for the body of this function. */
5547 gfc_init_block (&body
);
5549 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
5550 && sym
->attr
.subroutine
)
5552 tree alternate_return
;
5553 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
5554 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
5559 /* Jump to the correct entry point. */
5560 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
5561 gfc_add_expr_to_block (&body
, tmp
);
5564 /* If bounds-checking is enabled, generate code to check passed in actual
5565 arguments against the expected dummy argument attributes (e.g. string
5567 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
5568 add_argument_checking (&body
, sym
);
5570 tmp
= gfc_trans_code (ns
->code
);
5571 gfc_add_expr_to_block (&body
, tmp
);
5573 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
5575 tree result
= get_proc_result (sym
);
5577 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
5579 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
5580 && sym
->result
== sym
)
5581 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
5582 null_pointer_node
));
5583 else if (sym
->ts
.type
== BT_CLASS
5584 && CLASS_DATA (sym
)->attr
.allocatable
5585 && CLASS_DATA (sym
)->attr
.dimension
== 0
5586 && sym
->result
== sym
)
5588 tmp
= CLASS_DATA (sym
)->backend_decl
;
5589 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5590 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
5591 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
5592 null_pointer_node
));
5594 else if (sym
->ts
.type
== BT_DERIVED
5595 && sym
->ts
.u
.derived
->attr
.alloc_comp
5596 && !sym
->attr
.allocatable
)
5598 rank
= sym
->as
? sym
->as
->rank
: 0;
5599 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, result
, rank
);
5600 gfc_add_expr_to_block (&init
, tmp
);
5604 if (result
== NULL_TREE
)
5606 /* TODO: move to the appropriate place in resolve.c. */
5607 if (warn_return_type
&& sym
== sym
->result
)
5608 gfc_warning ("Return value of function '%s' at %L not set",
5609 sym
->name
, &sym
->declared_at
);
5610 if (warn_return_type
)
5611 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5614 gfc_add_expr_to_block (&body
, gfc_generate_return ());
5617 gfc_init_block (&cleanup
);
5619 /* Reset recursion-check variable. */
5620 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5622 && !gfc_option
.gfc_flag_openmp
5623 && recurcheckvar
!= NULL_TREE
)
5625 gfc_add_modify (&cleanup
, recurcheckvar
, boolean_false_node
);
5626 recurcheckvar
= NULL
;
5629 /* Finish the function body and add init and cleanup code. */
5630 tmp
= gfc_finish_block (&body
);
5631 gfc_start_wrapped_block (&try_block
, tmp
);
5632 /* Add code to create and cleanup arrays. */
5633 gfc_trans_deferred_vars (sym
, &try_block
);
5634 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
5635 gfc_finish_block (&cleanup
));
5637 /* Add all the decls we created during processing. */
5638 decl
= saved_function_decls
;
5643 next
= DECL_CHAIN (decl
);
5644 DECL_CHAIN (decl
) = NULL_TREE
;
5648 saved_function_decls
= NULL_TREE
;
5650 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
5653 /* Finish off this function and send it for code generation. */
5655 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5657 DECL_SAVED_TREE (fndecl
)
5658 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5659 DECL_INITIAL (fndecl
));
5661 if (nonlocal_dummy_decls
)
5663 BLOCK_VARS (DECL_INITIAL (fndecl
))
5664 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
5665 pointer_set_destroy (nonlocal_dummy_decl_pset
);
5666 nonlocal_dummy_decls
= NULL
;
5667 nonlocal_dummy_decl_pset
= NULL
;
5670 /* Output the GENERIC tree. */
5671 dump_function (TDI_original
, fndecl
);
5673 /* Store the end of the function, so that we get good line number
5674 info for the epilogue. */
5675 cfun
->function_end_locus
= input_location
;
5677 /* We're leaving the context of this function, so zap cfun.
5678 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5679 tree_rest_of_compilation. */
5684 pop_function_context ();
5685 saved_function_decls
= saved_parent_function_decls
;
5687 current_function_decl
= old_context
;
5689 if (decl_function_context (fndecl
))
5691 /* Register this function with cgraph just far enough to get it
5692 added to our parent's nested function list.
5693 If there are static coarrays in this function, the nested _caf_init
5694 function has already called cgraph_create_node, which also created
5695 the cgraph node for this function. */
5696 if (!has_coarray_vars
|| gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
5697 (void) cgraph_create_node (fndecl
);
5700 cgraph_finalize_function (fndecl
, true);
5702 gfc_trans_use_stmts (ns
);
5703 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5705 if (sym
->attr
.is_main_program
)
5706 create_main_function (fndecl
);
5708 current_procedure_symbol
= previous_procedure_symbol
;
5713 gfc_generate_constructors (void)
5715 gcc_assert (gfc_static_ctors
== NULL_TREE
);
5723 if (gfc_static_ctors
== NULL_TREE
)
5726 fnname
= get_file_function_name ("I");
5727 type
= build_function_type_list (void_type_node
, NULL_TREE
);
5729 fndecl
= build_decl (input_location
,
5730 FUNCTION_DECL
, fnname
, type
);
5731 TREE_PUBLIC (fndecl
) = 1;
5733 decl
= build_decl (input_location
,
5734 RESULT_DECL
, NULL_TREE
, void_type_node
);
5735 DECL_ARTIFICIAL (decl
) = 1;
5736 DECL_IGNORED_P (decl
) = 1;
5737 DECL_CONTEXT (decl
) = fndecl
;
5738 DECL_RESULT (fndecl
) = decl
;
5742 current_function_decl
= fndecl
;
5744 rest_of_decl_compilation (fndecl
, 1, 0);
5746 make_decl_rtl (fndecl
);
5748 allocate_struct_function (fndecl
, false);
5752 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
5754 tmp
= build_call_expr_loc (input_location
,
5755 TREE_VALUE (gfc_static_ctors
), 0);
5756 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
5762 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5763 DECL_SAVED_TREE (fndecl
)
5764 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5765 DECL_INITIAL (fndecl
));
5767 free_after_parsing (cfun
);
5768 free_after_compilation (cfun
);
5770 tree_rest_of_compilation (fndecl
);
5772 current_function_decl
= NULL_TREE
;
5776 /* Translates a BLOCK DATA program unit. This means emitting the
5777 commons contained therein plus their initializations. We also emit
5778 a globally visible symbol to make sure that each BLOCK DATA program
5779 unit remains unique. */
5782 gfc_generate_block_data (gfc_namespace
* ns
)
5787 /* Tell the backend the source location of the block data. */
5789 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
5791 gfc_set_backend_locus (&gfc_current_locus
);
5793 /* Process the DATA statements. */
5794 gfc_trans_common (ns
);
5796 /* Create a global symbol with the mane of the block data. This is to
5797 generate linker errors if the same name is used twice. It is never
5800 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
5802 id
= get_identifier ("__BLOCK_DATA__");
5804 decl
= build_decl (input_location
,
5805 VAR_DECL
, id
, gfc_array_index_type
);
5806 TREE_PUBLIC (decl
) = 1;
5807 TREE_STATIC (decl
) = 1;
5808 DECL_IGNORED_P (decl
) = 1;
5811 rest_of_decl_compilation (decl
, 1, 0);
5815 /* Process the local variables of a BLOCK construct. */
5818 gfc_process_block_locals (gfc_namespace
* ns
)
5822 gcc_assert (saved_local_decls
== NULL_TREE
);
5823 has_coarray_vars
= false;
5825 generate_local_vars (ns
);
5827 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5828 generate_coarray_init (ns
);
5830 decl
= saved_local_decls
;
5835 next
= DECL_CHAIN (decl
);
5836 DECL_CHAIN (decl
) = NULL_TREE
;
5840 saved_local_decls
= NULL_TREE
;
5844 #include "gt-fortran-trans-decl.h"