1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-decl.c -- Handling of backend function and variable decls, etc */
27 #include "coretypes.h"
30 #include "tree-dump.h"
31 #include "gimple.h" /* For create_tmp_var_raw. */
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For announce_function. */
41 #include "pointer-set.h"
42 #include "constructor.h"
44 #include "trans-types.h"
45 #include "trans-array.h"
46 #include "trans-const.h"
47 /* Only for gfc_trans_code. Shouldn't need to include this. */
48 #include "trans-stmt.h"
50 #define MAX_LABEL_VALUE 99999
53 /* Holds the result of the function if no result variable specified. */
55 static GTY(()) tree current_fake_result_decl
;
56 static GTY(()) tree parent_fake_result_decl
;
59 /* Holds the variable DECLs for the current function. */
61 static GTY(()) tree saved_function_decls
;
62 static GTY(()) tree saved_parent_function_decls
;
64 static struct pointer_set_t
*nonlocal_dummy_decl_pset
;
65 static GTY(()) tree nonlocal_dummy_decls
;
67 /* Holds the variable DECLs that are locals. */
69 static GTY(()) tree saved_local_decls
;
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
74 static gfc_namespace
*module_namespace
;
76 /* The currently processed procedure symbol. */
77 static gfc_symbol
* current_procedure_symbol
= NULL
;
80 /* With -fcoarray=lib: For generating the registering call
81 of static coarrays. */
82 static bool has_coarray_vars
;
83 static stmtblock_t caf_init_block
;
86 /* List of static constructor functions. */
88 tree gfc_static_ctors
;
91 /* Function declarations for builtin library functions. */
93 tree gfor_fndecl_pause_numeric
;
94 tree gfor_fndecl_pause_string
;
95 tree gfor_fndecl_stop_numeric
;
96 tree gfor_fndecl_stop_numeric_f08
;
97 tree gfor_fndecl_stop_string
;
98 tree gfor_fndecl_error_stop_numeric
;
99 tree gfor_fndecl_error_stop_string
;
100 tree gfor_fndecl_runtime_error
;
101 tree gfor_fndecl_runtime_error_at
;
102 tree gfor_fndecl_runtime_warning_at
;
103 tree gfor_fndecl_os_error
;
104 tree gfor_fndecl_generate_error
;
105 tree gfor_fndecl_set_args
;
106 tree gfor_fndecl_set_fpe
;
107 tree gfor_fndecl_set_options
;
108 tree gfor_fndecl_set_convert
;
109 tree gfor_fndecl_set_record_marker
;
110 tree gfor_fndecl_set_max_subrecord_length
;
111 tree gfor_fndecl_ctime
;
112 tree gfor_fndecl_fdate
;
113 tree gfor_fndecl_ttynam
;
114 tree gfor_fndecl_in_pack
;
115 tree gfor_fndecl_in_unpack
;
116 tree gfor_fndecl_associated
;
119 /* Coarray run-time library function decls. */
120 tree gfor_fndecl_caf_init
;
121 tree gfor_fndecl_caf_finalize
;
122 tree gfor_fndecl_caf_register
;
123 tree gfor_fndecl_caf_deregister
;
124 tree gfor_fndecl_caf_critical
;
125 tree gfor_fndecl_caf_end_critical
;
126 tree gfor_fndecl_caf_sync_all
;
127 tree gfor_fndecl_caf_sync_images
;
128 tree gfor_fndecl_caf_error_stop
;
129 tree gfor_fndecl_caf_error_stop_str
;
131 /* Coarray global variables for num_images/this_image. */
133 tree gfort_gvar_caf_num_images
;
134 tree gfort_gvar_caf_this_image
;
137 /* Math functions. Many other math functions are handled in
138 trans-intrinsic.c. */
140 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
141 tree gfor_fndecl_math_ishftc4
;
142 tree gfor_fndecl_math_ishftc8
;
143 tree gfor_fndecl_math_ishftc16
;
146 /* String functions. */
148 tree gfor_fndecl_compare_string
;
149 tree gfor_fndecl_concat_string
;
150 tree gfor_fndecl_string_len_trim
;
151 tree gfor_fndecl_string_index
;
152 tree gfor_fndecl_string_scan
;
153 tree gfor_fndecl_string_verify
;
154 tree gfor_fndecl_string_trim
;
155 tree gfor_fndecl_string_minmax
;
156 tree gfor_fndecl_adjustl
;
157 tree gfor_fndecl_adjustr
;
158 tree gfor_fndecl_select_string
;
159 tree gfor_fndecl_compare_string_char4
;
160 tree gfor_fndecl_concat_string_char4
;
161 tree gfor_fndecl_string_len_trim_char4
;
162 tree gfor_fndecl_string_index_char4
;
163 tree gfor_fndecl_string_scan_char4
;
164 tree gfor_fndecl_string_verify_char4
;
165 tree gfor_fndecl_string_trim_char4
;
166 tree gfor_fndecl_string_minmax_char4
;
167 tree gfor_fndecl_adjustl_char4
;
168 tree gfor_fndecl_adjustr_char4
;
169 tree gfor_fndecl_select_string_char4
;
172 /* Conversion between character kinds. */
173 tree gfor_fndecl_convert_char1_to_char4
;
174 tree gfor_fndecl_convert_char4_to_char1
;
177 /* Other misc. runtime library functions. */
178 tree gfor_fndecl_size0
;
179 tree gfor_fndecl_size1
;
180 tree gfor_fndecl_iargc
;
182 /* Intrinsic functions implemented in Fortran. */
183 tree gfor_fndecl_sc_kind
;
184 tree gfor_fndecl_si_kind
;
185 tree gfor_fndecl_sr_kind
;
187 /* BLAS gemm functions. */
188 tree gfor_fndecl_sgemm
;
189 tree gfor_fndecl_dgemm
;
190 tree gfor_fndecl_cgemm
;
191 tree gfor_fndecl_zgemm
;
195 gfc_add_decl_to_parent_function (tree decl
)
198 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
199 DECL_NONLOCAL (decl
) = 1;
200 DECL_CHAIN (decl
) = saved_parent_function_decls
;
201 saved_parent_function_decls
= decl
;
205 gfc_add_decl_to_function (tree decl
)
208 TREE_USED (decl
) = 1;
209 DECL_CONTEXT (decl
) = current_function_decl
;
210 DECL_CHAIN (decl
) = saved_function_decls
;
211 saved_function_decls
= decl
;
215 add_decl_as_local (tree decl
)
218 TREE_USED (decl
) = 1;
219 DECL_CONTEXT (decl
) = current_function_decl
;
220 DECL_CHAIN (decl
) = saved_local_decls
;
221 saved_local_decls
= decl
;
225 /* Build a backend label declaration. Set TREE_USED for named labels.
226 The context of the label is always the current_function_decl. All
227 labels are marked artificial. */
230 gfc_build_label_decl (tree label_id
)
232 /* 2^32 temporaries should be enough. */
233 static unsigned int tmp_num
= 1;
237 if (label_id
== NULL_TREE
)
239 /* Build an internal label name. */
240 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
241 label_id
= get_identifier (label_name
);
246 /* Build the LABEL_DECL node. Labels have no type. */
247 label_decl
= build_decl (input_location
,
248 LABEL_DECL
, label_id
, void_type_node
);
249 DECL_CONTEXT (label_decl
) = current_function_decl
;
250 DECL_MODE (label_decl
) = VOIDmode
;
252 /* We always define the label as used, even if the original source
253 file never references the label. We don't want all kinds of
254 spurious warnings for old-style Fortran code with too many
256 TREE_USED (label_decl
) = 1;
258 DECL_ARTIFICIAL (label_decl
) = 1;
263 /* Set the backend source location of a decl. */
266 gfc_set_decl_location (tree decl
, locus
* loc
)
268 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
272 /* Return the backend label declaration for a given label structure,
273 or create it if it doesn't exist yet. */
276 gfc_get_label_decl (gfc_st_label
* lp
)
278 if (lp
->backend_decl
)
279 return lp
->backend_decl
;
282 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
285 /* Validate the label declaration from the front end. */
286 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
288 /* Build a mangled name for the label. */
289 sprintf (label_name
, "__label_%.6d", lp
->value
);
291 /* Build the LABEL_DECL node. */
292 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
294 /* Tell the debugger where the label came from. */
295 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
296 gfc_set_decl_location (label_decl
, &lp
->where
);
298 DECL_ARTIFICIAL (label_decl
) = 1;
300 /* Store the label in the label list and return the LABEL_DECL. */
301 lp
->backend_decl
= label_decl
;
307 /* Convert a gfc_symbol to an identifier of the same name. */
310 gfc_sym_identifier (gfc_symbol
* sym
)
312 if (sym
->attr
.is_main_program
&& strcmp (sym
->name
, "main") == 0)
313 return (get_identifier ("MAIN__"));
315 return (get_identifier (sym
->name
));
319 /* Construct mangled name from symbol name. */
322 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
324 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
326 /* Prevent the mangling of identifiers that have an assigned
327 binding label (mainly those that are bind(c)). */
328 if (sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
329 return get_identifier (sym
->binding_label
);
331 if (sym
->module
== NULL
)
332 return gfc_sym_identifier (sym
);
335 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
336 return get_identifier (name
);
341 /* Construct mangled function name from symbol name. */
344 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
347 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
349 /* It may be possible to simply use the binding label if it's
350 provided, and remove the other checks. Then we could use it
351 for other things if we wished. */
352 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
354 /* use the binding label rather than the mangled name */
355 return get_identifier (sym
->binding_label
);
357 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
358 || (sym
->module
!= NULL
&& (sym
->attr
.external
359 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
361 /* Main program is mangled into MAIN__. */
362 if (sym
->attr
.is_main_program
)
363 return get_identifier ("MAIN__");
365 /* Intrinsic procedures are never mangled. */
366 if (sym
->attr
.proc
== PROC_INTRINSIC
)
367 return get_identifier (sym
->name
);
369 if (gfc_option
.flag_underscoring
)
371 has_underscore
= strchr (sym
->name
, '_') != 0;
372 if (gfc_option
.flag_second_underscore
&& has_underscore
)
373 snprintf (name
, sizeof name
, "%s__", sym
->name
);
375 snprintf (name
, sizeof name
, "%s_", sym
->name
);
376 return get_identifier (name
);
379 return get_identifier (sym
->name
);
383 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
384 return get_identifier (name
);
390 gfc_set_decl_assembler_name (tree decl
, tree name
)
392 tree target_mangled
= targetm
.mangle_decl_assembler_name (decl
, name
);
393 SET_DECL_ASSEMBLER_NAME (decl
, target_mangled
);
397 /* Returns true if a variable of specified size should go on the stack. */
400 gfc_can_put_var_on_stack (tree size
)
402 unsigned HOST_WIDE_INT low
;
404 if (!INTEGER_CST_P (size
))
407 if (gfc_option
.flag_max_stack_var_size
< 0)
410 if (TREE_INT_CST_HIGH (size
) != 0)
413 low
= TREE_INT_CST_LOW (size
);
414 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
417 /* TODO: Set a per-function stack size limit. */
423 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
424 an expression involving its corresponding pointer. There are
425 2 cases; one for variable size arrays, and one for everything else,
426 because variable-sized arrays require one fewer level of
430 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
432 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
435 /* Parameters need to be dereferenced. */
436 if (sym
->cp_pointer
->attr
.dummy
)
437 ptr_decl
= build_fold_indirect_ref_loc (input_location
,
440 /* Check to see if we're dealing with a variable-sized array. */
441 if (sym
->attr
.dimension
442 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
444 /* These decls will be dereferenced later, so we don't dereference
446 value
= convert (TREE_TYPE (decl
), ptr_decl
);
450 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
452 value
= build_fold_indirect_ref_loc (input_location
,
456 SET_DECL_VALUE_EXPR (decl
, value
);
457 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
458 GFC_DECL_CRAY_POINTEE (decl
) = 1;
462 /* Finish processing of a declaration without an initial value. */
465 gfc_finish_decl (tree decl
)
467 gcc_assert (TREE_CODE (decl
) == PARM_DECL
468 || DECL_INITIAL (decl
) == NULL_TREE
);
470 if (TREE_CODE (decl
) != VAR_DECL
)
473 if (DECL_SIZE (decl
) == NULL_TREE
474 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
475 layout_decl (decl
, 0);
477 /* A few consistency checks. */
478 /* A static variable with an incomplete type is an error if it is
479 initialized. Also if it is not file scope. Otherwise, let it
480 through, but if it is not `extern' then it may cause an error
482 /* An automatic variable with an incomplete type is an error. */
484 /* We should know the storage size. */
485 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
486 || (TREE_STATIC (decl
)
487 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
488 : DECL_EXTERNAL (decl
)));
490 /* The storage size should be constant. */
491 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
493 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
497 /* Apply symbol attributes to a variable, and add it to the function scope. */
500 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
503 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
504 This is the equivalent of the TARGET variables.
505 We also need to set this if the variable is passed by reference in a
508 /* Set DECL_VALUE_EXPR for Cray Pointees. */
509 if (sym
->attr
.cray_pointee
)
510 gfc_finish_cray_pointee (decl
, sym
);
512 if (sym
->attr
.target
)
513 TREE_ADDRESSABLE (decl
) = 1;
514 /* If it wasn't used we wouldn't be getting it. */
515 TREE_USED (decl
) = 1;
517 if (sym
->attr
.flavor
== FL_PARAMETER
518 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
519 TREE_READONLY (decl
) = 1;
521 /* Chain this decl to the pending declarations. Don't do pushdecl()
522 because this would add them to the current scope rather than the
524 if (current_function_decl
!= NULL_TREE
)
526 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
527 || sym
->result
== sym
)
528 gfc_add_decl_to_function (decl
);
529 else if (sym
->ns
->proc_name
->attr
.flavor
== FL_LABEL
)
530 /* This is a BLOCK construct. */
531 add_decl_as_local (decl
);
533 gfc_add_decl_to_parent_function (decl
);
536 if (sym
->attr
.cray_pointee
)
539 if(sym
->attr
.is_bind_c
== 1 && sym
->binding_label
)
541 /* We need to put variables that are bind(c) into the common
542 segment of the object file, because this is what C would do.
543 gfortran would typically put them in either the BSS or
544 initialized data segments, and only mark them as common if
545 they were part of common blocks. However, if they are not put
546 into common space, then C cannot initialize global Fortran
547 variables that it interoperates with and the draft says that
548 either Fortran or C should be able to initialize it (but not
549 both, of course.) (J3/04-007, section 15.3). */
550 TREE_PUBLIC(decl
) = 1;
551 DECL_COMMON(decl
) = 1;
554 /* If a variable is USE associated, it's always external. */
555 if (sym
->attr
.use_assoc
)
557 DECL_EXTERNAL (decl
) = 1;
558 TREE_PUBLIC (decl
) = 1;
560 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
562 /* TODO: Don't set sym->module for result or dummy variables. */
563 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
564 /* This is the declaration of a module variable. */
565 if (sym
->attr
.access
== ACCESS_UNKNOWN
566 && (sym
->ns
->default_access
== ACCESS_PRIVATE
567 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
568 && gfc_option
.flag_module_private
)))
569 sym
->attr
.access
= ACCESS_PRIVATE
;
571 if (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
)
572 TREE_PUBLIC (decl
) = 1;
573 TREE_STATIC (decl
) = 1;
576 /* Derived types are a bit peculiar because of the possibility of
577 a default initializer; this must be applied each time the variable
578 comes into scope it therefore need not be static. These variables
579 are SAVE_NONE but have an initializer. Otherwise explicitly
580 initialized variables are SAVE_IMPLICIT and explicitly saved are
582 if (!sym
->attr
.use_assoc
583 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
584 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)
585 || (gfc_option
.coarray
== GFC_FCOARRAY_LIB
586 && sym
->attr
.codimension
&& !sym
->attr
.allocatable
)))
587 TREE_STATIC (decl
) = 1;
589 if (sym
->attr
.volatile_
)
591 TREE_THIS_VOLATILE (decl
) = 1;
592 TREE_SIDE_EFFECTS (decl
) = 1;
593 new_type
= build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
594 TREE_TYPE (decl
) = new_type
;
597 /* Keep variables larger than max-stack-var-size off stack. */
598 if (!sym
->ns
->proc_name
->attr
.recursive
599 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
600 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
601 /* Put variable length auto array pointers always into stack. */
602 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
603 || sym
->attr
.dimension
== 0
604 || sym
->as
->type
!= AS_EXPLICIT
606 || sym
->attr
.allocatable
)
607 && !DECL_ARTIFICIAL (decl
))
608 TREE_STATIC (decl
) = 1;
610 /* Handle threadprivate variables. */
611 if (sym
->attr
.threadprivate
612 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
613 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
617 /* Allocate the lang-specific part of a decl. */
620 gfc_allocate_lang_decl (tree decl
)
622 DECL_LANG_SPECIFIC (decl
) = ggc_alloc_cleared_lang_decl(sizeof
626 /* Remember a symbol to generate initialization/cleanup code at function
630 gfc_defer_symbol_init (gfc_symbol
* sym
)
636 /* Don't add a symbol twice. */
640 last
= head
= sym
->ns
->proc_name
;
643 /* Make sure that setup code for dummy variables which are used in the
644 setup of other variables is generated first. */
647 /* Find the first dummy arg seen after us, or the first non-dummy arg.
648 This is a circular list, so don't go past the head. */
650 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
656 /* Insert in between last and p. */
662 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
663 backend_decl for a module symbol, if it all ready exists. If the
664 module gsymbol does not exist, it is created. If the symbol does
665 not exist, it is added to the gsymbol namespace. Returns true if
666 an existing backend_decl is found. */
669 gfc_get_module_backend_decl (gfc_symbol
*sym
)
675 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
677 if (!gsym
|| (gsym
->ns
&& gsym
->type
== GSYM_MODULE
))
683 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
689 gsym
= gfc_get_gsymbol (sym
->module
);
690 gsym
->type
= GSYM_MODULE
;
691 gsym
->ns
= gfc_get_namespace (NULL
, 0);
694 st
= gfc_new_symtree (&gsym
->ns
->sym_root
, sym
->name
);
698 else if (sym
->attr
.flavor
== FL_DERIVED
)
700 if (s
&& s
->attr
.flavor
== FL_PROCEDURE
)
703 gcc_assert (s
->attr
.generic
);
704 for (intr
= s
->generic
; intr
; intr
= intr
->next
)
705 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
712 if (!s
->backend_decl
)
713 s
->backend_decl
= gfc_get_derived_type (s
);
714 gfc_copy_dt_decls_ifequal (s
, sym
, true);
717 else if (s
->backend_decl
)
719 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
720 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
722 else if (sym
->ts
.type
== BT_CHARACTER
)
723 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
724 sym
->backend_decl
= s
->backend_decl
;
732 /* Create an array index type variable with function scope. */
735 create_index_var (const char * pfx
, int nest
)
739 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
741 gfc_add_decl_to_parent_function (decl
);
743 gfc_add_decl_to_function (decl
);
748 /* Create variables to hold all the non-constant bits of info for a
749 descriptorless array. Remember these in the lang-specific part of the
753 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
758 gfc_namespace
* procns
;
760 type
= TREE_TYPE (decl
);
762 /* We just use the descriptor, if there is one. */
763 if (GFC_DESCRIPTOR_TYPE_P (type
))
766 gcc_assert (GFC_ARRAY_TYPE_P (type
));
767 procns
= gfc_find_proc_namespace (sym
->ns
);
768 nest
= (procns
->proc_name
->backend_decl
!= current_function_decl
)
769 && !sym
->attr
.contained
;
771 if (sym
->attr
.codimension
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
772 && sym
->as
->type
!= AS_ASSUMED_SHAPE
773 && GFC_TYPE_ARRAY_CAF_TOKEN (type
) == NULL_TREE
)
777 token
= gfc_create_var_np (build_qualified_type (pvoid_type_node
,
780 GFC_TYPE_ARRAY_CAF_TOKEN (type
) = token
;
781 DECL_ARTIFICIAL (token
) = 1;
782 TREE_STATIC (token
) = 1;
783 gfc_add_decl_to_function (token
);
786 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
788 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
790 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
791 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
793 /* Don't try to use the unknown bound for assumed shape arrays. */
794 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
795 && (sym
->as
->type
!= AS_ASSUMED_SIZE
796 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
798 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
799 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
802 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
804 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
805 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
808 for (dim
= GFC_TYPE_ARRAY_RANK (type
);
809 dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
); dim
++)
811 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
813 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
814 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
816 /* Don't try to use the unknown ubound for the last coarray dimension. */
817 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
818 && dim
< GFC_TYPE_ARRAY_RANK (type
) + GFC_TYPE_ARRAY_CORANK (type
) - 1)
820 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
821 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
824 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
826 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
828 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
831 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
833 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
836 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
837 && sym
->as
->type
!= AS_ASSUMED_SIZE
)
839 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
840 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
843 if (POINTER_TYPE_P (type
))
845 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
846 gcc_assert (TYPE_LANG_SPECIFIC (type
)
847 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
848 type
= TREE_TYPE (type
);
851 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
855 size
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
856 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
857 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
859 TYPE_DOMAIN (type
) = range
;
863 if (TYPE_NAME (type
) != NULL_TREE
864 && GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1) != NULL_TREE
865 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type
, sym
->as
->rank
- 1)) == VAR_DECL
)
867 tree gtype
= DECL_ORIGINAL_TYPE (TYPE_NAME (type
));
869 for (dim
= 0; dim
< sym
->as
->rank
- 1; dim
++)
871 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
872 gtype
= TREE_TYPE (gtype
);
874 gcc_assert (TREE_CODE (gtype
) == ARRAY_TYPE
);
875 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype
)) == NULL
)
876 TYPE_NAME (type
) = NULL_TREE
;
879 if (TYPE_NAME (type
) == NULL_TREE
)
881 tree gtype
= TREE_TYPE (type
), rtype
, type_decl
;
883 for (dim
= sym
->as
->rank
- 1; dim
>= 0; dim
--)
886 lbound
= GFC_TYPE_ARRAY_LBOUND (type
, dim
);
887 ubound
= GFC_TYPE_ARRAY_UBOUND (type
, dim
);
888 rtype
= build_range_type (gfc_array_index_type
, lbound
, ubound
);
889 gtype
= build_array_type (gtype
, rtype
);
890 /* Ensure the bound variables aren't optimized out at -O0.
891 For -O1 and above they often will be optimized out, but
892 can be tracked by VTA. Also set DECL_NAMELESS, so that
893 the artificial lbound.N or ubound.N DECL_NAME doesn't
894 end up in debug info. */
895 if (lbound
&& TREE_CODE (lbound
) == VAR_DECL
896 && DECL_ARTIFICIAL (lbound
) && DECL_IGNORED_P (lbound
))
898 if (DECL_NAME (lbound
)
899 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound
)),
901 DECL_NAMELESS (lbound
) = 1;
902 DECL_IGNORED_P (lbound
) = 0;
904 if (ubound
&& TREE_CODE (ubound
) == VAR_DECL
905 && DECL_ARTIFICIAL (ubound
) && DECL_IGNORED_P (ubound
))
907 if (DECL_NAME (ubound
)
908 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound
)),
910 DECL_NAMELESS (ubound
) = 1;
911 DECL_IGNORED_P (ubound
) = 0;
914 TYPE_NAME (type
) = type_decl
= build_decl (input_location
,
915 TYPE_DECL
, NULL
, gtype
);
916 DECL_ORIGINAL_TYPE (type_decl
) = gtype
;
921 /* For some dummy arguments we don't use the actual argument directly.
922 Instead we create a local decl and use that. This allows us to perform
923 initialization, and construct full type information. */
926 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
936 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
937 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
))
940 /* Add to list of variables if not a fake result variable. */
941 if (sym
->attr
.result
|| sym
->attr
.dummy
)
942 gfc_defer_symbol_init (sym
);
944 type
= TREE_TYPE (dummy
);
945 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
946 && POINTER_TYPE_P (type
));
948 /* Do we know the element size? */
949 known_size
= sym
->ts
.type
!= BT_CHARACTER
950 || INTEGER_CST_P (sym
->ts
.u
.cl
->backend_decl
);
952 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
954 /* For descriptorless arrays with known element size the actual
955 argument is sufficient. */
956 gcc_assert (GFC_ARRAY_TYPE_P (type
));
957 gfc_build_qualified_array (dummy
, sym
);
961 type
= TREE_TYPE (type
);
962 if (GFC_DESCRIPTOR_TYPE_P (type
))
964 /* Create a descriptorless array pointer. */
968 /* Even when -frepack-arrays is used, symbols with TARGET attribute
970 if (!gfc_option
.flag_repack_arrays
|| sym
->attr
.target
)
972 if (as
->type
== AS_ASSUMED_SIZE
)
973 packed
= PACKED_FULL
;
977 if (as
->type
== AS_EXPLICIT
)
979 packed
= PACKED_FULL
;
980 for (n
= 0; n
< as
->rank
; n
++)
984 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
985 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
986 packed
= PACKED_PARTIAL
;
990 packed
= PACKED_PARTIAL
;
993 type
= gfc_typenode_for_spec (&sym
->ts
);
994 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
999 /* We now have an expression for the element size, so create a fully
1000 qualified type. Reset sym->backend decl or this will just return the
1002 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1003 sym
->backend_decl
= NULL_TREE
;
1004 type
= gfc_sym_type (sym
);
1005 packed
= PACKED_FULL
;
1008 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
1009 decl
= build_decl (input_location
,
1010 VAR_DECL
, get_identifier (name
), type
);
1012 DECL_ARTIFICIAL (decl
) = 1;
1013 DECL_NAMELESS (decl
) = 1;
1014 TREE_PUBLIC (decl
) = 0;
1015 TREE_STATIC (decl
) = 0;
1016 DECL_EXTERNAL (decl
) = 0;
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 bool static_length
= sym
->attr
.save
1093 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1094 || gfc_option
.flag_max_stack_var_size
== 0;
1096 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1097 variables as some systems do not support the "." in the assembler name.
1098 For nonstatic variables, the "." does not appear in assembler. */
1102 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1105 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1107 else if (sym
->module
)
1108 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1110 name
= gfc_get_string (".%s", sym
->name
);
1112 length
= build_decl (input_location
,
1113 VAR_DECL
, get_identifier (name
),
1114 gfc_charlen_type_node
);
1115 DECL_ARTIFICIAL (length
) = 1;
1116 TREE_USED (length
) = 1;
1117 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1118 gfc_defer_symbol_init (sym
);
1120 sym
->ts
.u
.cl
->backend_decl
= length
;
1123 TREE_STATIC (length
) = 1;
1125 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1126 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1127 TREE_PUBLIC (length
) = 1;
1130 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1131 return sym
->ts
.u
.cl
->backend_decl
;
1134 /* If a variable is assigned a label, we add another two auxiliary
1138 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1144 gcc_assert (sym
->backend_decl
);
1146 decl
= sym
->backend_decl
;
1147 gfc_allocate_lang_decl (decl
);
1148 GFC_DECL_ASSIGN (decl
) = 1;
1149 length
= build_decl (input_location
,
1150 VAR_DECL
, create_tmp_var_name (sym
->name
),
1151 gfc_charlen_type_node
);
1152 addr
= build_decl (input_location
,
1153 VAR_DECL
, create_tmp_var_name (sym
->name
),
1155 gfc_finish_var_decl (length
, sym
);
1156 gfc_finish_var_decl (addr
, sym
);
1157 /* STRING_LENGTH is also used as flag. Less than -1 means that
1158 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1159 target label's address. Otherwise, value is the length of a format string
1160 and ASSIGN_ADDR is its address. */
1161 if (TREE_STATIC (length
))
1162 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1164 gfc_defer_symbol_init (sym
);
1166 GFC_DECL_STRING_LEN (decl
) = length
;
1167 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1172 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1177 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1178 if (sym_attr
.ext_attr
& (1 << id
))
1180 attr
= build_tree_list (
1181 get_identifier (ext_attr_list
[id
].middle_end_name
),
1183 list
= chainon (list
, attr
);
1190 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1193 /* Return the decl for a gfc_symbol, create it if it doesn't already
1197 gfc_get_symbol_decl (gfc_symbol
* sym
)
1200 tree length
= NULL_TREE
;
1203 bool intrinsic_array_parameter
= false;
1205 gcc_assert (sym
->attr
.referenced
1206 || sym
->attr
.flavor
== FL_PROCEDURE
1207 || sym
->attr
.use_assoc
1208 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1209 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1210 && sym
->backend_decl
));
1212 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1213 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1217 /* Make sure that the vtab for the declared type is completed. */
1218 if (sym
->ts
.type
== BT_CLASS
)
1220 gfc_component
*c
= CLASS_DATA (sym
);
1221 if (!c
->ts
.u
.derived
->backend_decl
)
1223 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1224 gfc_get_derived_type (sym
->ts
.u
.derived
);
1228 /* All deferred character length procedures need to retain the backend
1229 decl, which is a pointer to the character length in the caller's
1230 namespace and to declare a local character length. */
1231 if (!byref
&& sym
->attr
.function
1232 && sym
->ts
.type
== BT_CHARACTER
1234 && sym
->ts
.u
.cl
->passed_length
== NULL
1235 && sym
->ts
.u
.cl
->backend_decl
1236 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1238 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1239 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1240 length
= gfc_create_string_length (sym
);
1243 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
1245 /* Return via extra parameter. */
1246 if (sym
->attr
.result
&& byref
1247 && !sym
->backend_decl
)
1250 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1251 /* For entry master function skip over the __entry
1253 if (sym
->ns
->proc_name
->attr
.entry_master
)
1254 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1257 /* Dummy variables should already have been created. */
1258 gcc_assert (sym
->backend_decl
);
1260 /* Create a character length variable. */
1261 if (sym
->ts
.type
== BT_CHARACTER
)
1263 /* For a deferred dummy, make a new string length variable. */
1264 if (sym
->ts
.deferred
1266 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1267 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1269 if (sym
->ts
.deferred
&& sym
->attr
.result
1270 && sym
->ts
.u
.cl
->passed_length
== NULL
1271 && sym
->ts
.u
.cl
->backend_decl
)
1273 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1274 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1277 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1278 length
= gfc_create_string_length (sym
);
1280 length
= sym
->ts
.u
.cl
->backend_decl
;
1281 if (TREE_CODE (length
) == VAR_DECL
1282 && DECL_FILE_SCOPE_P (length
))
1284 /* Add the string length to the same context as the symbol. */
1285 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1286 gfc_add_decl_to_function (length
);
1288 gfc_add_decl_to_parent_function (length
);
1290 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1291 DECL_CONTEXT (length
));
1293 gfc_defer_symbol_init (sym
);
1297 /* Use a copy of the descriptor for dummy arrays. */
1298 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1299 && !TREE_USED (sym
->backend_decl
))
1301 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1302 /* Prevent the dummy from being detected as unused if it is copied. */
1303 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1304 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1305 sym
->backend_decl
= decl
;
1308 TREE_USED (sym
->backend_decl
) = 1;
1309 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1311 gfc_add_assign_aux_vars (sym
);
1314 if (sym
->attr
.dimension
1315 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1316 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1317 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1318 gfc_nonlocal_dummy_array_decl (sym
);
1320 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1321 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1323 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1324 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1325 return sym
->backend_decl
;
1328 if (sym
->backend_decl
)
1329 return sym
->backend_decl
;
1331 /* Special case for array-valued named constants from intrinsic
1332 procedures; those are inlined. */
1333 if (sym
->attr
.use_assoc
&& sym
->from_intmod
1334 && sym
->attr
.flavor
== FL_PARAMETER
)
1335 intrinsic_array_parameter
= true;
1337 /* If use associated and whole file compilation, use the module
1339 if (gfc_option
.flag_whole_file
1340 && (sym
->attr
.flavor
== FL_VARIABLE
1341 || sym
->attr
.flavor
== FL_PARAMETER
)
1342 && sym
->attr
.use_assoc
1343 && !intrinsic_array_parameter
1345 && gfc_get_module_backend_decl (sym
))
1347 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1348 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1349 return sym
->backend_decl
;
1352 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1354 /* Catch function declarations. Only used for actual parameters,
1355 procedure pointers and procptr initialization targets. */
1356 if (sym
->attr
.external
|| sym
->attr
.use_assoc
|| sym
->attr
.intrinsic
)
1358 decl
= gfc_get_extern_function_decl (sym
);
1359 gfc_set_decl_location (decl
, &sym
->declared_at
);
1363 if (!sym
->backend_decl
)
1364 build_function_decl (sym
, false);
1365 decl
= sym
->backend_decl
;
1370 if (sym
->attr
.intrinsic
)
1371 internal_error ("intrinsic variable which isn't a procedure");
1373 /* Create string length decl first so that they can be used in the
1374 type declaration. */
1375 if (sym
->ts
.type
== BT_CHARACTER
)
1376 length
= gfc_create_string_length (sym
);
1378 /* Create the decl for the variable. */
1379 decl
= build_decl (sym
->declared_at
.lb
->location
,
1380 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1382 /* Add attributes to variables. Functions are handled elsewhere. */
1383 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1384 decl_attributes (&decl
, attributes
, 0);
1386 /* Symbols from modules should have their assembler names mangled.
1387 This is done here rather than in gfc_finish_var_decl because it
1388 is different for string length variables. */
1391 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1392 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1393 DECL_IGNORED_P (decl
) = 1;
1396 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1398 /* Create variables to hold the non-constant bits of array info. */
1399 gfc_build_qualified_array (decl
, sym
);
1401 if (sym
->attr
.contiguous
1402 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1403 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1406 /* Remember this variable for allocation/cleanup. */
1407 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1408 || (sym
->ts
.type
== BT_CLASS
&&
1409 (CLASS_DATA (sym
)->attr
.dimension
1410 || CLASS_DATA (sym
)->attr
.allocatable
))
1411 || (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
1412 /* This applies a derived type default initializer. */
1413 || (sym
->ts
.type
== BT_DERIVED
1414 && sym
->attr
.save
== SAVE_NONE
1416 && !sym
->attr
.allocatable
1417 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1418 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1419 gfc_defer_symbol_init (sym
);
1421 gfc_finish_var_decl (decl
, sym
);
1423 if (sym
->ts
.type
== BT_CHARACTER
)
1425 /* Character variables need special handling. */
1426 gfc_allocate_lang_decl (decl
);
1428 if (TREE_CODE (length
) != INTEGER_CST
)
1430 gfc_finish_var_decl (length
, sym
);
1431 gcc_assert (!sym
->value
);
1434 else if (sym
->attr
.subref_array_pointer
)
1436 /* We need the span for these beasts. */
1437 gfc_allocate_lang_decl (decl
);
1440 if (sym
->attr
.subref_array_pointer
)
1443 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1444 span
= build_decl (input_location
,
1445 VAR_DECL
, create_tmp_var_name ("span"),
1446 gfc_array_index_type
);
1447 gfc_finish_var_decl (span
, sym
);
1448 TREE_STATIC (span
) = TREE_STATIC (decl
);
1449 DECL_ARTIFICIAL (span
) = 1;
1451 GFC_DECL_SPAN (decl
) = span
;
1452 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1455 if (sym
->ts
.type
== BT_CLASS
)
1456 GFC_DECL_CLASS(decl
) = 1;
1458 sym
->backend_decl
= decl
;
1460 if (sym
->attr
.assign
)
1461 gfc_add_assign_aux_vars (sym
);
1463 if (intrinsic_array_parameter
)
1465 TREE_STATIC (decl
) = 1;
1466 DECL_EXTERNAL (decl
) = 0;
1469 if (TREE_STATIC (decl
)
1470 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1471 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1472 || gfc_option
.flag_max_stack_var_size
== 0
1473 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1474 && (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
1475 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
))
1477 /* Add static initializer. For procedures, it is only needed if
1478 SAVE is specified otherwise they need to be reinitialized
1479 every time the procedure is entered. The TREE_STATIC is
1480 in this case due to -fmax-stack-var-size=. */
1481 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1484 || (sym
->attr
.codimension
1485 && sym
->attr
.allocatable
),
1487 || sym
->attr
.allocatable
,
1488 sym
->attr
.proc_pointer
);
1491 if (!TREE_STATIC (decl
)
1492 && POINTER_TYPE_P (TREE_TYPE (decl
))
1493 && !sym
->attr
.pointer
1494 && !sym
->attr
.allocatable
1495 && !sym
->attr
.proc_pointer
)
1496 DECL_BY_REFERENCE (decl
) = 1;
1499 || (sym
->name
[0] == '_' && strncmp ("__def_init", sym
->name
, 10) == 0))
1500 TREE_READONLY (decl
) = 1;
1506 /* Substitute a temporary variable in place of the real one. */
1509 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1511 save
->attr
= sym
->attr
;
1512 save
->decl
= sym
->backend_decl
;
1514 gfc_clear_attr (&sym
->attr
);
1515 sym
->attr
.referenced
= 1;
1516 sym
->attr
.flavor
= FL_VARIABLE
;
1518 sym
->backend_decl
= decl
;
1522 /* Restore the original variable. */
1525 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1527 sym
->attr
= save
->attr
;
1528 sym
->backend_decl
= save
->decl
;
1532 /* Declare a procedure pointer. */
1535 get_proc_pointer_decl (gfc_symbol
*sym
)
1540 decl
= sym
->backend_decl
;
1544 decl
= build_decl (input_location
,
1545 VAR_DECL
, get_identifier (sym
->name
),
1546 build_pointer_type (gfc_get_function_type (sym
)));
1550 /* Apply name mangling. */
1551 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1552 if (sym
->attr
.use_assoc
)
1553 DECL_IGNORED_P (decl
) = 1;
1556 if ((sym
->ns
->proc_name
1557 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1558 || sym
->attr
.contained
)
1559 gfc_add_decl_to_function (decl
);
1560 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1561 gfc_add_decl_to_parent_function (decl
);
1563 sym
->backend_decl
= decl
;
1565 /* If a variable is USE associated, it's always external. */
1566 if (sym
->attr
.use_assoc
)
1568 DECL_EXTERNAL (decl
) = 1;
1569 TREE_PUBLIC (decl
) = 1;
1571 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1573 /* This is the declaration of a module variable. */
1574 TREE_PUBLIC (decl
) = 1;
1575 TREE_STATIC (decl
) = 1;
1578 if (!sym
->attr
.use_assoc
1579 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1580 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1581 TREE_STATIC (decl
) = 1;
1583 if (TREE_STATIC (decl
) && sym
->value
)
1585 /* Add static initializer. */
1586 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1588 sym
->attr
.dimension
,
1592 /* Handle threadprivate procedure pointers. */
1593 if (sym
->attr
.threadprivate
1594 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
1595 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
1597 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1598 decl_attributes (&decl
, attributes
, 0);
1604 /* Get a basic decl for an external function. */
1607 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1613 gfc_intrinsic_sym
*isym
;
1615 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1620 if (sym
->backend_decl
)
1621 return sym
->backend_decl
;
1623 /* We should never be creating external decls for alternate entry points.
1624 The procedure may be an alternate entry point, but we don't want/need
1626 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1628 if (sym
->attr
.proc_pointer
)
1629 return get_proc_pointer_decl (sym
);
1631 /* See if this is an external procedure from the same file. If so,
1632 return the backend_decl. */
1633 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
1635 if (gfc_option
.flag_whole_file
1636 && (!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
1637 && !sym
->backend_decl
1639 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1640 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
1642 if (!gsym
->ns
->proc_name
->backend_decl
)
1644 /* By construction, the external function cannot be
1645 a contained procedure. */
1648 gfc_save_backend_locus (&old_loc
);
1651 gfc_create_function_decl (gsym
->ns
, true);
1654 gfc_restore_backend_locus (&old_loc
);
1657 /* If the namespace has entries, the proc_name is the
1658 entry master. Find the entry and use its backend_decl.
1659 otherwise, use the proc_name backend_decl. */
1660 if (gsym
->ns
->entries
)
1662 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1664 for (; entry
; entry
= entry
->next
)
1666 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1668 sym
->backend_decl
= entry
->sym
->backend_decl
;
1674 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1676 if (sym
->backend_decl
)
1678 /* Avoid problems of double deallocation of the backend declaration
1679 later in gfc_trans_use_stmts; cf. PR 45087. */
1680 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
1681 sym
->attr
.use_assoc
= 0;
1683 return sym
->backend_decl
;
1687 /* See if this is a module procedure from the same file. If so,
1688 return the backend_decl. */
1690 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1692 if (gfc_option
.flag_whole_file
1694 && gsym
->type
== GSYM_MODULE
)
1699 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1700 if (s
&& s
->backend_decl
)
1702 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1703 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
1705 else if (sym
->ts
.type
== BT_CHARACTER
)
1706 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1707 sym
->backend_decl
= s
->backend_decl
;
1708 return sym
->backend_decl
;
1712 if (sym
->attr
.intrinsic
)
1714 /* Call the resolution function to get the actual name. This is
1715 a nasty hack which relies on the resolution functions only looking
1716 at the first argument. We pass NULL for the second argument
1717 otherwise things like AINT get confused. */
1718 isym
= gfc_find_function (sym
->name
);
1719 gcc_assert (isym
->resolve
.f0
!= NULL
);
1721 memset (&e
, 0, sizeof (e
));
1722 e
.expr_type
= EXPR_FUNCTION
;
1724 memset (&argexpr
, 0, sizeof (argexpr
));
1725 gcc_assert (isym
->formal
);
1726 argexpr
.ts
= isym
->formal
->ts
;
1728 if (isym
->formal
->next
== NULL
)
1729 isym
->resolve
.f1 (&e
, &argexpr
);
1732 if (isym
->formal
->next
->next
== NULL
)
1733 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1736 if (isym
->formal
->next
->next
->next
== NULL
)
1737 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1740 /* All specific intrinsics take less than 5 arguments. */
1741 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1742 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1747 if (gfc_option
.flag_f2c
1748 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1749 || e
.ts
.type
== BT_COMPLEX
))
1751 /* Specific which needs a different implementation if f2c
1752 calling conventions are used. */
1753 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1756 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1758 name
= get_identifier (s
);
1759 mangled_name
= name
;
1763 name
= gfc_sym_identifier (sym
);
1764 mangled_name
= gfc_sym_mangled_function_id (sym
);
1767 type
= gfc_get_function_type (sym
);
1768 fndecl
= build_decl (input_location
,
1769 FUNCTION_DECL
, name
, type
);
1771 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1772 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1773 the opposite of declaring a function as static in C). */
1774 DECL_EXTERNAL (fndecl
) = 1;
1775 TREE_PUBLIC (fndecl
) = 1;
1777 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1778 decl_attributes (&fndecl
, attributes
, 0);
1780 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
1782 /* Set the context of this decl. */
1783 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1785 /* TODO: Add external decls to the appropriate scope. */
1786 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1790 /* Global declaration, e.g. intrinsic subroutine. */
1791 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1794 /* Set attributes for PURE functions. A call to PURE function in the
1795 Fortran 95 sense is both pure and without side effects in the C
1797 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
1799 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1800 DECL_PURE_P (fndecl
) = 1;
1801 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1802 parameters and don't use alternate returns (is this
1803 allowed?). In that case, calls to them are meaningless, and
1804 can be optimized away. See also in build_function_decl(). */
1805 TREE_SIDE_EFFECTS (fndecl
) = 0;
1808 /* Mark non-returning functions. */
1809 if (sym
->attr
.noreturn
)
1810 TREE_THIS_VOLATILE(fndecl
) = 1;
1812 sym
->backend_decl
= fndecl
;
1814 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1815 pushdecl_top_level (fndecl
);
1821 /* Create a declaration for a procedure. For external functions (in the C
1822 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1823 a master function with alternate entry points. */
1826 build_function_decl (gfc_symbol
* sym
, bool global
)
1828 tree fndecl
, type
, attributes
;
1829 symbol_attribute attr
;
1831 gfc_formal_arglist
*f
;
1833 gcc_assert (!sym
->attr
.external
);
1835 if (sym
->backend_decl
)
1838 /* Set the line and filename. sym->declared_at seems to point to the
1839 last statement for subroutines, but it'll do for now. */
1840 gfc_set_backend_locus (&sym
->declared_at
);
1842 /* Allow only one nesting level. Allow public declarations. */
1843 gcc_assert (current_function_decl
== NULL_TREE
1844 || DECL_FILE_SCOPE_P (current_function_decl
)
1845 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
1846 == NAMESPACE_DECL
));
1848 type
= gfc_get_function_type (sym
);
1849 fndecl
= build_decl (input_location
,
1850 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1854 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1855 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1856 the opposite of declaring a function as static in C). */
1857 DECL_EXTERNAL (fndecl
) = 0;
1859 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
1860 && (sym
->ns
->default_access
== ACCESS_PRIVATE
1861 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
1862 && gfc_option
.flag_module_private
)))
1863 sym
->attr
.access
= ACCESS_PRIVATE
;
1865 if (!current_function_decl
1866 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
1867 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
1868 || sym
->attr
.public_used
))
1869 TREE_PUBLIC (fndecl
) = 1;
1871 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
1872 TREE_USED (fndecl
) = 1;
1874 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
1875 decl_attributes (&fndecl
, attributes
, 0);
1877 /* Figure out the return type of the declared function, and build a
1878 RESULT_DECL for it. If this is a subroutine with alternate
1879 returns, build a RESULT_DECL for it. */
1880 result_decl
= NULL_TREE
;
1881 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1884 if (gfc_return_by_reference (sym
))
1885 type
= void_type_node
;
1888 if (sym
->result
!= sym
)
1889 result_decl
= gfc_sym_identifier (sym
->result
);
1891 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1896 /* Look for alternate return placeholders. */
1897 int has_alternate_returns
= 0;
1898 for (f
= sym
->formal
; f
; f
= f
->next
)
1902 has_alternate_returns
= 1;
1907 if (has_alternate_returns
)
1908 type
= integer_type_node
;
1910 type
= void_type_node
;
1913 result_decl
= build_decl (input_location
,
1914 RESULT_DECL
, result_decl
, type
);
1915 DECL_ARTIFICIAL (result_decl
) = 1;
1916 DECL_IGNORED_P (result_decl
) = 1;
1917 DECL_CONTEXT (result_decl
) = fndecl
;
1918 DECL_RESULT (fndecl
) = result_decl
;
1920 /* Don't call layout_decl for a RESULT_DECL.
1921 layout_decl (result_decl, 0); */
1923 /* TREE_STATIC means the function body is defined here. */
1924 TREE_STATIC (fndecl
) = 1;
1926 /* Set attributes for PURE functions. A call to a PURE function in the
1927 Fortran 95 sense is both pure and without side effects in the C
1929 if (attr
.pure
|| attr
.implicit_pure
)
1931 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1932 including an alternate return. In that case it can also be
1933 marked as PURE. See also in gfc_get_extern_function_decl(). */
1934 if (attr
.function
&& !gfc_return_by_reference (sym
))
1935 DECL_PURE_P (fndecl
) = 1;
1936 TREE_SIDE_EFFECTS (fndecl
) = 0;
1940 /* Layout the function declaration and put it in the binding level
1941 of the current function. */
1944 pushdecl_top_level (fndecl
);
1948 /* Perform name mangling if this is a top level or module procedure. */
1949 if (current_function_decl
== NULL_TREE
)
1950 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
1952 sym
->backend_decl
= fndecl
;
1956 /* Create the DECL_ARGUMENTS for a procedure. */
1959 create_function_arglist (gfc_symbol
* sym
)
1962 gfc_formal_arglist
*f
;
1963 tree typelist
, hidden_typelist
;
1964 tree arglist
, hidden_arglist
;
1968 fndecl
= sym
->backend_decl
;
1970 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1971 the new FUNCTION_DECL node. */
1972 arglist
= NULL_TREE
;
1973 hidden_arglist
= NULL_TREE
;
1974 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1976 if (sym
->attr
.entry_master
)
1978 type
= TREE_VALUE (typelist
);
1979 parm
= build_decl (input_location
,
1980 PARM_DECL
, get_identifier ("__entry"), type
);
1982 DECL_CONTEXT (parm
) = fndecl
;
1983 DECL_ARG_TYPE (parm
) = type
;
1984 TREE_READONLY (parm
) = 1;
1985 gfc_finish_decl (parm
);
1986 DECL_ARTIFICIAL (parm
) = 1;
1988 arglist
= chainon (arglist
, parm
);
1989 typelist
= TREE_CHAIN (typelist
);
1992 if (gfc_return_by_reference (sym
))
1994 tree type
= TREE_VALUE (typelist
), length
= NULL
;
1996 if (sym
->ts
.type
== BT_CHARACTER
)
1998 /* Length of character result. */
1999 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2001 length
= build_decl (input_location
,
2003 get_identifier (".__result"),
2005 if (!sym
->ts
.u
.cl
->length
)
2007 sym
->ts
.u
.cl
->backend_decl
= length
;
2008 TREE_USED (length
) = 1;
2010 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2011 DECL_CONTEXT (length
) = fndecl
;
2012 DECL_ARG_TYPE (length
) = len_type
;
2013 TREE_READONLY (length
) = 1;
2014 DECL_ARTIFICIAL (length
) = 1;
2015 gfc_finish_decl (length
);
2016 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2017 || sym
->ts
.u
.cl
->backend_decl
== length
)
2022 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2024 tree len
= build_decl (input_location
,
2026 get_identifier ("..__result"),
2027 gfc_charlen_type_node
);
2028 DECL_ARTIFICIAL (len
) = 1;
2029 TREE_USED (len
) = 1;
2030 sym
->ts
.u
.cl
->backend_decl
= len
;
2033 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2034 arg
= sym
->result
? sym
->result
: sym
;
2035 backend_decl
= arg
->backend_decl
;
2036 /* Temporary clear it, so that gfc_sym_type creates complete
2038 arg
->backend_decl
= NULL
;
2039 type
= gfc_sym_type (arg
);
2040 arg
->backend_decl
= backend_decl
;
2041 type
= build_reference_type (type
);
2045 parm
= build_decl (input_location
,
2046 PARM_DECL
, get_identifier ("__result"), type
);
2048 DECL_CONTEXT (parm
) = fndecl
;
2049 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2050 TREE_READONLY (parm
) = 1;
2051 DECL_ARTIFICIAL (parm
) = 1;
2052 gfc_finish_decl (parm
);
2054 arglist
= chainon (arglist
, parm
);
2055 typelist
= TREE_CHAIN (typelist
);
2057 if (sym
->ts
.type
== BT_CHARACTER
)
2059 gfc_allocate_lang_decl (parm
);
2060 arglist
= chainon (arglist
, length
);
2061 typelist
= TREE_CHAIN (typelist
);
2065 hidden_typelist
= typelist
;
2066 for (f
= sym
->formal
; f
; f
= f
->next
)
2067 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2068 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2070 for (f
= sym
->formal
; f
; f
= f
->next
)
2072 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2074 /* Ignore alternate returns. */
2078 type
= TREE_VALUE (typelist
);
2080 if (f
->sym
->ts
.type
== BT_CHARACTER
2081 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2083 tree len_type
= TREE_VALUE (hidden_typelist
);
2084 tree length
= NULL_TREE
;
2085 if (!f
->sym
->ts
.deferred
)
2086 gcc_assert (len_type
== gfc_charlen_type_node
);
2088 gcc_assert (POINTER_TYPE_P (len_type
));
2090 strcpy (&name
[1], f
->sym
->name
);
2092 length
= build_decl (input_location
,
2093 PARM_DECL
, get_identifier (name
), len_type
);
2095 hidden_arglist
= chainon (hidden_arglist
, length
);
2096 DECL_CONTEXT (length
) = fndecl
;
2097 DECL_ARTIFICIAL (length
) = 1;
2098 DECL_ARG_TYPE (length
) = len_type
;
2099 TREE_READONLY (length
) = 1;
2100 gfc_finish_decl (length
);
2102 /* Remember the passed value. */
2103 if (f
->sym
->ts
.u
.cl
->passed_length
!= NULL
)
2105 /* This can happen if the same type is used for multiple
2106 arguments. We need to copy cl as otherwise
2107 cl->passed_length gets overwritten. */
2108 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2110 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2112 /* Use the passed value for assumed length variables. */
2113 if (!f
->sym
->ts
.u
.cl
->length
)
2115 TREE_USED (length
) = 1;
2116 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2117 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2120 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2122 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2123 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2125 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2126 gfc_create_string_length (f
->sym
);
2128 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2129 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2130 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2132 type
= gfc_sym_type (f
->sym
);
2136 /* For non-constant length array arguments, make sure they use
2137 a different type node from TYPE_ARG_TYPES type. */
2138 if (f
->sym
->attr
.dimension
2139 && type
== TREE_VALUE (typelist
)
2140 && TREE_CODE (type
) == POINTER_TYPE
2141 && GFC_ARRAY_TYPE_P (type
)
2142 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2143 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2145 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2146 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2148 type
= gfc_sym_type (f
->sym
);
2151 if (f
->sym
->attr
.proc_pointer
)
2152 type
= build_pointer_type (type
);
2154 if (f
->sym
->attr
.volatile_
)
2155 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2157 /* Build the argument declaration. */
2158 parm
= build_decl (input_location
,
2159 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2161 if (f
->sym
->attr
.volatile_
)
2163 TREE_THIS_VOLATILE (parm
) = 1;
2164 TREE_SIDE_EFFECTS (parm
) = 1;
2167 /* Fill in arg stuff. */
2168 DECL_CONTEXT (parm
) = fndecl
;
2169 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2170 /* All implementation args are read-only. */
2171 TREE_READONLY (parm
) = 1;
2172 if (POINTER_TYPE_P (type
)
2173 && (!f
->sym
->attr
.proc_pointer
2174 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2175 DECL_BY_REFERENCE (parm
) = 1;
2177 gfc_finish_decl (parm
);
2179 f
->sym
->backend_decl
= parm
;
2181 /* Coarrays which are descriptorless or assumed-shape pass with
2182 -fcoarray=lib the token and the offset as hidden arguments. */
2183 if (f
->sym
->attr
.codimension
2184 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
2185 && !f
->sym
->attr
.allocatable
)
2191 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2192 && !sym
->attr
.is_bind_c
);
2193 caf_type
= TREE_TYPE (f
->sym
->backend_decl
);
2195 token
= build_decl (input_location
, PARM_DECL
,
2196 create_tmp_var_name ("caf_token"),
2197 build_qualified_type (pvoid_type_node
,
2198 TYPE_QUAL_RESTRICT
));
2199 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2201 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2202 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2203 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2204 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2205 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2209 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2210 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2213 DECL_CONTEXT (token
) = fndecl
;
2214 DECL_ARTIFICIAL (token
) = 1;
2215 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2216 TREE_READONLY (token
) = 1;
2217 hidden_arglist
= chainon (hidden_arglist
, token
);
2218 gfc_finish_decl (token
);
2220 offset
= build_decl (input_location
, PARM_DECL
,
2221 create_tmp_var_name ("caf_offset"),
2222 gfc_array_index_type
);
2224 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2226 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2228 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2232 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2233 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2235 DECL_CONTEXT (offset
) = fndecl
;
2236 DECL_ARTIFICIAL (offset
) = 1;
2237 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2238 TREE_READONLY (offset
) = 1;
2239 hidden_arglist
= chainon (hidden_arglist
, offset
);
2240 gfc_finish_decl (offset
);
2243 arglist
= chainon (arglist
, parm
);
2244 typelist
= TREE_CHAIN (typelist
);
2247 /* Add the hidden string length parameters, unless the procedure
2249 if (!sym
->attr
.is_bind_c
)
2250 arglist
= chainon (arglist
, hidden_arglist
);
2252 gcc_assert (hidden_typelist
== NULL_TREE
2253 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2254 DECL_ARGUMENTS (fndecl
) = arglist
;
2257 /* Do the setup necessary before generating the body of a function. */
2260 trans_function_start (gfc_symbol
* sym
)
2264 fndecl
= sym
->backend_decl
;
2266 /* Let GCC know the current scope is this function. */
2267 current_function_decl
= fndecl
;
2269 /* Let the world know what we're about to do. */
2270 announce_function (fndecl
);
2272 if (DECL_FILE_SCOPE_P (fndecl
))
2274 /* Create RTL for function declaration. */
2275 rest_of_decl_compilation (fndecl
, 1, 0);
2278 /* Create RTL for function definition. */
2279 make_decl_rtl (fndecl
);
2281 allocate_struct_function (fndecl
, false);
2283 /* function.c requires a push at the start of the function. */
2287 /* Create thunks for alternate entry points. */
2290 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2292 gfc_formal_arglist
*formal
;
2293 gfc_formal_arglist
*thunk_formal
;
2295 gfc_symbol
*thunk_sym
;
2301 /* This should always be a toplevel function. */
2302 gcc_assert (current_function_decl
== NULL_TREE
);
2304 gfc_save_backend_locus (&old_loc
);
2305 for (el
= ns
->entries
; el
; el
= el
->next
)
2307 vec
<tree
, va_gc
> *args
= NULL
;
2308 vec
<tree
, va_gc
> *string_args
= NULL
;
2310 thunk_sym
= el
->sym
;
2312 build_function_decl (thunk_sym
, global
);
2313 create_function_arglist (thunk_sym
);
2315 trans_function_start (thunk_sym
);
2317 thunk_fndecl
= thunk_sym
->backend_decl
;
2319 gfc_init_block (&body
);
2321 /* Pass extra parameter identifying this entry point. */
2322 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2323 vec_safe_push (args
, tmp
);
2325 if (thunk_sym
->attr
.function
)
2327 if (gfc_return_by_reference (ns
->proc_name
))
2329 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2330 vec_safe_push (args
, ref
);
2331 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2332 vec_safe_push (args
, DECL_CHAIN (ref
));
2336 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
2338 /* Ignore alternate returns. */
2339 if (formal
->sym
== NULL
)
2342 /* We don't have a clever way of identifying arguments, so resort to
2343 a brute-force search. */
2344 for (thunk_formal
= thunk_sym
->formal
;
2346 thunk_formal
= thunk_formal
->next
)
2348 if (thunk_formal
->sym
== formal
->sym
)
2354 /* Pass the argument. */
2355 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2356 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2357 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2359 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2360 vec_safe_push (string_args
, tmp
);
2365 /* Pass NULL for a missing argument. */
2366 vec_safe_push (args
, null_pointer_node
);
2367 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2369 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2370 vec_safe_push (string_args
, tmp
);
2375 /* Call the master function. */
2376 vec_safe_splice (args
, string_args
);
2377 tmp
= ns
->proc_name
->backend_decl
;
2378 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2379 if (ns
->proc_name
->attr
.mixed_entry_master
)
2381 tree union_decl
, field
;
2382 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2384 union_decl
= build_decl (input_location
,
2385 VAR_DECL
, get_identifier ("__result"),
2386 TREE_TYPE (master_type
));
2387 DECL_ARTIFICIAL (union_decl
) = 1;
2388 DECL_EXTERNAL (union_decl
) = 0;
2389 TREE_PUBLIC (union_decl
) = 0;
2390 TREE_USED (union_decl
) = 1;
2391 layout_decl (union_decl
, 0);
2392 pushdecl (union_decl
);
2394 DECL_CONTEXT (union_decl
) = current_function_decl
;
2395 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2396 TREE_TYPE (union_decl
), union_decl
, tmp
);
2397 gfc_add_expr_to_block (&body
, tmp
);
2399 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2400 field
; field
= DECL_CHAIN (field
))
2401 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2402 thunk_sym
->result
->name
) == 0)
2404 gcc_assert (field
!= NULL_TREE
);
2405 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2406 TREE_TYPE (field
), union_decl
, field
,
2408 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2409 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2410 DECL_RESULT (current_function_decl
), tmp
);
2411 tmp
= build1_v (RETURN_EXPR
, tmp
);
2413 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2416 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2417 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2418 DECL_RESULT (current_function_decl
), tmp
);
2419 tmp
= build1_v (RETURN_EXPR
, tmp
);
2421 gfc_add_expr_to_block (&body
, tmp
);
2423 /* Finish off this function and send it for code generation. */
2424 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2427 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2428 DECL_SAVED_TREE (thunk_fndecl
)
2429 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2430 DECL_INITIAL (thunk_fndecl
));
2432 /* Output the GENERIC tree. */
2433 dump_function (TDI_original
, thunk_fndecl
);
2435 /* Store the end of the function, so that we get good line number
2436 info for the epilogue. */
2437 cfun
->function_end_locus
= input_location
;
2439 /* We're leaving the context of this function, so zap cfun.
2440 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2441 tree_rest_of_compilation. */
2444 current_function_decl
= NULL_TREE
;
2446 cgraph_finalize_function (thunk_fndecl
, true);
2448 /* We share the symbols in the formal argument list with other entry
2449 points and the master function. Clear them so that they are
2450 recreated for each function. */
2451 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
2452 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2454 formal
->sym
->backend_decl
= NULL_TREE
;
2455 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2456 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2459 if (thunk_sym
->attr
.function
)
2461 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2462 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2463 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2464 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2468 gfc_restore_backend_locus (&old_loc
);
2472 /* Create a decl for a function, and create any thunks for alternate entry
2473 points. If global is true, generate the function in the global binding
2474 level, otherwise in the current binding level (which can be global). */
2477 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
2479 /* Create a declaration for the master function. */
2480 build_function_decl (ns
->proc_name
, global
);
2482 /* Compile the entry thunks. */
2484 build_entry_thunks (ns
, global
);
2486 /* Now create the read argument list. */
2487 create_function_arglist (ns
->proc_name
);
2490 /* Return the decl used to hold the function return value. If
2491 parent_flag is set, the context is the parent_scope. */
2494 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2498 tree this_fake_result_decl
;
2499 tree this_function_decl
;
2501 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2505 this_fake_result_decl
= parent_fake_result_decl
;
2506 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2510 this_fake_result_decl
= current_fake_result_decl
;
2511 this_function_decl
= current_function_decl
;
2515 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2516 && sym
->ns
->proc_name
->attr
.entry_master
2517 && sym
!= sym
->ns
->proc_name
)
2520 if (this_fake_result_decl
!= NULL
)
2521 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2522 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2525 return TREE_VALUE (t
);
2526 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2529 this_fake_result_decl
= parent_fake_result_decl
;
2531 this_fake_result_decl
= current_fake_result_decl
;
2533 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2537 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2538 field
; field
= DECL_CHAIN (field
))
2539 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2543 gcc_assert (field
!= NULL_TREE
);
2544 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2545 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
2548 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2550 gfc_add_decl_to_parent_function (var
);
2552 gfc_add_decl_to_function (var
);
2554 SET_DECL_VALUE_EXPR (var
, decl
);
2555 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2556 GFC_DECL_RESULT (var
) = 1;
2558 TREE_CHAIN (this_fake_result_decl
)
2559 = tree_cons (get_identifier (sym
->name
), var
,
2560 TREE_CHAIN (this_fake_result_decl
));
2564 if (this_fake_result_decl
!= NULL_TREE
)
2565 return TREE_VALUE (this_fake_result_decl
);
2567 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2572 if (sym
->ts
.type
== BT_CHARACTER
)
2574 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2575 length
= gfc_create_string_length (sym
);
2577 length
= sym
->ts
.u
.cl
->backend_decl
;
2578 if (TREE_CODE (length
) == VAR_DECL
2579 && DECL_CONTEXT (length
) == NULL_TREE
)
2580 gfc_add_decl_to_function (length
);
2583 if (gfc_return_by_reference (sym
))
2585 decl
= DECL_ARGUMENTS (this_function_decl
);
2587 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2588 && sym
->ns
->proc_name
->attr
.entry_master
)
2589 decl
= DECL_CHAIN (decl
);
2591 TREE_USED (decl
) = 1;
2593 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2597 sprintf (name
, "__result_%.20s",
2598 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2600 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2601 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2602 VAR_DECL
, get_identifier (name
),
2603 gfc_sym_type (sym
));
2605 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2606 VAR_DECL
, get_identifier (name
),
2607 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2608 DECL_ARTIFICIAL (decl
) = 1;
2609 DECL_EXTERNAL (decl
) = 0;
2610 TREE_PUBLIC (decl
) = 0;
2611 TREE_USED (decl
) = 1;
2612 GFC_DECL_RESULT (decl
) = 1;
2613 TREE_ADDRESSABLE (decl
) = 1;
2615 layout_decl (decl
, 0);
2618 gfc_add_decl_to_parent_function (decl
);
2620 gfc_add_decl_to_function (decl
);
2624 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2626 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2632 /* Builds a function decl. The remaining parameters are the types of the
2633 function arguments. Negative nargs indicates a varargs function. */
2636 build_library_function_decl_1 (tree name
, const char *spec
,
2637 tree rettype
, int nargs
, va_list p
)
2639 vec
<tree
, va_gc
> *arglist
;
2644 /* Library functions must be declared with global scope. */
2645 gcc_assert (current_function_decl
== NULL_TREE
);
2647 /* Create a list of the argument types. */
2648 vec_alloc (arglist
, abs (nargs
));
2649 for (n
= abs (nargs
); n
> 0; n
--)
2651 tree argtype
= va_arg (p
, tree
);
2652 arglist
->quick_push (argtype
);
2655 /* Build the function type and decl. */
2657 fntype
= build_function_type_vec (rettype
, arglist
);
2659 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
2662 tree attr_args
= build_tree_list (NULL_TREE
,
2663 build_string (strlen (spec
), spec
));
2664 tree attrs
= tree_cons (get_identifier ("fn spec"),
2665 attr_args
, TYPE_ATTRIBUTES (fntype
));
2666 fntype
= build_type_attribute_variant (fntype
, attrs
);
2668 fndecl
= build_decl (input_location
,
2669 FUNCTION_DECL
, name
, fntype
);
2671 /* Mark this decl as external. */
2672 DECL_EXTERNAL (fndecl
) = 1;
2673 TREE_PUBLIC (fndecl
) = 1;
2677 rest_of_decl_compilation (fndecl
, 1, 0);
2682 /* Builds a function decl. The remaining parameters are the types of the
2683 function arguments. Negative nargs indicates a varargs function. */
2686 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2690 va_start (args
, nargs
);
2691 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
2696 /* Builds a function decl. The remaining parameters are the types of the
2697 function arguments. Negative nargs indicates a varargs function.
2698 The SPEC parameter specifies the function argument and return type
2699 specification according to the fnspec function type attribute. */
2702 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
2703 tree rettype
, int nargs
, ...)
2707 va_start (args
, nargs
);
2708 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
2714 gfc_build_intrinsic_function_decls (void)
2716 tree gfc_int4_type_node
= gfc_get_int_type (4);
2717 tree gfc_int8_type_node
= gfc_get_int_type (8);
2718 tree gfc_int16_type_node
= gfc_get_int_type (16);
2719 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2720 tree pchar1_type_node
= gfc_get_pchar_type (1);
2721 tree pchar4_type_node
= gfc_get_pchar_type (4);
2723 /* String functions. */
2724 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
2725 get_identifier (PREFIX("compare_string")), "..R.R",
2726 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
2727 gfc_charlen_type_node
, pchar1_type_node
);
2728 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
2729 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
2731 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
2732 get_identifier (PREFIX("concat_string")), "..W.R.R",
2733 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
2734 gfc_charlen_type_node
, pchar1_type_node
,
2735 gfc_charlen_type_node
, pchar1_type_node
);
2736 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
2738 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
2739 get_identifier (PREFIX("string_len_trim")), "..R",
2740 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
2741 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
2742 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
2744 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
2745 get_identifier (PREFIX("string_index")), "..R.R.",
2746 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2747 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2748 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
2749 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
2751 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
2752 get_identifier (PREFIX("string_scan")), "..R.R.",
2753 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2754 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2755 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
2756 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
2758 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
2759 get_identifier (PREFIX("string_verify")), "..R.R.",
2760 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2761 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2762 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
2763 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
2765 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
2766 get_identifier (PREFIX("string_trim")), ".Ww.R",
2767 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2768 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
2771 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
2772 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2773 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2774 build_pointer_type (pchar1_type_node
), integer_type_node
,
2777 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
2778 get_identifier (PREFIX("adjustl")), ".W.R",
2779 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2781 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
2783 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
2784 get_identifier (PREFIX("adjustr")), ".W.R",
2785 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2787 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
2789 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
2790 get_identifier (PREFIX("select_string")), ".R.R.",
2791 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2792 pchar1_type_node
, gfc_charlen_type_node
);
2793 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
2794 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
2796 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
2797 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2798 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
2799 gfc_charlen_type_node
, pchar4_type_node
);
2800 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
2801 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
2803 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
2804 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2805 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
2806 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
2808 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
2810 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
2811 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2812 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
2813 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
2814 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
2816 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
2817 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2818 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2819 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2820 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
2821 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
2823 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
2824 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2825 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2826 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2827 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
2828 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
2830 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
2831 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2832 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2833 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2834 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
2835 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
2837 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
2838 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2839 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2840 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
2843 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
2844 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2845 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2846 build_pointer_type (pchar4_type_node
), integer_type_node
,
2849 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
2850 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2851 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2853 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
2855 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
2856 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2857 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2859 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
2861 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
2862 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2863 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2864 pvoid_type_node
, gfc_charlen_type_node
);
2865 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
2866 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
2869 /* Conversion between character kinds. */
2871 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
2872 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2873 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
2874 gfc_charlen_type_node
, pchar1_type_node
);
2876 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
2877 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2878 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
2879 gfc_charlen_type_node
, pchar4_type_node
);
2881 /* Misc. functions. */
2883 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
2884 get_identifier (PREFIX("ttynam")), ".W",
2885 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2888 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
2889 get_identifier (PREFIX("fdate")), ".W",
2890 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
2892 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
2893 get_identifier (PREFIX("ctime")), ".W",
2894 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2895 gfc_int8_type_node
);
2897 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
2898 get_identifier (PREFIX("selected_char_kind")), "..R",
2899 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
2900 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
2901 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
2903 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
2904 get_identifier (PREFIX("selected_int_kind")), ".R",
2905 gfc_int4_type_node
, 1, pvoid_type_node
);
2906 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
2907 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
2909 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
2910 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2911 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
2913 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
2914 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
2916 /* Power functions. */
2918 tree ctype
, rtype
, itype
, jtype
;
2919 int rkind
, ikind
, jkind
;
2922 static int ikinds
[NIKINDS
] = {4, 8, 16};
2923 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2924 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2926 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2928 itype
= gfc_get_int_type (ikinds
[ikind
]);
2930 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2932 jtype
= gfc_get_int_type (ikinds
[jkind
]);
2935 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
2937 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
2938 gfc_build_library_function_decl (get_identifier (name
),
2939 jtype
, 2, jtype
, itype
);
2940 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2941 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2945 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
2947 rtype
= gfc_get_real_type (rkinds
[rkind
]);
2950 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
2952 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
2953 gfc_build_library_function_decl (get_identifier (name
),
2954 rtype
, 2, rtype
, itype
);
2955 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2956 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2959 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
2962 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
2964 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
2965 gfc_build_library_function_decl (get_identifier (name
),
2966 ctype
, 2,ctype
, itype
);
2967 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2968 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2976 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
2977 get_identifier (PREFIX("ishftc4")),
2978 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
2979 gfc_int4_type_node
);
2980 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
2981 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
2983 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
2984 get_identifier (PREFIX("ishftc8")),
2985 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
2986 gfc_int4_type_node
);
2987 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
2988 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
2990 if (gfc_int16_type_node
)
2992 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
2993 get_identifier (PREFIX("ishftc16")),
2994 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
2995 gfc_int4_type_node
);
2996 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
2997 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3000 /* BLAS functions. */
3002 tree pint
= build_pointer_type (integer_type_node
);
3003 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3004 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3005 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3006 tree pz
= build_pointer_type
3007 (gfc_get_complex_type (gfc_default_double_kind
));
3009 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3011 (gfc_option
.flag_underscoring
? "sgemm_"
3013 void_type_node
, 15, pchar_type_node
,
3014 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3015 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3017 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3019 (gfc_option
.flag_underscoring
? "dgemm_"
3021 void_type_node
, 15, pchar_type_node
,
3022 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3023 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3025 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3027 (gfc_option
.flag_underscoring
? "cgemm_"
3029 void_type_node
, 15, pchar_type_node
,
3030 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3031 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3033 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3035 (gfc_option
.flag_underscoring
? "zgemm_"
3037 void_type_node
, 15, pchar_type_node
,
3038 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3039 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3043 /* Other functions. */
3044 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3045 get_identifier (PREFIX("size0")), ".R",
3046 gfc_array_index_type
, 1, pvoid_type_node
);
3047 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3048 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3050 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3051 get_identifier (PREFIX("size1")), ".R",
3052 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3053 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3054 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3056 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3057 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3058 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3062 /* Make prototypes for runtime library functions. */
3065 gfc_build_builtin_function_decls (void)
3067 tree gfc_int4_type_node
= gfc_get_int_type (4);
3069 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3070 get_identifier (PREFIX("stop_numeric")),
3071 void_type_node
, 1, gfc_int4_type_node
);
3072 /* STOP doesn't return. */
3073 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3075 gfor_fndecl_stop_numeric_f08
= gfc_build_library_function_decl (
3076 get_identifier (PREFIX("stop_numeric_f08")),
3077 void_type_node
, 1, gfc_int4_type_node
);
3078 /* STOP doesn't return. */
3079 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08
) = 1;
3081 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3082 get_identifier (PREFIX("stop_string")), ".R.",
3083 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3084 /* STOP doesn't return. */
3085 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3087 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3088 get_identifier (PREFIX("error_stop_numeric")),
3089 void_type_node
, 1, gfc_int4_type_node
);
3090 /* ERROR STOP doesn't return. */
3091 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3093 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3094 get_identifier (PREFIX("error_stop_string")), ".R.",
3095 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3096 /* ERROR STOP doesn't return. */
3097 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3099 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3100 get_identifier (PREFIX("pause_numeric")),
3101 void_type_node
, 1, gfc_int4_type_node
);
3103 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3104 get_identifier (PREFIX("pause_string")), ".R.",
3105 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3107 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3108 get_identifier (PREFIX("runtime_error")), ".R",
3109 void_type_node
, -1, pchar_type_node
);
3110 /* The runtime_error function does not return. */
3111 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3113 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3114 get_identifier (PREFIX("runtime_error_at")), ".RR",
3115 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3116 /* The runtime_error_at function does not return. */
3117 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3119 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3120 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3121 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3123 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3124 get_identifier (PREFIX("generate_error")), ".R.R",
3125 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3128 gfor_fndecl_os_error
= gfc_build_library_function_decl_with_spec (
3129 get_identifier (PREFIX("os_error")), ".R",
3130 void_type_node
, 1, pchar_type_node
);
3131 /* The runtime_error function does not return. */
3132 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
3134 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3135 get_identifier (PREFIX("set_args")),
3136 void_type_node
, 2, integer_type_node
,
3137 build_pointer_type (pchar_type_node
));
3139 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3140 get_identifier (PREFIX("set_fpe")),
3141 void_type_node
, 1, integer_type_node
);
3143 /* Keep the array dimension in sync with the call, later in this file. */
3144 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3145 get_identifier (PREFIX("set_options")), "..R",
3146 void_type_node
, 2, integer_type_node
,
3147 build_pointer_type (integer_type_node
));
3149 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3150 get_identifier (PREFIX("set_convert")),
3151 void_type_node
, 1, integer_type_node
);
3153 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3154 get_identifier (PREFIX("set_record_marker")),
3155 void_type_node
, 1, integer_type_node
);
3157 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3158 get_identifier (PREFIX("set_max_subrecord_length")),
3159 void_type_node
, 1, integer_type_node
);
3161 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3162 get_identifier (PREFIX("internal_pack")), ".r",
3163 pvoid_type_node
, 1, pvoid_type_node
);
3165 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3166 get_identifier (PREFIX("internal_unpack")), ".wR",
3167 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3169 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3170 get_identifier (PREFIX("associated")), ".RR",
3171 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3172 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3173 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3175 /* Coarray library calls. */
3176 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
3178 tree pint_type
, pppchar_type
;
3180 pint_type
= build_pointer_type (integer_type_node
);
3182 = build_pointer_type (build_pointer_type (pchar_type_node
));
3184 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3185 get_identifier (PREFIX("caf_init")), void_type_node
,
3186 4, pint_type
, pppchar_type
, pint_type
, pint_type
);
3188 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3189 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3191 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3192 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node
, 6,
3193 size_type_node
, integer_type_node
, ppvoid_type_node
, pint_type
,
3194 pchar_type_node
, integer_type_node
);
3196 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3197 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node
, 4,
3198 ppvoid_type_node
, pint_type
, pchar_type_node
, integer_type_node
);
3200 gfor_fndecl_caf_critical
= gfc_build_library_function_decl (
3201 get_identifier (PREFIX("caf_critical")), void_type_node
, 0);
3203 gfor_fndecl_caf_end_critical
= gfc_build_library_function_decl (
3204 get_identifier (PREFIX("caf_end_critical")), void_type_node
, 0);
3206 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3207 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3208 3, pint_type
, build_pointer_type (pchar_type_node
), integer_type_node
);
3210 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3211 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3212 5, integer_type_node
, pint_type
, pint_type
,
3213 build_pointer_type (pchar_type_node
), integer_type_node
);
3215 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3216 get_identifier (PREFIX("caf_error_stop")),
3217 void_type_node
, 1, gfc_int4_type_node
);
3218 /* CAF's ERROR STOP doesn't return. */
3219 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3221 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3222 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3223 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3224 /* CAF's ERROR STOP doesn't return. */
3225 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3228 gfc_build_intrinsic_function_decls ();
3229 gfc_build_intrinsic_lib_fndecls ();
3230 gfc_build_io_library_fndecls ();
3234 /* Evaluate the length of dummy character variables. */
3237 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
3238 gfc_wrapped_block
*block
)
3242 gfc_finish_decl (cl
->backend_decl
);
3244 gfc_start_block (&init
);
3246 /* Evaluate the string length expression. */
3247 gfc_conv_string_length (cl
, NULL
, &init
);
3249 gfc_trans_vla_type_sizes (sym
, &init
);
3251 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3255 /* Allocate and cleanup an automatic character variable. */
3258 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3264 gcc_assert (sym
->backend_decl
);
3265 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
3267 gfc_init_block (&init
);
3269 /* Evaluate the string length expression. */
3270 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
3272 gfc_trans_vla_type_sizes (sym
, &init
);
3274 decl
= sym
->backend_decl
;
3276 /* Emit a DECL_EXPR for this variable, which will cause the
3277 gimplifier to allocate storage, and all that good stuff. */
3278 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
3279 gfc_add_expr_to_block (&init
, tmp
);
3281 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3284 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3287 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3291 gcc_assert (sym
->backend_decl
);
3292 gfc_start_block (&init
);
3294 /* Set the initial value to length. See the comments in
3295 function gfc_add_assign_aux_vars in this file. */
3296 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
3297 build_int_cst (gfc_charlen_type_node
, -2));
3299 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3303 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
3305 tree t
= *tp
, var
, val
;
3307 if (t
== NULL
|| t
== error_mark_node
)
3309 if (TREE_CONSTANT (t
) || DECL_P (t
))
3312 if (TREE_CODE (t
) == SAVE_EXPR
)
3314 if (SAVE_EXPR_RESOLVED_P (t
))
3316 *tp
= TREE_OPERAND (t
, 0);
3319 val
= TREE_OPERAND (t
, 0);
3324 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
3325 gfc_add_decl_to_function (var
);
3326 gfc_add_modify (body
, var
, val
);
3327 if (TREE_CODE (t
) == SAVE_EXPR
)
3328 TREE_OPERAND (t
, 0) = var
;
3333 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
3337 if (type
== NULL
|| type
== error_mark_node
)
3340 type
= TYPE_MAIN_VARIANT (type
);
3342 if (TREE_CODE (type
) == INTEGER_TYPE
)
3344 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
3345 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
3347 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3349 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
3350 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
3353 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3355 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
3356 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
3357 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
3358 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
3360 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3362 TYPE_SIZE (t
) = TYPE_SIZE (type
);
3363 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
3368 /* Make sure all type sizes and array domains are either constant,
3369 or variable or parameter decls. This is a simplified variant
3370 of gimplify_type_sizes, but we can't use it here, as none of the
3371 variables in the expressions have been gimplified yet.
3372 As type sizes and domains for various variable length arrays
3373 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3374 time, without this routine gimplify_type_sizes in the middle-end
3375 could result in the type sizes being gimplified earlier than where
3376 those variables are initialized. */
3379 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
3381 tree type
= TREE_TYPE (sym
->backend_decl
);
3383 if (TREE_CODE (type
) == FUNCTION_TYPE
3384 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
3386 if (! current_fake_result_decl
)
3389 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
3392 while (POINTER_TYPE_P (type
))
3393 type
= TREE_TYPE (type
);
3395 if (GFC_DESCRIPTOR_TYPE_P (type
))
3397 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3399 while (POINTER_TYPE_P (etype
))
3400 etype
= TREE_TYPE (etype
);
3402 gfc_trans_vla_type_sizes_1 (etype
, body
);
3405 gfc_trans_vla_type_sizes_1 (type
, body
);
3409 /* Initialize a derived type by building an lvalue from the symbol
3410 and using trans_assignment to do the work. Set dealloc to false
3411 if no deallocation prior the assignment is needed. */
3413 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
3421 gcc_assert (!sym
->attr
.allocatable
);
3422 gfc_set_sym_referenced (sym
);
3423 e
= gfc_lval_expr_from_sym (sym
);
3424 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3425 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3426 || sym
->ns
->proc_name
->attr
.entry_master
))
3428 present
= gfc_conv_expr_present (sym
);
3429 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
3430 tmp
, build_empty_stmt (input_location
));
3432 gfc_add_expr_to_block (block
, tmp
);
3437 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3438 them their default initializer, if they do not have allocatable
3439 components, they have their allocatable components deallocated. */
3442 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3445 gfc_formal_arglist
*f
;
3449 gfc_init_block (&init
);
3450 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3451 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3452 && !f
->sym
->attr
.pointer
3453 && f
->sym
->ts
.type
== BT_DERIVED
)
3455 if (f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3457 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3458 f
->sym
->backend_decl
,
3459 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3461 if (f
->sym
->attr
.optional
3462 || f
->sym
->ns
->proc_name
->attr
.entry_master
)
3464 present
= gfc_conv_expr_present (f
->sym
);
3465 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3467 build_empty_stmt (input_location
));
3470 gfc_add_expr_to_block (&init
, tmp
);
3472 else if (f
->sym
->value
)
3473 gfc_init_default_dt (f
->sym
, &init
, true);
3475 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3476 && f
->sym
->ts
.type
== BT_CLASS
3477 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3478 && CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.alloc_comp
)
3480 tmp
= gfc_class_data_get (f
->sym
->backend_decl
);
3481 if (CLASS_DATA (f
->sym
)->as
== NULL
)
3482 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3483 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (f
->sym
)->ts
.u
.derived
,
3485 CLASS_DATA (f
->sym
)->as
?
3486 CLASS_DATA (f
->sym
)->as
->rank
: 0);
3488 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
3490 present
= gfc_conv_expr_present (f
->sym
);
3491 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3493 build_empty_stmt (input_location
));
3496 gfc_add_expr_to_block (&init
, tmp
);
3499 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3503 /* Generate function entry and exit code, and add it to the function body.
3505 Allocation and initialization of array variables.
3506 Allocation of character string variables.
3507 Initialization and possibly repacking of dummy arrays.
3508 Initialization of ASSIGN statement auxiliary variable.
3509 Initialization of ASSOCIATE names.
3510 Automatic deallocation. */
3513 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3517 gfc_formal_arglist
*f
;
3518 stmtblock_t tmpblock
;
3519 bool seen_trans_deferred_array
= false;
3525 /* Deal with implicit return variables. Explicit return variables will
3526 already have been added. */
3527 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
3529 if (!current_fake_result_decl
)
3531 gfc_entry_list
*el
= NULL
;
3532 if (proc_sym
->attr
.entry_master
)
3534 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
3535 if (el
->sym
!= el
->sym
->result
)
3538 /* TODO: move to the appropriate place in resolve.c. */
3539 if (warn_return_type
&& el
== NULL
)
3540 gfc_warning ("Return value of function '%s' at %L not set",
3541 proc_sym
->name
, &proc_sym
->declared_at
);
3543 else if (proc_sym
->as
)
3545 tree result
= TREE_VALUE (current_fake_result_decl
);
3546 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
3548 /* An automatic character length, pointer array result. */
3549 if (proc_sym
->ts
.type
== BT_CHARACTER
3550 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3551 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3553 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
3555 if (proc_sym
->ts
.deferred
)
3558 gfc_save_backend_locus (&loc
);
3559 gfc_set_backend_locus (&proc_sym
->declared_at
);
3560 gfc_start_block (&init
);
3561 /* Zero the string length on entry. */
3562 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
3563 build_int_cst (gfc_charlen_type_node
, 0));
3564 /* Null the pointer. */
3565 e
= gfc_lval_expr_from_sym (proc_sym
);
3566 gfc_init_se (&se
, NULL
);
3567 se
.want_pointer
= 1;
3568 gfc_conv_expr (&se
, e
);
3571 gfc_add_modify (&init
, tmp
,
3572 fold_convert (TREE_TYPE (se
.expr
),
3573 null_pointer_node
));
3574 gfc_restore_backend_locus (&loc
);
3576 /* Pass back the string length on exit. */
3577 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
3578 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3579 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3580 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3581 gfc_charlen_type_node
, tmp
,
3582 proc_sym
->ts
.u
.cl
->backend_decl
);
3583 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3585 else if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3586 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3589 gcc_assert (gfc_option
.flag_f2c
3590 && proc_sym
->ts
.type
== BT_COMPLEX
);
3593 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3594 should be done here so that the offsets and lbounds of arrays
3596 gfc_save_backend_locus (&loc
);
3597 gfc_set_backend_locus (&proc_sym
->declared_at
);
3598 init_intent_out_dt (proc_sym
, block
);
3599 gfc_restore_backend_locus (&loc
);
3601 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
3603 bool sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
3604 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
3608 if (sym
->attr
.subref_array_pointer
3609 && GFC_DECL_SPAN (sym
->backend_decl
)
3610 && !TREE_STATIC (GFC_DECL_SPAN (sym
->backend_decl
)))
3612 gfc_init_block (&tmpblock
);
3613 gfc_add_modify (&tmpblock
, GFC_DECL_SPAN (sym
->backend_decl
),
3614 build_int_cst (gfc_array_index_type
, 0));
3615 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3619 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3621 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3622 array_type tmp
= sym
->as
->type
;
3623 if (tmp
== AS_ASSUMED_SIZE
&& sym
->as
->cp_was_assumed
)
3628 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3629 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3630 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3632 if (TREE_STATIC (sym
->backend_decl
))
3634 gfc_save_backend_locus (&loc
);
3635 gfc_set_backend_locus (&sym
->declared_at
);
3636 gfc_trans_static_array_pointer (sym
);
3637 gfc_restore_backend_locus (&loc
);
3641 seen_trans_deferred_array
= true;
3642 gfc_trans_deferred_array (sym
, block
);
3645 else if (sym
->attr
.codimension
&& TREE_STATIC (sym
->backend_decl
))
3647 gfc_init_block (&tmpblock
);
3648 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
3650 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3654 else if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
3656 gfc_save_backend_locus (&loc
);
3657 gfc_set_backend_locus (&sym
->declared_at
);
3659 if (sym_has_alloc_comp
)
3661 seen_trans_deferred_array
= true;
3662 gfc_trans_deferred_array (sym
, block
);
3664 else if (sym
->ts
.type
== BT_DERIVED
3667 && sym
->attr
.save
== SAVE_NONE
)
3669 gfc_start_block (&tmpblock
);
3670 gfc_init_default_dt (sym
, &tmpblock
, false);
3671 gfc_add_init_cleanup (block
,
3672 gfc_finish_block (&tmpblock
),
3676 gfc_trans_auto_array_allocation (sym
->backend_decl
,
3678 gfc_restore_backend_locus (&loc
);
3682 case AS_ASSUMED_SIZE
:
3683 /* Must be a dummy parameter. */
3684 gcc_assert (sym
->attr
.dummy
|| sym
->as
->cp_was_assumed
);
3686 /* We should always pass assumed size arrays the g77 way. */
3687 if (sym
->attr
.dummy
)
3688 gfc_trans_g77_array (sym
, block
);
3691 case AS_ASSUMED_SHAPE
:
3692 /* Must be a dummy parameter. */
3693 gcc_assert (sym
->attr
.dummy
);
3695 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3698 case AS_ASSUMED_RANK
:
3700 seen_trans_deferred_array
= true;
3701 gfc_trans_deferred_array (sym
, block
);
3707 if (sym_has_alloc_comp
&& !seen_trans_deferred_array
)
3708 gfc_trans_deferred_array (sym
, block
);
3710 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3711 && (sym
->ts
.type
== BT_CLASS
3712 && CLASS_DATA (sym
)->attr
.class_pointer
))
3714 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3715 && (sym
->attr
.allocatable
3716 || (sym
->ts
.type
== BT_CLASS
3717 && CLASS_DATA (sym
)->attr
.allocatable
)))
3719 if (!sym
->attr
.save
&& gfc_option
.flag_max_stack_var_size
!= 0)
3721 tree descriptor
= NULL_TREE
;
3723 /* Nullify and automatic deallocation of allocatable
3725 e
= gfc_lval_expr_from_sym (sym
);
3726 if (sym
->ts
.type
== BT_CLASS
)
3727 gfc_add_data_component (e
);
3729 gfc_init_se (&se
, NULL
);
3730 if (sym
->ts
.type
!= BT_CLASS
3731 || sym
->ts
.u
.derived
->attr
.dimension
3732 || sym
->ts
.u
.derived
->attr
.codimension
)
3734 se
.want_pointer
= 1;
3735 gfc_conv_expr (&se
, e
);
3737 else if (sym
->ts
.type
== BT_CLASS
3738 && !CLASS_DATA (sym
)->attr
.dimension
3739 && !CLASS_DATA (sym
)->attr
.codimension
)
3741 se
.want_pointer
= 1;
3742 gfc_conv_expr (&se
, e
);
3746 gfc_conv_expr (&se
, e
);
3747 descriptor
= se
.expr
;
3748 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
3749 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
3753 gfc_save_backend_locus (&loc
);
3754 gfc_set_backend_locus (&sym
->declared_at
);
3755 gfc_start_block (&init
);
3757 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3759 /* Nullify when entering the scope. */
3760 gfc_add_modify (&init
, se
.expr
,
3761 fold_convert (TREE_TYPE (se
.expr
),
3762 null_pointer_node
));
3765 if ((sym
->attr
.dummy
||sym
->attr
.result
)
3766 && sym
->ts
.type
== BT_CHARACTER
3767 && sym
->ts
.deferred
)
3769 /* Character length passed by reference. */
3770 tmp
= sym
->ts
.u
.cl
->passed_length
;
3771 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3772 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3774 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3775 /* Zero the string length when entering the scope. */
3776 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
,
3777 build_int_cst (gfc_charlen_type_node
, 0));
3779 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
3781 gfc_restore_backend_locus (&loc
);
3783 /* Pass the final character length back. */
3784 if (sym
->attr
.intent
!= INTENT_IN
)
3785 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3786 gfc_charlen_type_node
, tmp
,
3787 sym
->ts
.u
.cl
->backend_decl
);
3792 gfc_restore_backend_locus (&loc
);
3794 /* Deallocate when leaving the scope. Nullifying is not
3796 if (!sym
->attr
.result
&& !sym
->attr
.dummy
)
3798 if (sym
->ts
.type
== BT_CLASS
3799 && CLASS_DATA (sym
)->attr
.codimension
)
3800 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
3801 NULL_TREE
, NULL_TREE
,
3802 NULL_TREE
, true, NULL
,
3805 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, NULL_TREE
,
3807 gfc_lval_expr_from_sym (sym
),
3810 if (sym
->ts
.type
== BT_CLASS
)
3812 /* Initialize _vptr to declared type. */
3813 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3816 gfc_save_backend_locus (&loc
);
3817 gfc_set_backend_locus (&sym
->declared_at
);
3818 e
= gfc_lval_expr_from_sym (sym
);
3819 gfc_add_vptr_component (e
);
3820 gfc_init_se (&se
, NULL
);
3821 se
.want_pointer
= 1;
3822 gfc_conv_expr (&se
, e
);
3824 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
3825 gfc_get_symbol_decl (vtab
));
3826 gfc_add_modify (&init
, se
.expr
, rhs
);
3827 gfc_restore_backend_locus (&loc
);
3830 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3833 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
3838 /* If we get to here, all that should be left are pointers. */
3839 gcc_assert (sym
->attr
.pointer
);
3841 if (sym
->attr
.dummy
)
3843 gfc_start_block (&init
);
3845 /* Character length passed by reference. */
3846 tmp
= sym
->ts
.u
.cl
->passed_length
;
3847 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3848 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3849 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
3850 /* Pass the final character length back. */
3851 if (sym
->attr
.intent
!= INTENT_IN
)
3852 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3853 gfc_charlen_type_node
, tmp
,
3854 sym
->ts
.u
.cl
->backend_decl
);
3857 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3860 else if (sym
->ts
.deferred
)
3861 gfc_fatal_error ("Deferred type parameter not yet supported");
3862 else if (sym_has_alloc_comp
)
3863 gfc_trans_deferred_array (sym
, block
);
3864 else if (sym
->ts
.type
== BT_CHARACTER
)
3866 gfc_save_backend_locus (&loc
);
3867 gfc_set_backend_locus (&sym
->declared_at
);
3868 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3869 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
3871 gfc_trans_auto_character_variable (sym
, block
);
3872 gfc_restore_backend_locus (&loc
);
3874 else if (sym
->attr
.assign
)
3876 gfc_save_backend_locus (&loc
);
3877 gfc_set_backend_locus (&sym
->declared_at
);
3878 gfc_trans_assign_aux_var (sym
, block
);
3879 gfc_restore_backend_locus (&loc
);
3881 else if (sym
->ts
.type
== BT_DERIVED
3884 && sym
->attr
.save
== SAVE_NONE
)
3886 gfc_start_block (&tmpblock
);
3887 gfc_init_default_dt (sym
, &tmpblock
, false);
3888 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3895 gfc_init_block (&tmpblock
);
3897 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3899 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
3901 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3902 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3903 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
3907 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
3908 && current_fake_result_decl
!= NULL
)
3910 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3911 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3912 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
3915 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
3918 static GTY ((param_is (struct module_htab_entry
))) htab_t module_htab
;
3920 /* Hash and equality functions for module_htab. */
3923 module_htab_do_hash (const void *x
)
3925 return htab_hash_string (((const struct module_htab_entry
*)x
)->name
);
3929 module_htab_eq (const void *x1
, const void *x2
)
3931 return strcmp ((((const struct module_htab_entry
*)x1
)->name
),
3932 (const char *)x2
) == 0;
3935 /* Hash and equality functions for module_htab's decls. */
3938 module_htab_decls_hash (const void *x
)
3940 const_tree t
= (const_tree
) x
;
3941 const_tree n
= DECL_NAME (t
);
3943 n
= TYPE_NAME (TREE_TYPE (t
));
3944 return htab_hash_string (IDENTIFIER_POINTER (n
));
3948 module_htab_decls_eq (const void *x1
, const void *x2
)
3950 const_tree t1
= (const_tree
) x1
;
3951 const_tree n1
= DECL_NAME (t1
);
3952 if (n1
== NULL_TREE
)
3953 n1
= TYPE_NAME (TREE_TYPE (t1
));
3954 return strcmp (IDENTIFIER_POINTER (n1
), (const char *) x2
) == 0;
3957 struct module_htab_entry
*
3958 gfc_find_module (const char *name
)
3963 module_htab
= htab_create_ggc (10, module_htab_do_hash
,
3964 module_htab_eq
, NULL
);
3966 slot
= htab_find_slot_with_hash (module_htab
, name
,
3967 htab_hash_string (name
), INSERT
);
3970 struct module_htab_entry
*entry
= ggc_alloc_cleared_module_htab_entry ();
3972 entry
->name
= gfc_get_string (name
);
3973 entry
->decls
= htab_create_ggc (10, module_htab_decls_hash
,
3974 module_htab_decls_eq
, NULL
);
3975 *slot
= (void *) entry
;
3977 return (struct module_htab_entry
*) *slot
;
3981 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
3986 if (DECL_NAME (decl
))
3987 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
3990 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
3991 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
3993 slot
= htab_find_slot_with_hash (entry
->decls
, name
,
3994 htab_hash_string (name
), INSERT
);
3996 *slot
= (void *) decl
;
3999 static struct module_htab_entry
*cur_module
;
4001 /* Output an initialized decl for a module variable. */
4004 gfc_create_module_variable (gfc_symbol
* sym
)
4008 /* Module functions with alternate entries are dealt with later and
4009 would get caught by the next condition. */
4010 if (sym
->attr
.entry
)
4013 /* Make sure we convert the types of the derived types from iso_c_binding
4015 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4016 && sym
->ts
.type
== BT_DERIVED
)
4017 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4019 if (sym
->attr
.flavor
== FL_DERIVED
4020 && sym
->backend_decl
4021 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
4023 decl
= sym
->backend_decl
;
4024 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4026 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
4027 if (!(gfc_option
.flag_whole_file
&& sym
->attr
.use_assoc
))
4029 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
4030 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
4031 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
4032 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
4033 == sym
->ns
->proc_name
->backend_decl
);
4035 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4036 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
4037 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
4040 /* Only output variables, procedure pointers and array valued,
4041 or derived type, parameters. */
4042 if (sym
->attr
.flavor
!= FL_VARIABLE
4043 && !(sym
->attr
.flavor
== FL_PARAMETER
4044 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
4045 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4048 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
4050 decl
= sym
->backend_decl
;
4051 gcc_assert (DECL_FILE_SCOPE_P (decl
));
4052 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4053 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4054 gfc_module_add_decl (cur_module
, decl
);
4057 /* Don't generate variables from other modules. Variables from
4058 COMMONs will already have been generated. */
4059 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4062 /* Equivalenced variables arrive here after creation. */
4063 if (sym
->backend_decl
4064 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
4067 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
4068 internal_error ("backend decl for module variable %s already exists",
4071 /* We always want module variables to be created. */
4072 sym
->attr
.referenced
= 1;
4073 /* Create the decl. */
4074 decl
= gfc_get_symbol_decl (sym
);
4076 /* Create the variable. */
4078 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4079 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4080 rest_of_decl_compilation (decl
, 1, 0);
4081 gfc_module_add_decl (cur_module
, decl
);
4083 /* Also add length of strings. */
4084 if (sym
->ts
.type
== BT_CHARACTER
)
4088 length
= sym
->ts
.u
.cl
->backend_decl
;
4089 gcc_assert (length
|| sym
->attr
.proc_pointer
);
4090 if (length
&& !INTEGER_CST_P (length
))
4093 rest_of_decl_compilation (length
, 1, 0);
4097 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4098 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4099 has_coarray_vars
= true;
4102 /* Emit debug information for USE statements. */
4105 gfc_trans_use_stmts (gfc_namespace
* ns
)
4107 gfc_use_list
*use_stmt
;
4108 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
4110 struct module_htab_entry
*entry
4111 = gfc_find_module (use_stmt
->module_name
);
4112 gfc_use_rename
*rent
;
4114 if (entry
->namespace_decl
== NULL
)
4116 entry
->namespace_decl
4117 = build_decl (input_location
,
4119 get_identifier (use_stmt
->module_name
),
4121 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
4123 gfc_set_backend_locus (&use_stmt
->where
);
4124 if (!use_stmt
->only_flag
)
4125 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
4127 ns
->proc_name
->backend_decl
,
4129 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
4131 tree decl
, local_name
;
4134 if (rent
->op
!= INTRINSIC_NONE
)
4137 slot
= htab_find_slot_with_hash (entry
->decls
, rent
->use_name
,
4138 htab_hash_string (rent
->use_name
),
4144 st
= gfc_find_symtree (ns
->sym_root
,
4146 ? rent
->local_name
: rent
->use_name
);
4148 /* The following can happen if a derived type is renamed. */
4152 name
= xstrdup (rent
->local_name
[0]
4153 ? rent
->local_name
: rent
->use_name
);
4154 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
4155 st
= gfc_find_symtree (ns
->sym_root
, name
);
4160 /* Sometimes, generic interfaces wind up being over-ruled by a
4161 local symbol (see PR41062). */
4162 if (!st
->n
.sym
->attr
.use_assoc
)
4165 if (st
->n
.sym
->backend_decl
4166 && DECL_P (st
->n
.sym
->backend_decl
)
4167 && st
->n
.sym
->module
4168 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
4170 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
4171 || (TREE_CODE (st
->n
.sym
->backend_decl
)
4173 decl
= copy_node (st
->n
.sym
->backend_decl
);
4174 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4175 DECL_EXTERNAL (decl
) = 1;
4176 DECL_IGNORED_P (decl
) = 0;
4177 DECL_INITIAL (decl
) = NULL_TREE
;
4181 *slot
= error_mark_node
;
4182 htab_clear_slot (entry
->decls
, slot
);
4187 decl
= (tree
) *slot
;
4188 if (rent
->local_name
[0])
4189 local_name
= get_identifier (rent
->local_name
);
4191 local_name
= NULL_TREE
;
4192 gfc_set_backend_locus (&rent
->where
);
4193 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
4194 ns
->proc_name
->backend_decl
,
4195 !use_stmt
->only_flag
);
4201 /* Return true if expr is a constant initializer that gfc_conv_initializer
4205 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
4215 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
4217 else if (expr
->expr_type
== EXPR_STRUCTURE
)
4218 return check_constant_initializer (expr
, ts
, false, false);
4219 else if (expr
->expr_type
!= EXPR_ARRAY
)
4221 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4222 c
; c
= gfc_constructor_next (c
))
4226 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
4228 if (!check_constant_initializer (c
->expr
, ts
, false, false))
4231 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4236 else switch (ts
->type
)
4239 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4241 cm
= expr
->ts
.u
.derived
->components
;
4242 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4243 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4245 if (!c
->expr
|| cm
->attr
.allocatable
)
4247 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
4254 return expr
->expr_type
== EXPR_CONSTANT
;
4258 /* Emit debug info for parameters and unreferenced variables with
4262 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
4266 if (sym
->attr
.flavor
!= FL_PARAMETER
4267 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
4270 if (sym
->backend_decl
!= NULL
4271 || sym
->value
== NULL
4272 || sym
->attr
.use_assoc
4275 || sym
->attr
.function
4276 || sym
->attr
.intrinsic
4277 || sym
->attr
.pointer
4278 || sym
->attr
.allocatable
4279 || sym
->attr
.cray_pointee
4280 || sym
->attr
.threadprivate
4281 || sym
->attr
.is_bind_c
4282 || sym
->attr
.subref_array_pointer
4283 || sym
->attr
.assign
)
4286 if (sym
->ts
.type
== BT_CHARACTER
)
4288 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4289 if (sym
->ts
.u
.cl
->backend_decl
== NULL
4290 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
4293 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
4300 if (sym
->as
->type
!= AS_EXPLICIT
)
4302 for (n
= 0; n
< sym
->as
->rank
; n
++)
4303 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
4304 || sym
->as
->upper
[n
] == NULL
4305 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
4309 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
4310 sym
->attr
.dimension
, false))
4313 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
4316 /* Create the decl for the variable or constant. */
4317 decl
= build_decl (input_location
,
4318 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
4319 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
4320 if (sym
->attr
.flavor
== FL_PARAMETER
)
4321 TREE_READONLY (decl
) = 1;
4322 gfc_set_decl_location (decl
, &sym
->declared_at
);
4323 if (sym
->attr
.dimension
)
4324 GFC_DECL_PACKED_ARRAY (decl
) = 1;
4325 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4326 TREE_STATIC (decl
) = 1;
4327 TREE_USED (decl
) = 1;
4328 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
4329 TREE_PUBLIC (decl
) = 1;
4330 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
4332 sym
->attr
.dimension
,
4334 debug_hooks
->global_decl (decl
);
4339 generate_coarray_sym_init (gfc_symbol
*sym
)
4341 tree tmp
, size
, decl
, token
;
4343 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
4344 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
)
4347 decl
= sym
->backend_decl
;
4348 TREE_USED(decl
) = 1;
4349 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
4351 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4352 to make sure the variable is not optimized away. */
4353 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
4355 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
4357 /* Ensure that we do not have size=0 for zero-sized arrays. */
4358 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
4359 fold_convert (size_type_node
, size
),
4360 build_int_cst (size_type_node
, 1));
4362 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
4364 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
4365 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4366 fold_convert (size_type_node
, tmp
), size
);
4369 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
4370 token
= gfc_build_addr_expr (ppvoid_type_node
,
4371 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
4373 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 6, size
,
4374 build_int_cst (integer_type_node
,
4375 GFC_CAF_COARRAY_STATIC
), /* type. */
4376 token
, null_pointer_node
, /* token, stat. */
4377 null_pointer_node
, /* errgmsg, errmsg_len. */
4378 build_int_cst (integer_type_node
, 0));
4380 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
), tmp
));
4383 /* Handle "static" initializer. */
4386 sym
->attr
.pointer
= 1;
4387 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
4389 sym
->attr
.pointer
= 0;
4390 gfc_add_expr_to_block (&caf_init_block
, tmp
);
4395 /* Generate constructor function to initialize static, nonallocatable
4399 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
4401 tree fndecl
, tmp
, decl
, save_fn_decl
;
4403 save_fn_decl
= current_function_decl
;
4404 push_function_context ();
4406 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
4407 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
4408 create_tmp_var_name ("_caf_init"), tmp
);
4410 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
4411 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
4413 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
4414 DECL_ARTIFICIAL (decl
) = 1;
4415 DECL_IGNORED_P (decl
) = 1;
4416 DECL_CONTEXT (decl
) = fndecl
;
4417 DECL_RESULT (fndecl
) = decl
;
4420 current_function_decl
= fndecl
;
4421 announce_function (fndecl
);
4423 rest_of_decl_compilation (fndecl
, 0, 0);
4424 make_decl_rtl (fndecl
);
4425 allocate_struct_function (fndecl
, false);
4428 gfc_init_block (&caf_init_block
);
4430 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
4432 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
4436 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4438 DECL_SAVED_TREE (fndecl
)
4439 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4440 DECL_INITIAL (fndecl
));
4441 dump_function (TDI_original
, fndecl
);
4443 cfun
->function_end_locus
= input_location
;
4446 if (decl_function_context (fndecl
))
4447 (void) cgraph_create_node (fndecl
);
4449 cgraph_finalize_function (fndecl
, true);
4451 pop_function_context ();
4452 current_function_decl
= save_fn_decl
;
4456 /* Generate all the required code for module variables. */
4459 gfc_generate_module_vars (gfc_namespace
* ns
)
4461 module_namespace
= ns
;
4462 cur_module
= gfc_find_module (ns
->proc_name
->name
);
4464 /* Check if the frontend left the namespace in a reasonable state. */
4465 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
4467 /* Generate COMMON blocks. */
4468 gfc_trans_common (ns
);
4470 has_coarray_vars
= false;
4472 /* Create decls for all the module variables. */
4473 gfc_traverse_ns (ns
, gfc_create_module_variable
);
4475 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
4476 generate_coarray_init (ns
);
4480 gfc_trans_use_stmts (ns
);
4481 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
4486 gfc_generate_contained_functions (gfc_namespace
* parent
)
4490 /* We create all the prototypes before generating any code. */
4491 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4493 /* Skip namespaces from used modules. */
4494 if (ns
->parent
!= parent
)
4497 gfc_create_function_decl (ns
, false);
4500 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4502 /* Skip namespaces from used modules. */
4503 if (ns
->parent
!= parent
)
4506 gfc_generate_function_code (ns
);
4511 /* Drill down through expressions for the array specification bounds and
4512 character length calling generate_local_decl for all those variables
4513 that have not already been declared. */
4516 generate_local_decl (gfc_symbol
*);
4518 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4521 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
4522 int *f ATTRIBUTE_UNUSED
)
4524 if (e
->expr_type
!= EXPR_VARIABLE
4525 || sym
== e
->symtree
->n
.sym
4526 || e
->symtree
->n
.sym
->mark
4527 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
4530 generate_local_decl (e
->symtree
->n
.sym
);
4535 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
4537 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
4541 /* Check for dependencies in the character length and array spec. */
4544 generate_dependency_declarations (gfc_symbol
*sym
)
4548 if (sym
->ts
.type
== BT_CHARACTER
4550 && sym
->ts
.u
.cl
->length
4551 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4552 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
4554 if (sym
->as
&& sym
->as
->rank
)
4556 for (i
= 0; i
< sym
->as
->rank
; i
++)
4558 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
4559 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
4565 /* Generate decls for all local variables. We do this to ensure correct
4566 handling of expressions which only appear in the specification of
4570 generate_local_decl (gfc_symbol
* sym
)
4572 if (sym
->attr
.flavor
== FL_VARIABLE
)
4574 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4575 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4576 has_coarray_vars
= true;
4578 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
4579 generate_dependency_declarations (sym
);
4581 if (sym
->attr
.referenced
)
4582 gfc_get_symbol_decl (sym
);
4584 /* Warnings for unused dummy arguments. */
4585 else if (sym
->attr
.dummy
)
4587 /* INTENT(out) dummy arguments are likely meant to be set. */
4588 if (gfc_option
.warn_unused_dummy_argument
4589 && sym
->attr
.intent
== INTENT_OUT
)
4591 if (sym
->ts
.type
!= BT_DERIVED
)
4592 gfc_warning ("Dummy argument '%s' at %L was declared "
4593 "INTENT(OUT) but was not set", sym
->name
,
4595 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
))
4596 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4597 "declared INTENT(OUT) but was not set and "
4598 "does not have a default initializer",
4599 sym
->name
, &sym
->declared_at
);
4600 if (sym
->backend_decl
!= NULL_TREE
)
4601 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4603 else if (gfc_option
.warn_unused_dummy_argument
)
4605 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4607 if (sym
->backend_decl
!= NULL_TREE
)
4608 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4612 /* Warn for unused variables, but not if they're inside a common
4613 block or a namelist. */
4614 else if (warn_unused_variable
4615 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
4617 if (sym
->attr
.use_only
)
4619 gfc_warning ("Unused module variable '%s' which has been "
4620 "explicitly imported at %L", sym
->name
,
4622 if (sym
->backend_decl
!= NULL_TREE
)
4623 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4625 else if (!sym
->attr
.use_assoc
)
4627 gfc_warning ("Unused variable '%s' declared at %L",
4628 sym
->name
, &sym
->declared_at
);
4629 if (sym
->backend_decl
!= NULL_TREE
)
4630 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4634 /* For variable length CHARACTER parameters, the PARM_DECL already
4635 references the length variable, so force gfc_get_symbol_decl
4636 even when not referenced. If optimize > 0, it will be optimized
4637 away anyway. But do this only after emitting -Wunused-parameter
4638 warning if requested. */
4639 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
4640 && sym
->ts
.type
== BT_CHARACTER
4641 && sym
->ts
.u
.cl
->backend_decl
!= NULL
4642 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4644 sym
->attr
.referenced
= 1;
4645 gfc_get_symbol_decl (sym
);
4648 /* INTENT(out) dummy arguments and result variables with allocatable
4649 components are reset by default and need to be set referenced to
4650 generate the code for nullification and automatic lengths. */
4651 if (!sym
->attr
.referenced
4652 && sym
->ts
.type
== BT_DERIVED
4653 && sym
->ts
.u
.derived
->attr
.alloc_comp
4654 && !sym
->attr
.pointer
4655 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
4657 (sym
->attr
.result
&& sym
!= sym
->result
)))
4659 sym
->attr
.referenced
= 1;
4660 gfc_get_symbol_decl (sym
);
4663 /* Check for dependencies in the array specification and string
4664 length, adding the necessary declarations to the function. We
4665 mark the symbol now, as well as in traverse_ns, to prevent
4666 getting stuck in a circular dependency. */
4669 else if (sym
->attr
.flavor
== FL_PARAMETER
)
4671 if (warn_unused_parameter
4672 && !sym
->attr
.referenced
)
4674 if (!sym
->attr
.use_assoc
)
4675 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
4677 else if (sym
->attr
.use_only
)
4678 gfc_warning ("Unused parameter '%s' which has been explicitly "
4679 "imported at %L", sym
->name
, &sym
->declared_at
);
4682 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
4684 /* TODO: move to the appropriate place in resolve.c. */
4685 if (warn_return_type
4686 && sym
->attr
.function
4688 && sym
!= sym
->result
4689 && !sym
->result
->attr
.referenced
4690 && !sym
->attr
.use_assoc
4691 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
4693 gfc_warning ("Return value '%s' of function '%s' declared at "
4694 "%L not set", sym
->result
->name
, sym
->name
,
4695 &sym
->result
->declared_at
);
4697 /* Prevents "Unused variable" warning for RESULT variables. */
4698 sym
->result
->mark
= 1;
4702 if (sym
->attr
.dummy
== 1)
4704 /* Modify the tree type for scalar character dummy arguments of bind(c)
4705 procedures if they are passed by value. The tree type for them will
4706 be promoted to INTEGER_TYPE for the middle end, which appears to be
4707 what C would do with characters passed by-value. The value attribute
4708 implies the dummy is a scalar. */
4709 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
4710 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
4711 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
4712 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
4714 /* Unused procedure passed as dummy argument. */
4715 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4717 if (!sym
->attr
.referenced
)
4719 if (gfc_option
.warn_unused_dummy_argument
)
4720 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4724 /* Silence bogus "unused parameter" warnings from the
4726 if (sym
->backend_decl
!= NULL_TREE
)
4727 TREE_NO_WARNING (sym
->backend_decl
) = 1;
4731 /* Make sure we convert the types of the derived types from iso_c_binding
4733 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4734 && sym
->ts
.type
== BT_DERIVED
)
4735 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4739 generate_local_vars (gfc_namespace
* ns
)
4741 gfc_traverse_ns (ns
, generate_local_decl
);
4745 /* Generate a switch statement to jump to the correct entry point. Also
4746 creates the label decls for the entry points. */
4749 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
4756 gfc_init_block (&block
);
4757 for (; el
; el
= el
->next
)
4759 /* Add the case label. */
4760 label
= gfc_build_label_decl (NULL_TREE
);
4761 val
= build_int_cst (gfc_array_index_type
, el
->id
);
4762 tmp
= build_case_label (val
, NULL_TREE
, label
);
4763 gfc_add_expr_to_block (&block
, tmp
);
4765 /* And jump to the actual entry point. */
4766 label
= gfc_build_label_decl (NULL_TREE
);
4767 tmp
= build1_v (GOTO_EXPR
, label
);
4768 gfc_add_expr_to_block (&block
, tmp
);
4770 /* Save the label decl. */
4773 tmp
= gfc_finish_block (&block
);
4774 /* The first argument selects the entry point. */
4775 val
= DECL_ARGUMENTS (current_function_decl
);
4776 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
4777 val
, tmp
, NULL_TREE
);
4782 /* Add code to string lengths of actual arguments passed to a function against
4783 the expected lengths of the dummy arguments. */
4786 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
4788 gfc_formal_arglist
*formal
;
4790 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
4791 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
4792 && !formal
->sym
->ts
.deferred
)
4794 enum tree_code comparison
;
4799 const char *message
;
4805 gcc_assert (cl
->passed_length
!= NULL_TREE
);
4806 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
4808 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4809 string lengths must match exactly. Otherwise, it is only required
4810 that the actual string length is *at least* the expected one.
4811 Sequence association allows for a mismatch of the string length
4812 if the actual argument is (part of) an array, but only if the
4813 dummy argument is an array. (See "Sequence association" in
4814 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4815 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
4816 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
4817 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
4819 comparison
= NE_EXPR
;
4820 message
= _("Actual string length does not match the declared one"
4821 " for dummy argument '%s' (%ld/%ld)");
4823 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
4827 comparison
= LT_EXPR
;
4828 message
= _("Actual string length is shorter than the declared one"
4829 " for dummy argument '%s' (%ld/%ld)");
4832 /* Build the condition. For optional arguments, an actual length
4833 of 0 is also acceptable if the associated string is NULL, which
4834 means the argument was not passed. */
4835 cond
= fold_build2_loc (input_location
, comparison
, boolean_type_node
,
4836 cl
->passed_length
, cl
->backend_decl
);
4837 if (fsym
->attr
.optional
)
4843 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
4846 build_zero_cst (gfc_charlen_type_node
));
4847 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4848 fsym
->attr
.referenced
= 1;
4849 not_absent
= gfc_conv_expr_present (fsym
);
4851 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4852 boolean_type_node
, not_0length
,
4855 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4856 boolean_type_node
, cond
, absent_failed
);
4859 /* Build the runtime check. */
4860 argname
= gfc_build_cstring_const (fsym
->name
);
4861 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
4862 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
4864 fold_convert (long_integer_type_node
,
4866 fold_convert (long_integer_type_node
,
4872 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4873 global variables for -fcoarray=lib. They are placed into the translation
4874 unit of the main program. Make sure that in one TU (the one of the main
4875 program), the first call to gfc_init_coarray_decl is done with true.
4876 Otherwise, expect link errors. */
4879 gfc_init_coarray_decl (bool main_tu
)
4881 if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
4884 if (gfort_gvar_caf_this_image
|| gfort_gvar_caf_num_images
)
4889 gfort_gvar_caf_this_image
4890 = build_decl (input_location
, VAR_DECL
,
4891 get_identifier (PREFIX("caf_this_image")),
4893 DECL_ARTIFICIAL (gfort_gvar_caf_this_image
) = 1;
4894 TREE_USED (gfort_gvar_caf_this_image
) = 1;
4895 TREE_PUBLIC (gfort_gvar_caf_this_image
) = 1;
4896 TREE_READONLY (gfort_gvar_caf_this_image
) = 0;
4899 TREE_STATIC (gfort_gvar_caf_this_image
) = 1;
4901 DECL_EXTERNAL (gfort_gvar_caf_this_image
) = 1;
4903 pushdecl_top_level (gfort_gvar_caf_this_image
);
4905 gfort_gvar_caf_num_images
4906 = build_decl (input_location
, VAR_DECL
,
4907 get_identifier (PREFIX("caf_num_images")),
4909 DECL_ARTIFICIAL (gfort_gvar_caf_num_images
) = 1;
4910 TREE_USED (gfort_gvar_caf_num_images
) = 1;
4911 TREE_PUBLIC (gfort_gvar_caf_num_images
) = 1;
4912 TREE_READONLY (gfort_gvar_caf_num_images
) = 0;
4915 TREE_STATIC (gfort_gvar_caf_num_images
) = 1;
4917 DECL_EXTERNAL (gfort_gvar_caf_num_images
) = 1;
4919 pushdecl_top_level (gfort_gvar_caf_num_images
);
4926 create_main_function (tree fndecl
)
4930 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
4933 old_context
= current_function_decl
;
4937 push_function_context ();
4938 saved_parent_function_decls
= saved_function_decls
;
4939 saved_function_decls
= NULL_TREE
;
4942 /* main() function must be declared with global scope. */
4943 gcc_assert (current_function_decl
== NULL_TREE
);
4945 /* Declare the function. */
4946 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
4947 build_pointer_type (pchar_type_node
),
4949 main_identifier_node
= get_identifier ("main");
4950 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
4951 main_identifier_node
, tmp
);
4952 DECL_EXTERNAL (ftn_main
) = 0;
4953 TREE_PUBLIC (ftn_main
) = 1;
4954 TREE_STATIC (ftn_main
) = 1;
4955 DECL_ATTRIBUTES (ftn_main
)
4956 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
4958 /* Setup the result declaration (for "return 0"). */
4959 result_decl
= build_decl (input_location
,
4960 RESULT_DECL
, NULL_TREE
, integer_type_node
);
4961 DECL_ARTIFICIAL (result_decl
) = 1;
4962 DECL_IGNORED_P (result_decl
) = 1;
4963 DECL_CONTEXT (result_decl
) = ftn_main
;
4964 DECL_RESULT (ftn_main
) = result_decl
;
4966 pushdecl (ftn_main
);
4968 /* Get the arguments. */
4970 arglist
= NULL_TREE
;
4971 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
4973 tmp
= TREE_VALUE (typelist
);
4974 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
4975 DECL_CONTEXT (argc
) = ftn_main
;
4976 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
4977 TREE_READONLY (argc
) = 1;
4978 gfc_finish_decl (argc
);
4979 arglist
= chainon (arglist
, argc
);
4981 typelist
= TREE_CHAIN (typelist
);
4982 tmp
= TREE_VALUE (typelist
);
4983 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
4984 DECL_CONTEXT (argv
) = ftn_main
;
4985 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
4986 TREE_READONLY (argv
) = 1;
4987 DECL_BY_REFERENCE (argv
) = 1;
4988 gfc_finish_decl (argv
);
4989 arglist
= chainon (arglist
, argv
);
4991 DECL_ARGUMENTS (ftn_main
) = arglist
;
4992 current_function_decl
= ftn_main
;
4993 announce_function (ftn_main
);
4995 rest_of_decl_compilation (ftn_main
, 1, 0);
4996 make_decl_rtl (ftn_main
);
4997 allocate_struct_function (ftn_main
, false);
5000 gfc_init_block (&body
);
5002 /* Call some libgfortran initialization routines, call then MAIN__(). */
5004 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
5005 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5007 tree pint_type
, pppchar_type
;
5008 pint_type
= build_pointer_type (integer_type_node
);
5010 = build_pointer_type (build_pointer_type (pchar_type_node
));
5012 gfc_init_coarray_decl (true);
5013 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 4,
5014 gfc_build_addr_expr (pint_type
, argc
),
5015 gfc_build_addr_expr (pppchar_type
, argv
),
5016 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_this_image
),
5017 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_num_images
));
5018 gfc_add_expr_to_block (&body
, tmp
);
5021 /* Call _gfortran_set_args (argc, argv). */
5022 TREE_USED (argc
) = 1;
5023 TREE_USED (argv
) = 1;
5024 tmp
= build_call_expr_loc (input_location
,
5025 gfor_fndecl_set_args
, 2, argc
, argv
);
5026 gfc_add_expr_to_block (&body
, tmp
);
5028 /* Add a call to set_options to set up the runtime library Fortran
5029 language standard parameters. */
5031 tree array_type
, array
, var
;
5032 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5034 /* Passing a new option to the library requires four modifications:
5035 + add it to the tree_cons list below
5036 + change the array size in the call to build_array_type
5037 + change the first argument to the library call
5038 gfor_fndecl_set_options
5039 + modify the library (runtime/compile_options.c)! */
5041 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5042 build_int_cst (integer_type_node
,
5043 gfc_option
.warn_std
));
5044 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5045 build_int_cst (integer_type_node
,
5046 gfc_option
.allow_std
));
5047 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5048 build_int_cst (integer_type_node
, pedantic
));
5049 /* TODO: This is the old -fdump-core option, which is unused but
5050 passed due to ABI compatibility; remove when bumping the
5052 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5053 build_int_cst (integer_type_node
,
5055 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5056 build_int_cst (integer_type_node
,
5057 gfc_option
.flag_backtrace
));
5058 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5059 build_int_cst (integer_type_node
,
5060 gfc_option
.flag_sign_zero
));
5061 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5062 build_int_cst (integer_type_node
,
5064 & GFC_RTCHECK_BOUNDS
)));
5065 /* TODO: This is the -frange-check option, which no longer affects
5066 library behavior; when bumping the library ABI this slot can be
5067 reused for something else. As it is the last element in the
5068 array, we can instead leave it out altogether.
5069 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5070 build_int_cst (integer_type_node,
5071 gfc_option.flag_range_check));
5074 array_type
= build_array_type (integer_type_node
,
5075 build_index_type (size_int (6)));
5076 array
= build_constructor (array_type
, v
);
5077 TREE_CONSTANT (array
) = 1;
5078 TREE_STATIC (array
) = 1;
5080 /* Create a static variable to hold the jump table. */
5081 var
= gfc_create_var (array_type
, "options");
5082 TREE_CONSTANT (var
) = 1;
5083 TREE_STATIC (var
) = 1;
5084 TREE_READONLY (var
) = 1;
5085 DECL_INITIAL (var
) = array
;
5086 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
5088 tmp
= build_call_expr_loc (input_location
,
5089 gfor_fndecl_set_options
, 2,
5090 build_int_cst (integer_type_node
, 7), var
);
5091 gfc_add_expr_to_block (&body
, tmp
);
5094 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5095 the library will raise a FPE when needed. */
5096 if (gfc_option
.fpe
!= 0)
5098 tmp
= build_call_expr_loc (input_location
,
5099 gfor_fndecl_set_fpe
, 1,
5100 build_int_cst (integer_type_node
,
5102 gfc_add_expr_to_block (&body
, tmp
);
5105 /* If this is the main program and an -fconvert option was provided,
5106 add a call to set_convert. */
5108 if (gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
5110 tmp
= build_call_expr_loc (input_location
,
5111 gfor_fndecl_set_convert
, 1,
5112 build_int_cst (integer_type_node
,
5113 gfc_option
.convert
));
5114 gfc_add_expr_to_block (&body
, tmp
);
5117 /* If this is the main program and an -frecord-marker option was provided,
5118 add a call to set_record_marker. */
5120 if (gfc_option
.record_marker
!= 0)
5122 tmp
= build_call_expr_loc (input_location
,
5123 gfor_fndecl_set_record_marker
, 1,
5124 build_int_cst (integer_type_node
,
5125 gfc_option
.record_marker
));
5126 gfc_add_expr_to_block (&body
, tmp
);
5129 if (gfc_option
.max_subrecord_length
!= 0)
5131 tmp
= build_call_expr_loc (input_location
,
5132 gfor_fndecl_set_max_subrecord_length
, 1,
5133 build_int_cst (integer_type_node
,
5134 gfc_option
.max_subrecord_length
));
5135 gfc_add_expr_to_block (&body
, tmp
);
5138 /* Call MAIN__(). */
5139 tmp
= build_call_expr_loc (input_location
,
5141 gfc_add_expr_to_block (&body
, tmp
);
5143 /* Mark MAIN__ as used. */
5144 TREE_USED (fndecl
) = 1;
5146 /* Coarray: Call _gfortran_caf_finalize(void). */
5147 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5149 /* Per F2008, 8.5.1 END of the main program implies a
5151 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
5152 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
5153 gfc_add_expr_to_block (&body
, tmp
);
5155 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
5156 gfc_add_expr_to_block (&body
, tmp
);
5160 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
5161 DECL_RESULT (ftn_main
),
5162 build_int_cst (integer_type_node
, 0));
5163 tmp
= build1_v (RETURN_EXPR
, tmp
);
5164 gfc_add_expr_to_block (&body
, tmp
);
5167 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
5170 /* Finish off this function and send it for code generation. */
5172 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
5174 DECL_SAVED_TREE (ftn_main
)
5175 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
5176 DECL_INITIAL (ftn_main
));
5178 /* Output the GENERIC tree. */
5179 dump_function (TDI_original
, ftn_main
);
5181 cgraph_finalize_function (ftn_main
, true);
5185 pop_function_context ();
5186 saved_function_decls
= saved_parent_function_decls
;
5188 current_function_decl
= old_context
;
5192 /* Get the result expression for a procedure. */
5195 get_proc_result (gfc_symbol
* sym
)
5197 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
5199 if (current_fake_result_decl
!= NULL
)
5200 return TREE_VALUE (current_fake_result_decl
);
5205 return sym
->result
->backend_decl
;
5209 /* Generate an appropriate return-statement for a procedure. */
5212 gfc_generate_return (void)
5218 sym
= current_procedure_symbol
;
5219 fndecl
= sym
->backend_decl
;
5221 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
5225 result
= get_proc_result (sym
);
5227 /* Set the return value to the dummy result variable. The
5228 types may be different for scalar default REAL functions
5229 with -ff2c, therefore we have to convert. */
5230 if (result
!= NULL_TREE
)
5232 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
5233 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5234 TREE_TYPE (result
), DECL_RESULT (fndecl
),
5239 return build1_v (RETURN_EXPR
, result
);
5243 /* Generate code for a function. */
5246 gfc_generate_function_code (gfc_namespace
* ns
)
5252 stmtblock_t init
, cleanup
;
5254 gfc_wrapped_block try_block
;
5255 tree recurcheckvar
= NULL_TREE
;
5257 gfc_symbol
*previous_procedure_symbol
;
5261 sym
= ns
->proc_name
;
5262 previous_procedure_symbol
= current_procedure_symbol
;
5263 current_procedure_symbol
= sym
;
5265 /* Check that the frontend isn't still using this. */
5266 gcc_assert (sym
->tlink
== NULL
);
5269 /* Create the declaration for functions with global scope. */
5270 if (!sym
->backend_decl
)
5271 gfc_create_function_decl (ns
, false);
5273 fndecl
= sym
->backend_decl
;
5274 old_context
= current_function_decl
;
5278 push_function_context ();
5279 saved_parent_function_decls
= saved_function_decls
;
5280 saved_function_decls
= NULL_TREE
;
5283 trans_function_start (sym
);
5285 gfc_init_block (&init
);
5287 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
5289 /* Copy length backend_decls to all entry point result
5294 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
5295 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
5296 for (el
= ns
->entries
; el
; el
= el
->next
)
5297 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
5300 /* Translate COMMON blocks. */
5301 gfc_trans_common (ns
);
5303 /* Null the parent fake result declaration if this namespace is
5304 a module function or an external procedures. */
5305 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5306 || ns
->parent
== NULL
)
5307 parent_fake_result_decl
= NULL_TREE
;
5309 gfc_generate_contained_functions (ns
);
5311 nonlocal_dummy_decls
= NULL
;
5312 nonlocal_dummy_decl_pset
= NULL
;
5314 has_coarray_vars
= false;
5315 generate_local_vars (ns
);
5317 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5318 generate_coarray_init (ns
);
5320 /* Keep the parent fake result declaration in module functions
5321 or external procedures. */
5322 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5323 || ns
->parent
== NULL
)
5324 current_fake_result_decl
= parent_fake_result_decl
;
5326 current_fake_result_decl
= NULL_TREE
;
5328 is_recursive
= sym
->attr
.recursive
5329 || (sym
->attr
.entry_master
5330 && sym
->ns
->entries
->sym
->attr
.recursive
);
5331 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5333 && !gfc_option
.flag_recursive
)
5337 asprintf (&msg
, "Recursive call to nonrecursive procedure '%s'",
5339 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
5340 TREE_STATIC (recurcheckvar
) = 1;
5341 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
5342 gfc_add_expr_to_block (&init
, recurcheckvar
);
5343 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
5344 &sym
->declared_at
, msg
);
5345 gfc_add_modify (&init
, recurcheckvar
, boolean_true_node
);
5349 /* Now generate the code for the body of this function. */
5350 gfc_init_block (&body
);
5352 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
5353 && sym
->attr
.subroutine
)
5355 tree alternate_return
;
5356 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
5357 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
5362 /* Jump to the correct entry point. */
5363 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
5364 gfc_add_expr_to_block (&body
, tmp
);
5367 /* If bounds-checking is enabled, generate code to check passed in actual
5368 arguments against the expected dummy argument attributes (e.g. string
5370 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
5371 add_argument_checking (&body
, sym
);
5373 tmp
= gfc_trans_code (ns
->code
);
5374 gfc_add_expr_to_block (&body
, tmp
);
5376 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
5378 tree result
= get_proc_result (sym
);
5380 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
5382 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
5383 && sym
->result
== sym
)
5384 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
5385 null_pointer_node
));
5386 else if (sym
->ts
.type
== BT_CLASS
5387 && CLASS_DATA (sym
)->attr
.allocatable
5388 && CLASS_DATA (sym
)->attr
.dimension
== 0
5389 && sym
->result
== sym
)
5391 tmp
= CLASS_DATA (sym
)->backend_decl
;
5392 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5393 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
5394 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
5395 null_pointer_node
));
5397 else if (sym
->ts
.type
== BT_DERIVED
5398 && sym
->ts
.u
.derived
->attr
.alloc_comp
5399 && !sym
->attr
.allocatable
)
5401 rank
= sym
->as
? sym
->as
->rank
: 0;
5402 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, result
, rank
);
5403 gfc_add_expr_to_block (&init
, tmp
);
5407 if (result
== NULL_TREE
)
5409 /* TODO: move to the appropriate place in resolve.c. */
5410 if (warn_return_type
&& sym
== sym
->result
)
5411 gfc_warning ("Return value of function '%s' at %L not set",
5412 sym
->name
, &sym
->declared_at
);
5413 if (warn_return_type
)
5414 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5417 gfc_add_expr_to_block (&body
, gfc_generate_return ());
5420 gfc_init_block (&cleanup
);
5422 /* Reset recursion-check variable. */
5423 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5425 && !gfc_option
.gfc_flag_openmp
5426 && recurcheckvar
!= NULL_TREE
)
5428 gfc_add_modify (&cleanup
, recurcheckvar
, boolean_false_node
);
5429 recurcheckvar
= NULL
;
5432 /* Finish the function body and add init and cleanup code. */
5433 tmp
= gfc_finish_block (&body
);
5434 gfc_start_wrapped_block (&try_block
, tmp
);
5435 /* Add code to create and cleanup arrays. */
5436 gfc_trans_deferred_vars (sym
, &try_block
);
5437 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
5438 gfc_finish_block (&cleanup
));
5440 /* Add all the decls we created during processing. */
5441 decl
= saved_function_decls
;
5446 next
= DECL_CHAIN (decl
);
5447 DECL_CHAIN (decl
) = NULL_TREE
;
5451 saved_function_decls
= NULL_TREE
;
5453 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
5456 /* Finish off this function and send it for code generation. */
5458 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5460 DECL_SAVED_TREE (fndecl
)
5461 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5462 DECL_INITIAL (fndecl
));
5464 if (nonlocal_dummy_decls
)
5466 BLOCK_VARS (DECL_INITIAL (fndecl
))
5467 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
5468 pointer_set_destroy (nonlocal_dummy_decl_pset
);
5469 nonlocal_dummy_decls
= NULL
;
5470 nonlocal_dummy_decl_pset
= NULL
;
5473 /* Output the GENERIC tree. */
5474 dump_function (TDI_original
, fndecl
);
5476 /* Store the end of the function, so that we get good line number
5477 info for the epilogue. */
5478 cfun
->function_end_locus
= input_location
;
5480 /* We're leaving the context of this function, so zap cfun.
5481 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5482 tree_rest_of_compilation. */
5487 pop_function_context ();
5488 saved_function_decls
= saved_parent_function_decls
;
5490 current_function_decl
= old_context
;
5492 if (decl_function_context (fndecl
) && gfc_option
.coarray
!= GFC_FCOARRAY_LIB
5493 && has_coarray_vars
)
5494 /* Register this function with cgraph just far enough to get it
5495 added to our parent's nested function list.
5496 If there are static coarrays in this function, the nested _caf_init
5497 function has already called cgraph_create_node, which also created
5498 the cgraph node for this function. */
5499 (void) cgraph_create_node (fndecl
);
5501 cgraph_finalize_function (fndecl
, true);
5503 gfc_trans_use_stmts (ns
);
5504 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5506 if (sym
->attr
.is_main_program
)
5507 create_main_function (fndecl
);
5509 current_procedure_symbol
= previous_procedure_symbol
;
5514 gfc_generate_constructors (void)
5516 gcc_assert (gfc_static_ctors
== NULL_TREE
);
5524 if (gfc_static_ctors
== NULL_TREE
)
5527 fnname
= get_file_function_name ("I");
5528 type
= build_function_type_list (void_type_node
, NULL_TREE
);
5530 fndecl
= build_decl (input_location
,
5531 FUNCTION_DECL
, fnname
, type
);
5532 TREE_PUBLIC (fndecl
) = 1;
5534 decl
= build_decl (input_location
,
5535 RESULT_DECL
, NULL_TREE
, void_type_node
);
5536 DECL_ARTIFICIAL (decl
) = 1;
5537 DECL_IGNORED_P (decl
) = 1;
5538 DECL_CONTEXT (decl
) = fndecl
;
5539 DECL_RESULT (fndecl
) = decl
;
5543 current_function_decl
= fndecl
;
5545 rest_of_decl_compilation (fndecl
, 1, 0);
5547 make_decl_rtl (fndecl
);
5549 allocate_struct_function (fndecl
, false);
5553 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
5555 tmp
= build_call_expr_loc (input_location
,
5556 TREE_VALUE (gfc_static_ctors
), 0);
5557 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
5563 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5564 DECL_SAVED_TREE (fndecl
)
5565 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5566 DECL_INITIAL (fndecl
));
5568 free_after_parsing (cfun
);
5569 free_after_compilation (cfun
);
5571 tree_rest_of_compilation (fndecl
);
5573 current_function_decl
= NULL_TREE
;
5577 /* Translates a BLOCK DATA program unit. This means emitting the
5578 commons contained therein plus their initializations. We also emit
5579 a globally visible symbol to make sure that each BLOCK DATA program
5580 unit remains unique. */
5583 gfc_generate_block_data (gfc_namespace
* ns
)
5588 /* Tell the backend the source location of the block data. */
5590 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
5592 gfc_set_backend_locus (&gfc_current_locus
);
5594 /* Process the DATA statements. */
5595 gfc_trans_common (ns
);
5597 /* Create a global symbol with the mane of the block data. This is to
5598 generate linker errors if the same name is used twice. It is never
5601 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
5603 id
= get_identifier ("__BLOCK_DATA__");
5605 decl
= build_decl (input_location
,
5606 VAR_DECL
, id
, gfc_array_index_type
);
5607 TREE_PUBLIC (decl
) = 1;
5608 TREE_STATIC (decl
) = 1;
5609 DECL_IGNORED_P (decl
) = 1;
5612 rest_of_decl_compilation (decl
, 1, 0);
5616 /* Process the local variables of a BLOCK construct. */
5619 gfc_process_block_locals (gfc_namespace
* ns
)
5623 gcc_assert (saved_local_decls
== NULL_TREE
);
5624 has_coarray_vars
= false;
5626 generate_local_vars (ns
);
5628 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5629 generate_coarray_init (ns
);
5631 decl
= saved_local_decls
;
5636 next
= DECL_CHAIN (decl
);
5637 DECL_CHAIN (decl
) = NULL_TREE
;
5641 saved_local_decls
= NULL_TREE
;
5645 #include "gt-fortran-trans-decl.h"