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 /* The string length variable shall be in static memory if it is either
1093 explicitly SAVED, a module variable or with -fno-automatic. Only
1094 relevant is "len=:" - otherwise, it is either a constant length or
1095 it is an automatic variable. */
1096 bool static_length
= sym
->attr
.save
1097 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1098 || (gfc_option
.flag_max_stack_var_size
== 0
1099 && sym
->ts
.deferred
&& !sym
->attr
.dummy
1100 && !sym
->attr
.result
&& !sym
->attr
.function
);
1102 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1103 variables as some systems do not support the "." in the assembler name.
1104 For nonstatic variables, the "." does not appear in assembler. */
1108 name
= gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym
->module
,
1111 name
= gfc_get_string (GFC_PREFIX ("%s"), sym
->name
);
1113 else if (sym
->module
)
1114 name
= gfc_get_string (".__%s_MOD_%s", sym
->module
, sym
->name
);
1116 name
= gfc_get_string (".%s", sym
->name
);
1118 length
= build_decl (input_location
,
1119 VAR_DECL
, get_identifier (name
),
1120 gfc_charlen_type_node
);
1121 DECL_ARTIFICIAL (length
) = 1;
1122 TREE_USED (length
) = 1;
1123 if (sym
->ns
->proc_name
->tlink
!= NULL
)
1124 gfc_defer_symbol_init (sym
);
1126 sym
->ts
.u
.cl
->backend_decl
= length
;
1129 TREE_STATIC (length
) = 1;
1131 if (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1132 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->attr
.public_used
))
1133 TREE_PUBLIC (length
) = 1;
1136 gcc_assert (sym
->ts
.u
.cl
->backend_decl
!= NULL_TREE
);
1137 return sym
->ts
.u
.cl
->backend_decl
;
1140 /* If a variable is assigned a label, we add another two auxiliary
1144 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
1150 gcc_assert (sym
->backend_decl
);
1152 decl
= sym
->backend_decl
;
1153 gfc_allocate_lang_decl (decl
);
1154 GFC_DECL_ASSIGN (decl
) = 1;
1155 length
= build_decl (input_location
,
1156 VAR_DECL
, create_tmp_var_name (sym
->name
),
1157 gfc_charlen_type_node
);
1158 addr
= build_decl (input_location
,
1159 VAR_DECL
, create_tmp_var_name (sym
->name
),
1161 gfc_finish_var_decl (length
, sym
);
1162 gfc_finish_var_decl (addr
, sym
);
1163 /* STRING_LENGTH is also used as flag. Less than -1 means that
1164 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1165 target label's address. Otherwise, value is the length of a format string
1166 and ASSIGN_ADDR is its address. */
1167 if (TREE_STATIC (length
))
1168 DECL_INITIAL (length
) = build_int_cst (gfc_charlen_type_node
, -2);
1170 gfc_defer_symbol_init (sym
);
1172 GFC_DECL_STRING_LEN (decl
) = length
;
1173 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
1178 add_attributes_to_decl (symbol_attribute sym_attr
, tree list
)
1183 for (id
= 0; id
< EXT_ATTR_NUM
; id
++)
1184 if (sym_attr
.ext_attr
& (1 << id
))
1186 attr
= build_tree_list (
1187 get_identifier (ext_attr_list
[id
].middle_end_name
),
1189 list
= chainon (list
, attr
);
1196 static void build_function_decl (gfc_symbol
* sym
, bool global
);
1199 /* Return the decl for a gfc_symbol, create it if it doesn't already
1203 gfc_get_symbol_decl (gfc_symbol
* sym
)
1206 tree length
= NULL_TREE
;
1209 bool intrinsic_array_parameter
= false;
1211 gcc_assert (sym
->attr
.referenced
1212 || sym
->attr
.flavor
== FL_PROCEDURE
1213 || sym
->attr
.use_assoc
1214 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1215 || (sym
->module
&& sym
->attr
.if_source
!= IFSRC_DECL
1216 && sym
->backend_decl
));
1218 if (sym
->ns
&& sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.function
)
1219 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
1223 /* Make sure that the vtab for the declared type is completed. */
1224 if (sym
->ts
.type
== BT_CLASS
)
1226 gfc_component
*c
= CLASS_DATA (sym
);
1227 if (!c
->ts
.u
.derived
->backend_decl
)
1229 gfc_find_derived_vtab (c
->ts
.u
.derived
);
1230 gfc_get_derived_type (sym
->ts
.u
.derived
);
1234 /* All deferred character length procedures need to retain the backend
1235 decl, which is a pointer to the character length in the caller's
1236 namespace and to declare a local character length. */
1237 if (!byref
&& sym
->attr
.function
1238 && sym
->ts
.type
== BT_CHARACTER
1240 && sym
->ts
.u
.cl
->passed_length
== NULL
1241 && sym
->ts
.u
.cl
->backend_decl
1242 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
1244 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1245 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1246 length
= gfc_create_string_length (sym
);
1249 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
1251 /* Return via extra parameter. */
1252 if (sym
->attr
.result
&& byref
1253 && !sym
->backend_decl
)
1256 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
1257 /* For entry master function skip over the __entry
1259 if (sym
->ns
->proc_name
->attr
.entry_master
)
1260 sym
->backend_decl
= DECL_CHAIN (sym
->backend_decl
);
1263 /* Dummy variables should already have been created. */
1264 gcc_assert (sym
->backend_decl
);
1266 /* Create a character length variable. */
1267 if (sym
->ts
.type
== BT_CHARACTER
)
1269 /* For a deferred dummy, make a new string length variable. */
1270 if (sym
->ts
.deferred
1272 (sym
->ts
.u
.cl
->passed_length
== sym
->ts
.u
.cl
->backend_decl
))
1273 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1275 if (sym
->ts
.deferred
&& sym
->attr
.result
1276 && sym
->ts
.u
.cl
->passed_length
== NULL
1277 && sym
->ts
.u
.cl
->backend_decl
)
1279 sym
->ts
.u
.cl
->passed_length
= sym
->ts
.u
.cl
->backend_decl
;
1280 sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
1283 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
1284 length
= gfc_create_string_length (sym
);
1286 length
= sym
->ts
.u
.cl
->backend_decl
;
1287 if (TREE_CODE (length
) == VAR_DECL
1288 && DECL_FILE_SCOPE_P (length
))
1290 /* Add the string length to the same context as the symbol. */
1291 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
1292 gfc_add_decl_to_function (length
);
1294 gfc_add_decl_to_parent_function (length
);
1296 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
1297 DECL_CONTEXT (length
));
1299 gfc_defer_symbol_init (sym
);
1303 /* Use a copy of the descriptor for dummy arrays. */
1304 if ((sym
->attr
.dimension
|| sym
->attr
.codimension
)
1305 && !TREE_USED (sym
->backend_decl
))
1307 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
1308 /* Prevent the dummy from being detected as unused if it is copied. */
1309 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
1310 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
1311 sym
->backend_decl
= decl
;
1314 TREE_USED (sym
->backend_decl
) = 1;
1315 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
1317 gfc_add_assign_aux_vars (sym
);
1320 if (sym
->attr
.dimension
1321 && DECL_LANG_SPECIFIC (sym
->backend_decl
)
1322 && GFC_DECL_SAVED_DESCRIPTOR (sym
->backend_decl
)
1323 && DECL_CONTEXT (sym
->backend_decl
) != current_function_decl
)
1324 gfc_nonlocal_dummy_array_decl (sym
);
1326 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1327 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1329 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1330 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1331 return sym
->backend_decl
;
1334 if (sym
->backend_decl
)
1335 return sym
->backend_decl
;
1337 /* Special case for array-valued named constants from intrinsic
1338 procedures; those are inlined. */
1339 if (sym
->attr
.use_assoc
&& sym
->from_intmod
1340 && sym
->attr
.flavor
== FL_PARAMETER
)
1341 intrinsic_array_parameter
= true;
1343 /* If use associated and whole file compilation, use the module
1345 if (gfc_option
.flag_whole_file
1346 && (sym
->attr
.flavor
== FL_VARIABLE
1347 || sym
->attr
.flavor
== FL_PARAMETER
)
1348 && sym
->attr
.use_assoc
1349 && !intrinsic_array_parameter
1351 && gfc_get_module_backend_decl (sym
))
1353 if (sym
->ts
.type
== BT_CLASS
&& sym
->backend_decl
)
1354 GFC_DECL_CLASS(sym
->backend_decl
) = 1;
1355 return sym
->backend_decl
;
1358 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1360 /* Catch function declarations. Only used for actual parameters,
1361 procedure pointers and procptr initialization targets. */
1362 if (sym
->attr
.external
|| sym
->attr
.use_assoc
|| sym
->attr
.intrinsic
)
1364 decl
= gfc_get_extern_function_decl (sym
);
1365 gfc_set_decl_location (decl
, &sym
->declared_at
);
1369 if (!sym
->backend_decl
)
1370 build_function_decl (sym
, false);
1371 decl
= sym
->backend_decl
;
1376 if (sym
->attr
.intrinsic
)
1377 internal_error ("intrinsic variable which isn't a procedure");
1379 /* Create string length decl first so that they can be used in the
1380 type declaration. */
1381 if (sym
->ts
.type
== BT_CHARACTER
)
1382 length
= gfc_create_string_length (sym
);
1384 /* Create the decl for the variable. */
1385 decl
= build_decl (sym
->declared_at
.lb
->location
,
1386 VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
1388 /* Add attributes to variables. Functions are handled elsewhere. */
1389 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1390 decl_attributes (&decl
, attributes
, 0);
1392 /* Symbols from modules should have their assembler names mangled.
1393 This is done here rather than in gfc_finish_var_decl because it
1394 is different for string length variables. */
1397 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1398 if (sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1399 DECL_IGNORED_P (decl
) = 1;
1402 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
1404 /* Create variables to hold the non-constant bits of array info. */
1405 gfc_build_qualified_array (decl
, sym
);
1407 if (sym
->attr
.contiguous
1408 || ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
))
1409 GFC_DECL_PACKED_ARRAY (decl
) = 1;
1412 /* Remember this variable for allocation/cleanup. */
1413 if (sym
->attr
.dimension
|| sym
->attr
.allocatable
|| sym
->attr
.codimension
1414 || (sym
->ts
.type
== BT_CLASS
&&
1415 (CLASS_DATA (sym
)->attr
.dimension
1416 || CLASS_DATA (sym
)->attr
.allocatable
))
1417 || (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
1418 /* This applies a derived type default initializer. */
1419 || (sym
->ts
.type
== BT_DERIVED
1420 && sym
->attr
.save
== SAVE_NONE
1422 && !sym
->attr
.allocatable
1423 && (sym
->value
&& !sym
->ns
->proc_name
->attr
.is_main_program
)
1424 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)))
1425 gfc_defer_symbol_init (sym
);
1427 gfc_finish_var_decl (decl
, sym
);
1429 if (sym
->ts
.type
== BT_CHARACTER
)
1431 /* Character variables need special handling. */
1432 gfc_allocate_lang_decl (decl
);
1434 if (TREE_CODE (length
) != INTEGER_CST
)
1436 gfc_finish_var_decl (length
, sym
);
1437 gcc_assert (!sym
->value
);
1440 else if (sym
->attr
.subref_array_pointer
)
1442 /* We need the span for these beasts. */
1443 gfc_allocate_lang_decl (decl
);
1446 if (sym
->attr
.subref_array_pointer
)
1449 GFC_DECL_SUBREF_ARRAY_P (decl
) = 1;
1450 span
= build_decl (input_location
,
1451 VAR_DECL
, create_tmp_var_name ("span"),
1452 gfc_array_index_type
);
1453 gfc_finish_var_decl (span
, sym
);
1454 TREE_STATIC (span
) = TREE_STATIC (decl
);
1455 DECL_ARTIFICIAL (span
) = 1;
1457 GFC_DECL_SPAN (decl
) = span
;
1458 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl
)) = span
;
1461 if (sym
->ts
.type
== BT_CLASS
)
1462 GFC_DECL_CLASS(decl
) = 1;
1464 sym
->backend_decl
= decl
;
1466 if (sym
->attr
.assign
)
1467 gfc_add_assign_aux_vars (sym
);
1469 if (intrinsic_array_parameter
)
1471 TREE_STATIC (decl
) = 1;
1472 DECL_EXTERNAL (decl
) = 0;
1475 if (TREE_STATIC (decl
)
1476 && !(sym
->attr
.use_assoc
&& !intrinsic_array_parameter
)
1477 && (sym
->attr
.save
|| sym
->ns
->proc_name
->attr
.is_main_program
1478 || gfc_option
.flag_max_stack_var_size
== 0
1479 || sym
->attr
.data
|| sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1480 && (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
1481 || !sym
->attr
.codimension
|| sym
->attr
.allocatable
))
1483 /* Add static initializer. For procedures, it is only needed if
1484 SAVE is specified otherwise they need to be reinitialized
1485 every time the procedure is entered. The TREE_STATIC is
1486 in this case due to -fmax-stack-var-size=. */
1487 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1490 || (sym
->attr
.codimension
1491 && sym
->attr
.allocatable
),
1493 || sym
->attr
.allocatable
,
1494 sym
->attr
.proc_pointer
);
1497 if (!TREE_STATIC (decl
)
1498 && POINTER_TYPE_P (TREE_TYPE (decl
))
1499 && !sym
->attr
.pointer
1500 && !sym
->attr
.allocatable
1501 && !sym
->attr
.proc_pointer
)
1502 DECL_BY_REFERENCE (decl
) = 1;
1505 || (sym
->name
[0] == '_' && strncmp ("__def_init", sym
->name
, 10) == 0))
1506 TREE_READONLY (decl
) = 1;
1512 /* Substitute a temporary variable in place of the real one. */
1515 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1517 save
->attr
= sym
->attr
;
1518 save
->decl
= sym
->backend_decl
;
1520 gfc_clear_attr (&sym
->attr
);
1521 sym
->attr
.referenced
= 1;
1522 sym
->attr
.flavor
= FL_VARIABLE
;
1524 sym
->backend_decl
= decl
;
1528 /* Restore the original variable. */
1531 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1533 sym
->attr
= save
->attr
;
1534 sym
->backend_decl
= save
->decl
;
1538 /* Declare a procedure pointer. */
1541 get_proc_pointer_decl (gfc_symbol
*sym
)
1546 decl
= sym
->backend_decl
;
1550 decl
= build_decl (input_location
,
1551 VAR_DECL
, get_identifier (sym
->name
),
1552 build_pointer_type (gfc_get_function_type (sym
)));
1556 /* Apply name mangling. */
1557 gfc_set_decl_assembler_name (decl
, gfc_sym_mangled_identifier (sym
));
1558 if (sym
->attr
.use_assoc
)
1559 DECL_IGNORED_P (decl
) = 1;
1562 if ((sym
->ns
->proc_name
1563 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
1564 || sym
->attr
.contained
)
1565 gfc_add_decl_to_function (decl
);
1566 else if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1567 gfc_add_decl_to_parent_function (decl
);
1569 sym
->backend_decl
= decl
;
1571 /* If a variable is USE associated, it's always external. */
1572 if (sym
->attr
.use_assoc
)
1574 DECL_EXTERNAL (decl
) = 1;
1575 TREE_PUBLIC (decl
) = 1;
1577 else if (sym
->module
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1579 /* This is the declaration of a module variable. */
1580 TREE_PUBLIC (decl
) = 1;
1581 TREE_STATIC (decl
) = 1;
1584 if (!sym
->attr
.use_assoc
1585 && (sym
->attr
.save
!= SAVE_NONE
|| sym
->attr
.data
1586 || (sym
->value
&& sym
->ns
->proc_name
->attr
.is_main_program
)))
1587 TREE_STATIC (decl
) = 1;
1589 if (TREE_STATIC (decl
) && sym
->value
)
1591 /* Add static initializer. */
1592 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1594 sym
->attr
.dimension
,
1598 /* Handle threadprivate procedure pointers. */
1599 if (sym
->attr
.threadprivate
1600 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
1601 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
1603 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1604 decl_attributes (&decl
, attributes
, 0);
1610 /* Get a basic decl for an external function. */
1613 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1619 gfc_intrinsic_sym
*isym
;
1621 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1626 if (sym
->backend_decl
)
1627 return sym
->backend_decl
;
1629 /* We should never be creating external decls for alternate entry points.
1630 The procedure may be an alternate entry point, but we don't want/need
1632 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1634 if (sym
->attr
.proc_pointer
)
1635 return get_proc_pointer_decl (sym
);
1637 /* See if this is an external procedure from the same file. If so,
1638 return the backend_decl. */
1639 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
1641 if (gfc_option
.flag_whole_file
1642 && (!sym
->attr
.use_assoc
|| sym
->attr
.if_source
!= IFSRC_DECL
)
1643 && !sym
->backend_decl
1645 && ((gsym
->type
== GSYM_SUBROUTINE
) || (gsym
->type
== GSYM_FUNCTION
))
1646 && (gsym
->ns
->proc_name
->backend_decl
|| !sym
->attr
.intrinsic
))
1648 if (!gsym
->ns
->proc_name
->backend_decl
)
1650 /* By construction, the external function cannot be
1651 a contained procedure. */
1654 gfc_save_backend_locus (&old_loc
);
1657 gfc_create_function_decl (gsym
->ns
, true);
1660 gfc_restore_backend_locus (&old_loc
);
1663 /* If the namespace has entries, the proc_name is the
1664 entry master. Find the entry and use its backend_decl.
1665 otherwise, use the proc_name backend_decl. */
1666 if (gsym
->ns
->entries
)
1668 gfc_entry_list
*entry
= gsym
->ns
->entries
;
1670 for (; entry
; entry
= entry
->next
)
1672 if (strcmp (gsym
->name
, entry
->sym
->name
) == 0)
1674 sym
->backend_decl
= entry
->sym
->backend_decl
;
1680 sym
->backend_decl
= gsym
->ns
->proc_name
->backend_decl
;
1682 if (sym
->backend_decl
)
1684 /* Avoid problems of double deallocation of the backend declaration
1685 later in gfc_trans_use_stmts; cf. PR 45087. */
1686 if (sym
->attr
.if_source
!= IFSRC_DECL
&& sym
->attr
.use_assoc
)
1687 sym
->attr
.use_assoc
= 0;
1689 return sym
->backend_decl
;
1693 /* See if this is a module procedure from the same file. If so,
1694 return the backend_decl. */
1696 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->module
);
1698 if (gfc_option
.flag_whole_file
1700 && gsym
->type
== GSYM_MODULE
)
1705 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &s
);
1706 if (s
&& s
->backend_decl
)
1708 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1709 gfc_copy_dt_decls_ifequal (s
->ts
.u
.derived
, sym
->ts
.u
.derived
,
1711 else if (sym
->ts
.type
== BT_CHARACTER
)
1712 sym
->ts
.u
.cl
->backend_decl
= s
->ts
.u
.cl
->backend_decl
;
1713 sym
->backend_decl
= s
->backend_decl
;
1714 return sym
->backend_decl
;
1718 if (sym
->attr
.intrinsic
)
1720 /* Call the resolution function to get the actual name. This is
1721 a nasty hack which relies on the resolution functions only looking
1722 at the first argument. We pass NULL for the second argument
1723 otherwise things like AINT get confused. */
1724 isym
= gfc_find_function (sym
->name
);
1725 gcc_assert (isym
->resolve
.f0
!= NULL
);
1727 memset (&e
, 0, sizeof (e
));
1728 e
.expr_type
= EXPR_FUNCTION
;
1730 memset (&argexpr
, 0, sizeof (argexpr
));
1731 gcc_assert (isym
->formal
);
1732 argexpr
.ts
= isym
->formal
->ts
;
1734 if (isym
->formal
->next
== NULL
)
1735 isym
->resolve
.f1 (&e
, &argexpr
);
1738 if (isym
->formal
->next
->next
== NULL
)
1739 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1742 if (isym
->formal
->next
->next
->next
== NULL
)
1743 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1746 /* All specific intrinsics take less than 5 arguments. */
1747 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1748 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1753 if (gfc_option
.flag_f2c
1754 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1755 || e
.ts
.type
== BT_COMPLEX
))
1757 /* Specific which needs a different implementation if f2c
1758 calling conventions are used. */
1759 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1762 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1764 name
= get_identifier (s
);
1765 mangled_name
= name
;
1769 name
= gfc_sym_identifier (sym
);
1770 mangled_name
= gfc_sym_mangled_function_id (sym
);
1773 type
= gfc_get_function_type (sym
);
1774 fndecl
= build_decl (input_location
,
1775 FUNCTION_DECL
, name
, type
);
1777 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1778 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1779 the opposite of declaring a function as static in C). */
1780 DECL_EXTERNAL (fndecl
) = 1;
1781 TREE_PUBLIC (fndecl
) = 1;
1783 attributes
= add_attributes_to_decl (sym
->attr
, NULL_TREE
);
1784 decl_attributes (&fndecl
, attributes
, 0);
1786 gfc_set_decl_assembler_name (fndecl
, mangled_name
);
1788 /* Set the context of this decl. */
1789 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1791 /* TODO: Add external decls to the appropriate scope. */
1792 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1796 /* Global declaration, e.g. intrinsic subroutine. */
1797 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1800 /* Set attributes for PURE functions. A call to PURE function in the
1801 Fortran 95 sense is both pure and without side effects in the C
1803 if (sym
->attr
.pure
|| sym
->attr
.implicit_pure
)
1805 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1806 DECL_PURE_P (fndecl
) = 1;
1807 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1808 parameters and don't use alternate returns (is this
1809 allowed?). In that case, calls to them are meaningless, and
1810 can be optimized away. See also in build_function_decl(). */
1811 TREE_SIDE_EFFECTS (fndecl
) = 0;
1814 /* Mark non-returning functions. */
1815 if (sym
->attr
.noreturn
)
1816 TREE_THIS_VOLATILE(fndecl
) = 1;
1818 sym
->backend_decl
= fndecl
;
1820 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1821 pushdecl_top_level (fndecl
);
1827 /* Create a declaration for a procedure. For external functions (in the C
1828 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1829 a master function with alternate entry points. */
1832 build_function_decl (gfc_symbol
* sym
, bool global
)
1834 tree fndecl
, type
, attributes
;
1835 symbol_attribute attr
;
1837 gfc_formal_arglist
*f
;
1839 gcc_assert (!sym
->attr
.external
);
1841 if (sym
->backend_decl
)
1844 /* Set the line and filename. sym->declared_at seems to point to the
1845 last statement for subroutines, but it'll do for now. */
1846 gfc_set_backend_locus (&sym
->declared_at
);
1848 /* Allow only one nesting level. Allow public declarations. */
1849 gcc_assert (current_function_decl
== NULL_TREE
1850 || DECL_FILE_SCOPE_P (current_function_decl
)
1851 || (TREE_CODE (DECL_CONTEXT (current_function_decl
))
1852 == NAMESPACE_DECL
));
1854 type
= gfc_get_function_type (sym
);
1855 fndecl
= build_decl (input_location
,
1856 FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1860 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1861 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1862 the opposite of declaring a function as static in C). */
1863 DECL_EXTERNAL (fndecl
) = 0;
1865 if (sym
->attr
.access
== ACCESS_UNKNOWN
&& sym
->module
1866 && (sym
->ns
->default_access
== ACCESS_PRIVATE
1867 || (sym
->ns
->default_access
== ACCESS_UNKNOWN
1868 && gfc_option
.flag_module_private
)))
1869 sym
->attr
.access
= ACCESS_PRIVATE
;
1871 if (!current_function_decl
1872 && !sym
->attr
.entry_master
&& !sym
->attr
.is_main_program
1873 && (sym
->attr
.access
!= ACCESS_PRIVATE
|| sym
->binding_label
1874 || sym
->attr
.public_used
))
1875 TREE_PUBLIC (fndecl
) = 1;
1877 if (sym
->attr
.referenced
|| sym
->attr
.entry_master
)
1878 TREE_USED (fndecl
) = 1;
1880 attributes
= add_attributes_to_decl (attr
, NULL_TREE
);
1881 decl_attributes (&fndecl
, attributes
, 0);
1883 /* Figure out the return type of the declared function, and build a
1884 RESULT_DECL for it. If this is a subroutine with alternate
1885 returns, build a RESULT_DECL for it. */
1886 result_decl
= NULL_TREE
;
1887 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1890 if (gfc_return_by_reference (sym
))
1891 type
= void_type_node
;
1894 if (sym
->result
!= sym
)
1895 result_decl
= gfc_sym_identifier (sym
->result
);
1897 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1902 /* Look for alternate return placeholders. */
1903 int has_alternate_returns
= 0;
1904 for (f
= sym
->formal
; f
; f
= f
->next
)
1908 has_alternate_returns
= 1;
1913 if (has_alternate_returns
)
1914 type
= integer_type_node
;
1916 type
= void_type_node
;
1919 result_decl
= build_decl (input_location
,
1920 RESULT_DECL
, result_decl
, type
);
1921 DECL_ARTIFICIAL (result_decl
) = 1;
1922 DECL_IGNORED_P (result_decl
) = 1;
1923 DECL_CONTEXT (result_decl
) = fndecl
;
1924 DECL_RESULT (fndecl
) = result_decl
;
1926 /* Don't call layout_decl for a RESULT_DECL.
1927 layout_decl (result_decl, 0); */
1929 /* TREE_STATIC means the function body is defined here. */
1930 TREE_STATIC (fndecl
) = 1;
1932 /* Set attributes for PURE functions. A call to a PURE function in the
1933 Fortran 95 sense is both pure and without side effects in the C
1935 if (attr
.pure
|| attr
.implicit_pure
)
1937 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1938 including an alternate return. In that case it can also be
1939 marked as PURE. See also in gfc_get_extern_function_decl(). */
1940 if (attr
.function
&& !gfc_return_by_reference (sym
))
1941 DECL_PURE_P (fndecl
) = 1;
1942 TREE_SIDE_EFFECTS (fndecl
) = 0;
1946 /* Layout the function declaration and put it in the binding level
1947 of the current function. */
1950 pushdecl_top_level (fndecl
);
1954 /* Perform name mangling if this is a top level or module procedure. */
1955 if (current_function_decl
== NULL_TREE
)
1956 gfc_set_decl_assembler_name (fndecl
, gfc_sym_mangled_function_id (sym
));
1958 sym
->backend_decl
= fndecl
;
1962 /* Create the DECL_ARGUMENTS for a procedure. */
1965 create_function_arglist (gfc_symbol
* sym
)
1968 gfc_formal_arglist
*f
;
1969 tree typelist
, hidden_typelist
;
1970 tree arglist
, hidden_arglist
;
1974 fndecl
= sym
->backend_decl
;
1976 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1977 the new FUNCTION_DECL node. */
1978 arglist
= NULL_TREE
;
1979 hidden_arglist
= NULL_TREE
;
1980 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1982 if (sym
->attr
.entry_master
)
1984 type
= TREE_VALUE (typelist
);
1985 parm
= build_decl (input_location
,
1986 PARM_DECL
, get_identifier ("__entry"), type
);
1988 DECL_CONTEXT (parm
) = fndecl
;
1989 DECL_ARG_TYPE (parm
) = type
;
1990 TREE_READONLY (parm
) = 1;
1991 gfc_finish_decl (parm
);
1992 DECL_ARTIFICIAL (parm
) = 1;
1994 arglist
= chainon (arglist
, parm
);
1995 typelist
= TREE_CHAIN (typelist
);
1998 if (gfc_return_by_reference (sym
))
2000 tree type
= TREE_VALUE (typelist
), length
= NULL
;
2002 if (sym
->ts
.type
== BT_CHARACTER
)
2004 /* Length of character result. */
2005 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
2007 length
= build_decl (input_location
,
2009 get_identifier (".__result"),
2011 if (!sym
->ts
.u
.cl
->length
)
2013 sym
->ts
.u
.cl
->backend_decl
= length
;
2014 TREE_USED (length
) = 1;
2016 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
2017 DECL_CONTEXT (length
) = fndecl
;
2018 DECL_ARG_TYPE (length
) = len_type
;
2019 TREE_READONLY (length
) = 1;
2020 DECL_ARTIFICIAL (length
) = 1;
2021 gfc_finish_decl (length
);
2022 if (sym
->ts
.u
.cl
->backend_decl
== NULL
2023 || sym
->ts
.u
.cl
->backend_decl
== length
)
2028 if (sym
->ts
.u
.cl
->backend_decl
== NULL
)
2030 tree len
= build_decl (input_location
,
2032 get_identifier ("..__result"),
2033 gfc_charlen_type_node
);
2034 DECL_ARTIFICIAL (len
) = 1;
2035 TREE_USED (len
) = 1;
2036 sym
->ts
.u
.cl
->backend_decl
= len
;
2039 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2040 arg
= sym
->result
? sym
->result
: sym
;
2041 backend_decl
= arg
->backend_decl
;
2042 /* Temporary clear it, so that gfc_sym_type creates complete
2044 arg
->backend_decl
= NULL
;
2045 type
= gfc_sym_type (arg
);
2046 arg
->backend_decl
= backend_decl
;
2047 type
= build_reference_type (type
);
2051 parm
= build_decl (input_location
,
2052 PARM_DECL
, get_identifier ("__result"), type
);
2054 DECL_CONTEXT (parm
) = fndecl
;
2055 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2056 TREE_READONLY (parm
) = 1;
2057 DECL_ARTIFICIAL (parm
) = 1;
2058 gfc_finish_decl (parm
);
2060 arglist
= chainon (arglist
, parm
);
2061 typelist
= TREE_CHAIN (typelist
);
2063 if (sym
->ts
.type
== BT_CHARACTER
)
2065 gfc_allocate_lang_decl (parm
);
2066 arglist
= chainon (arglist
, length
);
2067 typelist
= TREE_CHAIN (typelist
);
2071 hidden_typelist
= typelist
;
2072 for (f
= sym
->formal
; f
; f
= f
->next
)
2073 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
2074 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2076 for (f
= sym
->formal
; f
; f
= f
->next
)
2078 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
2080 /* Ignore alternate returns. */
2084 type
= TREE_VALUE (typelist
);
2086 if (f
->sym
->ts
.type
== BT_CHARACTER
2087 && (!sym
->attr
.is_bind_c
|| sym
->attr
.entry_master
))
2089 tree len_type
= TREE_VALUE (hidden_typelist
);
2090 tree length
= NULL_TREE
;
2091 if (!f
->sym
->ts
.deferred
)
2092 gcc_assert (len_type
== gfc_charlen_type_node
);
2094 gcc_assert (POINTER_TYPE_P (len_type
));
2096 strcpy (&name
[1], f
->sym
->name
);
2098 length
= build_decl (input_location
,
2099 PARM_DECL
, get_identifier (name
), len_type
);
2101 hidden_arglist
= chainon (hidden_arglist
, length
);
2102 DECL_CONTEXT (length
) = fndecl
;
2103 DECL_ARTIFICIAL (length
) = 1;
2104 DECL_ARG_TYPE (length
) = len_type
;
2105 TREE_READONLY (length
) = 1;
2106 gfc_finish_decl (length
);
2108 /* Remember the passed value. */
2109 if (f
->sym
->ts
.u
.cl
->passed_length
!= NULL
)
2111 /* This can happen if the same type is used for multiple
2112 arguments. We need to copy cl as otherwise
2113 cl->passed_length gets overwritten. */
2114 f
->sym
->ts
.u
.cl
= gfc_new_charlen (f
->sym
->ns
, f
->sym
->ts
.u
.cl
);
2116 f
->sym
->ts
.u
.cl
->passed_length
= length
;
2118 /* Use the passed value for assumed length variables. */
2119 if (!f
->sym
->ts
.u
.cl
->length
)
2121 TREE_USED (length
) = 1;
2122 gcc_assert (!f
->sym
->ts
.u
.cl
->backend_decl
);
2123 f
->sym
->ts
.u
.cl
->backend_decl
= length
;
2126 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
2128 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
2129 || f
->sym
->ts
.u
.cl
->backend_decl
== length
)
2131 if (f
->sym
->ts
.u
.cl
->backend_decl
== NULL
)
2132 gfc_create_string_length (f
->sym
);
2134 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2135 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2136 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2138 type
= gfc_sym_type (f
->sym
);
2142 /* For non-constant length array arguments, make sure they use
2143 a different type node from TYPE_ARG_TYPES type. */
2144 if (f
->sym
->attr
.dimension
2145 && type
== TREE_VALUE (typelist
)
2146 && TREE_CODE (type
) == POINTER_TYPE
2147 && GFC_ARRAY_TYPE_P (type
)
2148 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
2149 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
2151 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
2152 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
2154 type
= gfc_sym_type (f
->sym
);
2157 if (f
->sym
->attr
.proc_pointer
)
2158 type
= build_pointer_type (type
);
2160 if (f
->sym
->attr
.volatile_
)
2161 type
= build_qualified_type (type
, TYPE_QUAL_VOLATILE
);
2163 /* Build the argument declaration. */
2164 parm
= build_decl (input_location
,
2165 PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
2167 if (f
->sym
->attr
.volatile_
)
2169 TREE_THIS_VOLATILE (parm
) = 1;
2170 TREE_SIDE_EFFECTS (parm
) = 1;
2173 /* Fill in arg stuff. */
2174 DECL_CONTEXT (parm
) = fndecl
;
2175 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
2176 /* All implementation args are read-only. */
2177 TREE_READONLY (parm
) = 1;
2178 if (POINTER_TYPE_P (type
)
2179 && (!f
->sym
->attr
.proc_pointer
2180 && f
->sym
->attr
.flavor
!= FL_PROCEDURE
))
2181 DECL_BY_REFERENCE (parm
) = 1;
2183 gfc_finish_decl (parm
);
2185 f
->sym
->backend_decl
= parm
;
2187 /* Coarrays which are descriptorless or assumed-shape pass with
2188 -fcoarray=lib the token and the offset as hidden arguments. */
2189 if (f
->sym
->attr
.codimension
2190 && gfc_option
.coarray
== GFC_FCOARRAY_LIB
2191 && !f
->sym
->attr
.allocatable
)
2197 gcc_assert (f
->sym
->backend_decl
!= NULL_TREE
2198 && !sym
->attr
.is_bind_c
);
2199 caf_type
= TREE_TYPE (f
->sym
->backend_decl
);
2201 token
= build_decl (input_location
, PARM_DECL
,
2202 create_tmp_var_name ("caf_token"),
2203 build_qualified_type (pvoid_type_node
,
2204 TYPE_QUAL_RESTRICT
));
2205 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2207 gcc_assert (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
2208 || GFC_DECL_TOKEN (f
->sym
->backend_decl
) == NULL_TREE
);
2209 if (DECL_LANG_SPECIFIC (f
->sym
->backend_decl
) == NULL
)
2210 gfc_allocate_lang_decl (f
->sym
->backend_decl
);
2211 GFC_DECL_TOKEN (f
->sym
->backend_decl
) = token
;
2215 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) == NULL_TREE
);
2216 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
) = token
;
2219 DECL_CONTEXT (token
) = fndecl
;
2220 DECL_ARTIFICIAL (token
) = 1;
2221 DECL_ARG_TYPE (token
) = TREE_VALUE (typelist
);
2222 TREE_READONLY (token
) = 1;
2223 hidden_arglist
= chainon (hidden_arglist
, token
);
2224 gfc_finish_decl (token
);
2226 offset
= build_decl (input_location
, PARM_DECL
,
2227 create_tmp_var_name ("caf_offset"),
2228 gfc_array_index_type
);
2230 if (f
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2232 gcc_assert (GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
)
2234 GFC_DECL_CAF_OFFSET (f
->sym
->backend_decl
) = offset
;
2238 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) == NULL_TREE
);
2239 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type
) = offset
;
2241 DECL_CONTEXT (offset
) = fndecl
;
2242 DECL_ARTIFICIAL (offset
) = 1;
2243 DECL_ARG_TYPE (offset
) = TREE_VALUE (typelist
);
2244 TREE_READONLY (offset
) = 1;
2245 hidden_arglist
= chainon (hidden_arglist
, offset
);
2246 gfc_finish_decl (offset
);
2249 arglist
= chainon (arglist
, parm
);
2250 typelist
= TREE_CHAIN (typelist
);
2253 /* Add the hidden string length parameters, unless the procedure
2255 if (!sym
->attr
.is_bind_c
)
2256 arglist
= chainon (arglist
, hidden_arglist
);
2258 gcc_assert (hidden_typelist
== NULL_TREE
2259 || TREE_VALUE (hidden_typelist
) == void_type_node
);
2260 DECL_ARGUMENTS (fndecl
) = arglist
;
2263 /* Do the setup necessary before generating the body of a function. */
2266 trans_function_start (gfc_symbol
* sym
)
2270 fndecl
= sym
->backend_decl
;
2272 /* Let GCC know the current scope is this function. */
2273 current_function_decl
= fndecl
;
2275 /* Let the world know what we're about to do. */
2276 announce_function (fndecl
);
2278 if (DECL_FILE_SCOPE_P (fndecl
))
2280 /* Create RTL for function declaration. */
2281 rest_of_decl_compilation (fndecl
, 1, 0);
2284 /* Create RTL for function definition. */
2285 make_decl_rtl (fndecl
);
2287 allocate_struct_function (fndecl
, false);
2289 /* function.c requires a push at the start of the function. */
2293 /* Create thunks for alternate entry points. */
2296 build_entry_thunks (gfc_namespace
* ns
, bool global
)
2298 gfc_formal_arglist
*formal
;
2299 gfc_formal_arglist
*thunk_formal
;
2301 gfc_symbol
*thunk_sym
;
2307 /* This should always be a toplevel function. */
2308 gcc_assert (current_function_decl
== NULL_TREE
);
2310 gfc_save_backend_locus (&old_loc
);
2311 for (el
= ns
->entries
; el
; el
= el
->next
)
2313 vec
<tree
, va_gc
> *args
= NULL
;
2314 vec
<tree
, va_gc
> *string_args
= NULL
;
2316 thunk_sym
= el
->sym
;
2318 build_function_decl (thunk_sym
, global
);
2319 create_function_arglist (thunk_sym
);
2321 trans_function_start (thunk_sym
);
2323 thunk_fndecl
= thunk_sym
->backend_decl
;
2325 gfc_init_block (&body
);
2327 /* Pass extra parameter identifying this entry point. */
2328 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
2329 vec_safe_push (args
, tmp
);
2331 if (thunk_sym
->attr
.function
)
2333 if (gfc_return_by_reference (ns
->proc_name
))
2335 tree ref
= DECL_ARGUMENTS (current_function_decl
);
2336 vec_safe_push (args
, ref
);
2337 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
2338 vec_safe_push (args
, DECL_CHAIN (ref
));
2342 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
2344 /* Ignore alternate returns. */
2345 if (formal
->sym
== NULL
)
2348 /* We don't have a clever way of identifying arguments, so resort to
2349 a brute-force search. */
2350 for (thunk_formal
= thunk_sym
->formal
;
2352 thunk_formal
= thunk_formal
->next
)
2354 if (thunk_formal
->sym
== formal
->sym
)
2360 /* Pass the argument. */
2361 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
2362 vec_safe_push (args
, thunk_formal
->sym
->backend_decl
);
2363 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2365 tmp
= thunk_formal
->sym
->ts
.u
.cl
->backend_decl
;
2366 vec_safe_push (string_args
, tmp
);
2371 /* Pass NULL for a missing argument. */
2372 vec_safe_push (args
, null_pointer_node
);
2373 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2375 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
2376 vec_safe_push (string_args
, tmp
);
2381 /* Call the master function. */
2382 vec_safe_splice (args
, string_args
);
2383 tmp
= ns
->proc_name
->backend_decl
;
2384 tmp
= build_call_expr_loc_vec (input_location
, tmp
, args
);
2385 if (ns
->proc_name
->attr
.mixed_entry_master
)
2387 tree union_decl
, field
;
2388 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
2390 union_decl
= build_decl (input_location
,
2391 VAR_DECL
, get_identifier ("__result"),
2392 TREE_TYPE (master_type
));
2393 DECL_ARTIFICIAL (union_decl
) = 1;
2394 DECL_EXTERNAL (union_decl
) = 0;
2395 TREE_PUBLIC (union_decl
) = 0;
2396 TREE_USED (union_decl
) = 1;
2397 layout_decl (union_decl
, 0);
2398 pushdecl (union_decl
);
2400 DECL_CONTEXT (union_decl
) = current_function_decl
;
2401 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2402 TREE_TYPE (union_decl
), union_decl
, tmp
);
2403 gfc_add_expr_to_block (&body
, tmp
);
2405 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
2406 field
; field
= DECL_CHAIN (field
))
2407 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2408 thunk_sym
->result
->name
) == 0)
2410 gcc_assert (field
!= NULL_TREE
);
2411 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
2412 TREE_TYPE (field
), union_decl
, field
,
2414 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2415 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2416 DECL_RESULT (current_function_decl
), tmp
);
2417 tmp
= build1_v (RETURN_EXPR
, tmp
);
2419 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
2422 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
2423 TREE_TYPE (DECL_RESULT (current_function_decl
)),
2424 DECL_RESULT (current_function_decl
), tmp
);
2425 tmp
= build1_v (RETURN_EXPR
, tmp
);
2427 gfc_add_expr_to_block (&body
, tmp
);
2429 /* Finish off this function and send it for code generation. */
2430 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
2433 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
2434 DECL_SAVED_TREE (thunk_fndecl
)
2435 = build3_v (BIND_EXPR
, tmp
, DECL_SAVED_TREE (thunk_fndecl
),
2436 DECL_INITIAL (thunk_fndecl
));
2438 /* Output the GENERIC tree. */
2439 dump_function (TDI_original
, thunk_fndecl
);
2441 /* Store the end of the function, so that we get good line number
2442 info for the epilogue. */
2443 cfun
->function_end_locus
= input_location
;
2445 /* We're leaving the context of this function, so zap cfun.
2446 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2447 tree_rest_of_compilation. */
2450 current_function_decl
= NULL_TREE
;
2452 cgraph_finalize_function (thunk_fndecl
, true);
2454 /* We share the symbols in the formal argument list with other entry
2455 points and the master function. Clear them so that they are
2456 recreated for each function. */
2457 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
2458 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
2460 formal
->sym
->backend_decl
= NULL_TREE
;
2461 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
2462 formal
->sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2465 if (thunk_sym
->attr
.function
)
2467 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
2468 thunk_sym
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2469 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
2470 thunk_sym
->result
->ts
.u
.cl
->backend_decl
= NULL_TREE
;
2474 gfc_restore_backend_locus (&old_loc
);
2478 /* Create a decl for a function, and create any thunks for alternate entry
2479 points. If global is true, generate the function in the global binding
2480 level, otherwise in the current binding level (which can be global). */
2483 gfc_create_function_decl (gfc_namespace
* ns
, bool global
)
2485 /* Create a declaration for the master function. */
2486 build_function_decl (ns
->proc_name
, global
);
2488 /* Compile the entry thunks. */
2490 build_entry_thunks (ns
, global
);
2492 /* Now create the read argument list. */
2493 create_function_arglist (ns
->proc_name
);
2496 /* Return the decl used to hold the function return value. If
2497 parent_flag is set, the context is the parent_scope. */
2500 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
2504 tree this_fake_result_decl
;
2505 tree this_function_decl
;
2507 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
2511 this_fake_result_decl
= parent_fake_result_decl
;
2512 this_function_decl
= DECL_CONTEXT (current_function_decl
);
2516 this_fake_result_decl
= current_fake_result_decl
;
2517 this_function_decl
= current_function_decl
;
2521 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
2522 && sym
->ns
->proc_name
->attr
.entry_master
2523 && sym
!= sym
->ns
->proc_name
)
2526 if (this_fake_result_decl
!= NULL
)
2527 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
2528 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
2531 return TREE_VALUE (t
);
2532 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
2535 this_fake_result_decl
= parent_fake_result_decl
;
2537 this_fake_result_decl
= current_fake_result_decl
;
2539 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
2543 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
2544 field
; field
= DECL_CHAIN (field
))
2545 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
2549 gcc_assert (field
!= NULL_TREE
);
2550 decl
= fold_build3_loc (input_location
, COMPONENT_REF
,
2551 TREE_TYPE (field
), decl
, field
, NULL_TREE
);
2554 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
2556 gfc_add_decl_to_parent_function (var
);
2558 gfc_add_decl_to_function (var
);
2560 SET_DECL_VALUE_EXPR (var
, decl
);
2561 DECL_HAS_VALUE_EXPR_P (var
) = 1;
2562 GFC_DECL_RESULT (var
) = 1;
2564 TREE_CHAIN (this_fake_result_decl
)
2565 = tree_cons (get_identifier (sym
->name
), var
,
2566 TREE_CHAIN (this_fake_result_decl
));
2570 if (this_fake_result_decl
!= NULL_TREE
)
2571 return TREE_VALUE (this_fake_result_decl
);
2573 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2578 if (sym
->ts
.type
== BT_CHARACTER
)
2580 if (sym
->ts
.u
.cl
->backend_decl
== NULL_TREE
)
2581 length
= gfc_create_string_length (sym
);
2583 length
= sym
->ts
.u
.cl
->backend_decl
;
2584 if (TREE_CODE (length
) == VAR_DECL
2585 && DECL_CONTEXT (length
) == NULL_TREE
)
2586 gfc_add_decl_to_function (length
);
2589 if (gfc_return_by_reference (sym
))
2591 decl
= DECL_ARGUMENTS (this_function_decl
);
2593 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
2594 && sym
->ns
->proc_name
->attr
.entry_master
)
2595 decl
= DECL_CHAIN (decl
);
2597 TREE_USED (decl
) = 1;
2599 decl
= gfc_build_dummy_array_decl (sym
, decl
);
2603 sprintf (name
, "__result_%.20s",
2604 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
2606 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
2607 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2608 VAR_DECL
, get_identifier (name
),
2609 gfc_sym_type (sym
));
2611 decl
= build_decl (DECL_SOURCE_LOCATION (this_function_decl
),
2612 VAR_DECL
, get_identifier (name
),
2613 TREE_TYPE (TREE_TYPE (this_function_decl
)));
2614 DECL_ARTIFICIAL (decl
) = 1;
2615 DECL_EXTERNAL (decl
) = 0;
2616 TREE_PUBLIC (decl
) = 0;
2617 TREE_USED (decl
) = 1;
2618 GFC_DECL_RESULT (decl
) = 1;
2619 TREE_ADDRESSABLE (decl
) = 1;
2621 layout_decl (decl
, 0);
2624 gfc_add_decl_to_parent_function (decl
);
2626 gfc_add_decl_to_function (decl
);
2630 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
2632 current_fake_result_decl
= build_tree_list (NULL
, decl
);
2638 /* Builds a function decl. The remaining parameters are the types of the
2639 function arguments. Negative nargs indicates a varargs function. */
2642 build_library_function_decl_1 (tree name
, const char *spec
,
2643 tree rettype
, int nargs
, va_list p
)
2645 vec
<tree
, va_gc
> *arglist
;
2650 /* Library functions must be declared with global scope. */
2651 gcc_assert (current_function_decl
== NULL_TREE
);
2653 /* Create a list of the argument types. */
2654 vec_alloc (arglist
, abs (nargs
));
2655 for (n
= abs (nargs
); n
> 0; n
--)
2657 tree argtype
= va_arg (p
, tree
);
2658 arglist
->quick_push (argtype
);
2661 /* Build the function type and decl. */
2663 fntype
= build_function_type_vec (rettype
, arglist
);
2665 fntype
= build_varargs_function_type_vec (rettype
, arglist
);
2668 tree attr_args
= build_tree_list (NULL_TREE
,
2669 build_string (strlen (spec
), spec
));
2670 tree attrs
= tree_cons (get_identifier ("fn spec"),
2671 attr_args
, TYPE_ATTRIBUTES (fntype
));
2672 fntype
= build_type_attribute_variant (fntype
, attrs
);
2674 fndecl
= build_decl (input_location
,
2675 FUNCTION_DECL
, name
, fntype
);
2677 /* Mark this decl as external. */
2678 DECL_EXTERNAL (fndecl
) = 1;
2679 TREE_PUBLIC (fndecl
) = 1;
2683 rest_of_decl_compilation (fndecl
, 1, 0);
2688 /* Builds a function decl. The remaining parameters are the types of the
2689 function arguments. Negative nargs indicates a varargs function. */
2692 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
2696 va_start (args
, nargs
);
2697 ret
= build_library_function_decl_1 (name
, NULL
, rettype
, nargs
, args
);
2702 /* Builds a function decl. The remaining parameters are the types of the
2703 function arguments. Negative nargs indicates a varargs function.
2704 The SPEC parameter specifies the function argument and return type
2705 specification according to the fnspec function type attribute. */
2708 gfc_build_library_function_decl_with_spec (tree name
, const char *spec
,
2709 tree rettype
, int nargs
, ...)
2713 va_start (args
, nargs
);
2714 ret
= build_library_function_decl_1 (name
, spec
, rettype
, nargs
, args
);
2720 gfc_build_intrinsic_function_decls (void)
2722 tree gfc_int4_type_node
= gfc_get_int_type (4);
2723 tree gfc_int8_type_node
= gfc_get_int_type (8);
2724 tree gfc_int16_type_node
= gfc_get_int_type (16);
2725 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
2726 tree pchar1_type_node
= gfc_get_pchar_type (1);
2727 tree pchar4_type_node
= gfc_get_pchar_type (4);
2729 /* String functions. */
2730 gfor_fndecl_compare_string
= gfc_build_library_function_decl_with_spec (
2731 get_identifier (PREFIX("compare_string")), "..R.R",
2732 integer_type_node
, 4, gfc_charlen_type_node
, pchar1_type_node
,
2733 gfc_charlen_type_node
, pchar1_type_node
);
2734 DECL_PURE_P (gfor_fndecl_compare_string
) = 1;
2735 TREE_NOTHROW (gfor_fndecl_compare_string
) = 1;
2737 gfor_fndecl_concat_string
= gfc_build_library_function_decl_with_spec (
2738 get_identifier (PREFIX("concat_string")), "..W.R.R",
2739 void_type_node
, 6, gfc_charlen_type_node
, pchar1_type_node
,
2740 gfc_charlen_type_node
, pchar1_type_node
,
2741 gfc_charlen_type_node
, pchar1_type_node
);
2742 TREE_NOTHROW (gfor_fndecl_concat_string
) = 1;
2744 gfor_fndecl_string_len_trim
= gfc_build_library_function_decl_with_spec (
2745 get_identifier (PREFIX("string_len_trim")), "..R",
2746 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar1_type_node
);
2747 DECL_PURE_P (gfor_fndecl_string_len_trim
) = 1;
2748 TREE_NOTHROW (gfor_fndecl_string_len_trim
) = 1;
2750 gfor_fndecl_string_index
= gfc_build_library_function_decl_with_spec (
2751 get_identifier (PREFIX("string_index")), "..R.R.",
2752 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2753 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2754 DECL_PURE_P (gfor_fndecl_string_index
) = 1;
2755 TREE_NOTHROW (gfor_fndecl_string_index
) = 1;
2757 gfor_fndecl_string_scan
= gfc_build_library_function_decl_with_spec (
2758 get_identifier (PREFIX("string_scan")), "..R.R.",
2759 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2760 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2761 DECL_PURE_P (gfor_fndecl_string_scan
) = 1;
2762 TREE_NOTHROW (gfor_fndecl_string_scan
) = 1;
2764 gfor_fndecl_string_verify
= gfc_build_library_function_decl_with_spec (
2765 get_identifier (PREFIX("string_verify")), "..R.R.",
2766 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar1_type_node
,
2767 gfc_charlen_type_node
, pchar1_type_node
, gfc_logical4_type_node
);
2768 DECL_PURE_P (gfor_fndecl_string_verify
) = 1;
2769 TREE_NOTHROW (gfor_fndecl_string_verify
) = 1;
2771 gfor_fndecl_string_trim
= gfc_build_library_function_decl_with_spec (
2772 get_identifier (PREFIX("string_trim")), ".Ww.R",
2773 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2774 build_pointer_type (pchar1_type_node
), gfc_charlen_type_node
,
2777 gfor_fndecl_string_minmax
= gfc_build_library_function_decl_with_spec (
2778 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2779 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2780 build_pointer_type (pchar1_type_node
), integer_type_node
,
2783 gfor_fndecl_adjustl
= gfc_build_library_function_decl_with_spec (
2784 get_identifier (PREFIX("adjustl")), ".W.R",
2785 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2787 TREE_NOTHROW (gfor_fndecl_adjustl
) = 1;
2789 gfor_fndecl_adjustr
= gfc_build_library_function_decl_with_spec (
2790 get_identifier (PREFIX("adjustr")), ".W.R",
2791 void_type_node
, 3, pchar1_type_node
, gfc_charlen_type_node
,
2793 TREE_NOTHROW (gfor_fndecl_adjustr
) = 1;
2795 gfor_fndecl_select_string
= gfc_build_library_function_decl_with_spec (
2796 get_identifier (PREFIX("select_string")), ".R.R.",
2797 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2798 pchar1_type_node
, gfc_charlen_type_node
);
2799 DECL_PURE_P (gfor_fndecl_select_string
) = 1;
2800 TREE_NOTHROW (gfor_fndecl_select_string
) = 1;
2802 gfor_fndecl_compare_string_char4
= gfc_build_library_function_decl_with_spec (
2803 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2804 integer_type_node
, 4, gfc_charlen_type_node
, pchar4_type_node
,
2805 gfc_charlen_type_node
, pchar4_type_node
);
2806 DECL_PURE_P (gfor_fndecl_compare_string_char4
) = 1;
2807 TREE_NOTHROW (gfor_fndecl_compare_string_char4
) = 1;
2809 gfor_fndecl_concat_string_char4
= gfc_build_library_function_decl_with_spec (
2810 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2811 void_type_node
, 6, gfc_charlen_type_node
, pchar4_type_node
,
2812 gfc_charlen_type_node
, pchar4_type_node
, gfc_charlen_type_node
,
2814 TREE_NOTHROW (gfor_fndecl_concat_string_char4
) = 1;
2816 gfor_fndecl_string_len_trim_char4
= gfc_build_library_function_decl_with_spec (
2817 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2818 gfc_charlen_type_node
, 2, gfc_charlen_type_node
, pchar4_type_node
);
2819 DECL_PURE_P (gfor_fndecl_string_len_trim_char4
) = 1;
2820 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4
) = 1;
2822 gfor_fndecl_string_index_char4
= gfc_build_library_function_decl_with_spec (
2823 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2824 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2825 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2826 DECL_PURE_P (gfor_fndecl_string_index_char4
) = 1;
2827 TREE_NOTHROW (gfor_fndecl_string_index_char4
) = 1;
2829 gfor_fndecl_string_scan_char4
= gfc_build_library_function_decl_with_spec (
2830 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2831 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2832 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2833 DECL_PURE_P (gfor_fndecl_string_scan_char4
) = 1;
2834 TREE_NOTHROW (gfor_fndecl_string_scan_char4
) = 1;
2836 gfor_fndecl_string_verify_char4
= gfc_build_library_function_decl_with_spec (
2837 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2838 gfc_charlen_type_node
, 5, gfc_charlen_type_node
, pchar4_type_node
,
2839 gfc_charlen_type_node
, pchar4_type_node
, gfc_logical4_type_node
);
2840 DECL_PURE_P (gfor_fndecl_string_verify_char4
) = 1;
2841 TREE_NOTHROW (gfor_fndecl_string_verify_char4
) = 1;
2843 gfor_fndecl_string_trim_char4
= gfc_build_library_function_decl_with_spec (
2844 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2845 void_type_node
, 4, build_pointer_type (gfc_charlen_type_node
),
2846 build_pointer_type (pchar4_type_node
), gfc_charlen_type_node
,
2849 gfor_fndecl_string_minmax_char4
= gfc_build_library_function_decl_with_spec (
2850 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2851 void_type_node
, -4, build_pointer_type (gfc_charlen_type_node
),
2852 build_pointer_type (pchar4_type_node
), integer_type_node
,
2855 gfor_fndecl_adjustl_char4
= gfc_build_library_function_decl_with_spec (
2856 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2857 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2859 TREE_NOTHROW (gfor_fndecl_adjustl_char4
) = 1;
2861 gfor_fndecl_adjustr_char4
= gfc_build_library_function_decl_with_spec (
2862 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2863 void_type_node
, 3, pchar4_type_node
, gfc_charlen_type_node
,
2865 TREE_NOTHROW (gfor_fndecl_adjustr_char4
) = 1;
2867 gfor_fndecl_select_string_char4
= gfc_build_library_function_decl_with_spec (
2868 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2869 integer_type_node
, 4, pvoid_type_node
, integer_type_node
,
2870 pvoid_type_node
, gfc_charlen_type_node
);
2871 DECL_PURE_P (gfor_fndecl_select_string_char4
) = 1;
2872 TREE_NOTHROW (gfor_fndecl_select_string_char4
) = 1;
2875 /* Conversion between character kinds. */
2877 gfor_fndecl_convert_char1_to_char4
= gfc_build_library_function_decl_with_spec (
2878 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2879 void_type_node
, 3, build_pointer_type (pchar4_type_node
),
2880 gfc_charlen_type_node
, pchar1_type_node
);
2882 gfor_fndecl_convert_char4_to_char1
= gfc_build_library_function_decl_with_spec (
2883 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2884 void_type_node
, 3, build_pointer_type (pchar1_type_node
),
2885 gfc_charlen_type_node
, pchar4_type_node
);
2887 /* Misc. functions. */
2889 gfor_fndecl_ttynam
= gfc_build_library_function_decl_with_spec (
2890 get_identifier (PREFIX("ttynam")), ".W",
2891 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2894 gfor_fndecl_fdate
= gfc_build_library_function_decl_with_spec (
2895 get_identifier (PREFIX("fdate")), ".W",
2896 void_type_node
, 2, pchar_type_node
, gfc_charlen_type_node
);
2898 gfor_fndecl_ctime
= gfc_build_library_function_decl_with_spec (
2899 get_identifier (PREFIX("ctime")), ".W",
2900 void_type_node
, 3, pchar_type_node
, gfc_charlen_type_node
,
2901 gfc_int8_type_node
);
2903 gfor_fndecl_sc_kind
= gfc_build_library_function_decl_with_spec (
2904 get_identifier (PREFIX("selected_char_kind")), "..R",
2905 gfc_int4_type_node
, 2, gfc_charlen_type_node
, pchar_type_node
);
2906 DECL_PURE_P (gfor_fndecl_sc_kind
) = 1;
2907 TREE_NOTHROW (gfor_fndecl_sc_kind
) = 1;
2909 gfor_fndecl_si_kind
= gfc_build_library_function_decl_with_spec (
2910 get_identifier (PREFIX("selected_int_kind")), ".R",
2911 gfc_int4_type_node
, 1, pvoid_type_node
);
2912 DECL_PURE_P (gfor_fndecl_si_kind
) = 1;
2913 TREE_NOTHROW (gfor_fndecl_si_kind
) = 1;
2915 gfor_fndecl_sr_kind
= gfc_build_library_function_decl_with_spec (
2916 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2917 gfc_int4_type_node
, 3, pvoid_type_node
, pvoid_type_node
,
2919 DECL_PURE_P (gfor_fndecl_sr_kind
) = 1;
2920 TREE_NOTHROW (gfor_fndecl_sr_kind
) = 1;
2922 /* Power functions. */
2924 tree ctype
, rtype
, itype
, jtype
;
2925 int rkind
, ikind
, jkind
;
2928 static int ikinds
[NIKINDS
] = {4, 8, 16};
2929 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2930 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2932 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2934 itype
= gfc_get_int_type (ikinds
[ikind
]);
2936 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2938 jtype
= gfc_get_int_type (ikinds
[jkind
]);
2941 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
2943 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
2944 gfc_build_library_function_decl (get_identifier (name
),
2945 jtype
, 2, jtype
, itype
);
2946 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2947 TREE_NOTHROW (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2951 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
2953 rtype
= gfc_get_real_type (rkinds
[rkind
]);
2956 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
2958 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
2959 gfc_build_library_function_decl (get_identifier (name
),
2960 rtype
, 2, rtype
, itype
);
2961 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2962 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2965 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
2968 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
2970 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
2971 gfc_build_library_function_decl (get_identifier (name
),
2972 ctype
, 2,ctype
, itype
);
2973 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2974 TREE_NOTHROW (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2982 gfor_fndecl_math_ishftc4
= gfc_build_library_function_decl (
2983 get_identifier (PREFIX("ishftc4")),
2984 gfc_int4_type_node
, 3, gfc_int4_type_node
, gfc_int4_type_node
,
2985 gfc_int4_type_node
);
2986 TREE_READONLY (gfor_fndecl_math_ishftc4
) = 1;
2987 TREE_NOTHROW (gfor_fndecl_math_ishftc4
) = 1;
2989 gfor_fndecl_math_ishftc8
= gfc_build_library_function_decl (
2990 get_identifier (PREFIX("ishftc8")),
2991 gfc_int8_type_node
, 3, gfc_int8_type_node
, gfc_int4_type_node
,
2992 gfc_int4_type_node
);
2993 TREE_READONLY (gfor_fndecl_math_ishftc8
) = 1;
2994 TREE_NOTHROW (gfor_fndecl_math_ishftc8
) = 1;
2996 if (gfc_int16_type_node
)
2998 gfor_fndecl_math_ishftc16
= gfc_build_library_function_decl (
2999 get_identifier (PREFIX("ishftc16")),
3000 gfc_int16_type_node
, 3, gfc_int16_type_node
, gfc_int4_type_node
,
3001 gfc_int4_type_node
);
3002 TREE_READONLY (gfor_fndecl_math_ishftc16
) = 1;
3003 TREE_NOTHROW (gfor_fndecl_math_ishftc16
) = 1;
3006 /* BLAS functions. */
3008 tree pint
= build_pointer_type (integer_type_node
);
3009 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
3010 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
3011 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
3012 tree pz
= build_pointer_type
3013 (gfc_get_complex_type (gfc_default_double_kind
));
3015 gfor_fndecl_sgemm
= gfc_build_library_function_decl
3017 (gfc_option
.flag_underscoring
? "sgemm_"
3019 void_type_node
, 15, pchar_type_node
,
3020 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
3021 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
3023 gfor_fndecl_dgemm
= gfc_build_library_function_decl
3025 (gfc_option
.flag_underscoring
? "dgemm_"
3027 void_type_node
, 15, pchar_type_node
,
3028 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
3029 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
3031 gfor_fndecl_cgemm
= gfc_build_library_function_decl
3033 (gfc_option
.flag_underscoring
? "cgemm_"
3035 void_type_node
, 15, pchar_type_node
,
3036 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
3037 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
3039 gfor_fndecl_zgemm
= gfc_build_library_function_decl
3041 (gfc_option
.flag_underscoring
? "zgemm_"
3043 void_type_node
, 15, pchar_type_node
,
3044 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
3045 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
3049 /* Other functions. */
3050 gfor_fndecl_size0
= gfc_build_library_function_decl_with_spec (
3051 get_identifier (PREFIX("size0")), ".R",
3052 gfc_array_index_type
, 1, pvoid_type_node
);
3053 DECL_PURE_P (gfor_fndecl_size0
) = 1;
3054 TREE_NOTHROW (gfor_fndecl_size0
) = 1;
3056 gfor_fndecl_size1
= gfc_build_library_function_decl_with_spec (
3057 get_identifier (PREFIX("size1")), ".R",
3058 gfc_array_index_type
, 2, pvoid_type_node
, gfc_array_index_type
);
3059 DECL_PURE_P (gfor_fndecl_size1
) = 1;
3060 TREE_NOTHROW (gfor_fndecl_size1
) = 1;
3062 gfor_fndecl_iargc
= gfc_build_library_function_decl (
3063 get_identifier (PREFIX ("iargc")), gfc_int4_type_node
, 0);
3064 TREE_NOTHROW (gfor_fndecl_iargc
) = 1;
3068 /* Make prototypes for runtime library functions. */
3071 gfc_build_builtin_function_decls (void)
3073 tree gfc_int4_type_node
= gfc_get_int_type (4);
3075 gfor_fndecl_stop_numeric
= gfc_build_library_function_decl (
3076 get_identifier (PREFIX("stop_numeric")),
3077 void_type_node
, 1, gfc_int4_type_node
);
3078 /* STOP doesn't return. */
3079 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
3081 gfor_fndecl_stop_numeric_f08
= gfc_build_library_function_decl (
3082 get_identifier (PREFIX("stop_numeric_f08")),
3083 void_type_node
, 1, gfc_int4_type_node
);
3084 /* STOP doesn't return. */
3085 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08
) = 1;
3087 gfor_fndecl_stop_string
= gfc_build_library_function_decl_with_spec (
3088 get_identifier (PREFIX("stop_string")), ".R.",
3089 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3090 /* STOP doesn't return. */
3091 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
3093 gfor_fndecl_error_stop_numeric
= gfc_build_library_function_decl (
3094 get_identifier (PREFIX("error_stop_numeric")),
3095 void_type_node
, 1, gfc_int4_type_node
);
3096 /* ERROR STOP doesn't return. */
3097 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric
) = 1;
3099 gfor_fndecl_error_stop_string
= gfc_build_library_function_decl_with_spec (
3100 get_identifier (PREFIX("error_stop_string")), ".R.",
3101 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3102 /* ERROR STOP doesn't return. */
3103 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string
) = 1;
3105 gfor_fndecl_pause_numeric
= gfc_build_library_function_decl (
3106 get_identifier (PREFIX("pause_numeric")),
3107 void_type_node
, 1, gfc_int4_type_node
);
3109 gfor_fndecl_pause_string
= gfc_build_library_function_decl_with_spec (
3110 get_identifier (PREFIX("pause_string")), ".R.",
3111 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3113 gfor_fndecl_runtime_error
= gfc_build_library_function_decl_with_spec (
3114 get_identifier (PREFIX("runtime_error")), ".R",
3115 void_type_node
, -1, pchar_type_node
);
3116 /* The runtime_error function does not return. */
3117 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
3119 gfor_fndecl_runtime_error_at
= gfc_build_library_function_decl_with_spec (
3120 get_identifier (PREFIX("runtime_error_at")), ".RR",
3121 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3122 /* The runtime_error_at function does not return. */
3123 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
3125 gfor_fndecl_runtime_warning_at
= gfc_build_library_function_decl_with_spec (
3126 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3127 void_type_node
, -2, pchar_type_node
, pchar_type_node
);
3129 gfor_fndecl_generate_error
= gfc_build_library_function_decl_with_spec (
3130 get_identifier (PREFIX("generate_error")), ".R.R",
3131 void_type_node
, 3, pvoid_type_node
, integer_type_node
,
3134 gfor_fndecl_os_error
= gfc_build_library_function_decl_with_spec (
3135 get_identifier (PREFIX("os_error")), ".R",
3136 void_type_node
, 1, pchar_type_node
);
3137 /* The runtime_error function does not return. */
3138 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
3140 gfor_fndecl_set_args
= gfc_build_library_function_decl (
3141 get_identifier (PREFIX("set_args")),
3142 void_type_node
, 2, integer_type_node
,
3143 build_pointer_type (pchar_type_node
));
3145 gfor_fndecl_set_fpe
= gfc_build_library_function_decl (
3146 get_identifier (PREFIX("set_fpe")),
3147 void_type_node
, 1, integer_type_node
);
3149 /* Keep the array dimension in sync with the call, later in this file. */
3150 gfor_fndecl_set_options
= gfc_build_library_function_decl_with_spec (
3151 get_identifier (PREFIX("set_options")), "..R",
3152 void_type_node
, 2, integer_type_node
,
3153 build_pointer_type (integer_type_node
));
3155 gfor_fndecl_set_convert
= gfc_build_library_function_decl (
3156 get_identifier (PREFIX("set_convert")),
3157 void_type_node
, 1, integer_type_node
);
3159 gfor_fndecl_set_record_marker
= gfc_build_library_function_decl (
3160 get_identifier (PREFIX("set_record_marker")),
3161 void_type_node
, 1, integer_type_node
);
3163 gfor_fndecl_set_max_subrecord_length
= gfc_build_library_function_decl (
3164 get_identifier (PREFIX("set_max_subrecord_length")),
3165 void_type_node
, 1, integer_type_node
);
3167 gfor_fndecl_in_pack
= gfc_build_library_function_decl_with_spec (
3168 get_identifier (PREFIX("internal_pack")), ".r",
3169 pvoid_type_node
, 1, pvoid_type_node
);
3171 gfor_fndecl_in_unpack
= gfc_build_library_function_decl_with_spec (
3172 get_identifier (PREFIX("internal_unpack")), ".wR",
3173 void_type_node
, 2, pvoid_type_node
, pvoid_type_node
);
3175 gfor_fndecl_associated
= gfc_build_library_function_decl_with_spec (
3176 get_identifier (PREFIX("associated")), ".RR",
3177 integer_type_node
, 2, ppvoid_type_node
, ppvoid_type_node
);
3178 DECL_PURE_P (gfor_fndecl_associated
) = 1;
3179 TREE_NOTHROW (gfor_fndecl_associated
) = 1;
3181 /* Coarray library calls. */
3182 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
3184 tree pint_type
, pppchar_type
;
3186 pint_type
= build_pointer_type (integer_type_node
);
3188 = build_pointer_type (build_pointer_type (pchar_type_node
));
3190 gfor_fndecl_caf_init
= gfc_build_library_function_decl (
3191 get_identifier (PREFIX("caf_init")), void_type_node
,
3192 4, pint_type
, pppchar_type
, pint_type
, pint_type
);
3194 gfor_fndecl_caf_finalize
= gfc_build_library_function_decl (
3195 get_identifier (PREFIX("caf_finalize")), void_type_node
, 0);
3197 gfor_fndecl_caf_register
= gfc_build_library_function_decl_with_spec (
3198 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node
, 6,
3199 size_type_node
, integer_type_node
, ppvoid_type_node
, pint_type
,
3200 pchar_type_node
, integer_type_node
);
3202 gfor_fndecl_caf_deregister
= gfc_build_library_function_decl_with_spec (
3203 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node
, 4,
3204 ppvoid_type_node
, pint_type
, pchar_type_node
, integer_type_node
);
3206 gfor_fndecl_caf_critical
= gfc_build_library_function_decl (
3207 get_identifier (PREFIX("caf_critical")), void_type_node
, 0);
3209 gfor_fndecl_caf_end_critical
= gfc_build_library_function_decl (
3210 get_identifier (PREFIX("caf_end_critical")), void_type_node
, 0);
3212 gfor_fndecl_caf_sync_all
= gfc_build_library_function_decl_with_spec (
3213 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node
,
3214 3, pint_type
, build_pointer_type (pchar_type_node
), integer_type_node
);
3216 gfor_fndecl_caf_sync_images
= gfc_build_library_function_decl_with_spec (
3217 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node
,
3218 5, integer_type_node
, pint_type
, pint_type
,
3219 build_pointer_type (pchar_type_node
), integer_type_node
);
3221 gfor_fndecl_caf_error_stop
= gfc_build_library_function_decl (
3222 get_identifier (PREFIX("caf_error_stop")),
3223 void_type_node
, 1, gfc_int4_type_node
);
3224 /* CAF's ERROR STOP doesn't return. */
3225 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop
) = 1;
3227 gfor_fndecl_caf_error_stop_str
= gfc_build_library_function_decl_with_spec (
3228 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3229 void_type_node
, 2, pchar_type_node
, gfc_int4_type_node
);
3230 /* CAF's ERROR STOP doesn't return. */
3231 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str
) = 1;
3234 gfc_build_intrinsic_function_decls ();
3235 gfc_build_intrinsic_lib_fndecls ();
3236 gfc_build_io_library_fndecls ();
3240 /* Evaluate the length of dummy character variables. */
3243 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
,
3244 gfc_wrapped_block
*block
)
3248 gfc_finish_decl (cl
->backend_decl
);
3250 gfc_start_block (&init
);
3252 /* Evaluate the string length expression. */
3253 gfc_conv_string_length (cl
, NULL
, &init
);
3255 gfc_trans_vla_type_sizes (sym
, &init
);
3257 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3261 /* Allocate and cleanup an automatic character variable. */
3264 gfc_trans_auto_character_variable (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3270 gcc_assert (sym
->backend_decl
);
3271 gcc_assert (sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
);
3273 gfc_init_block (&init
);
3275 /* Evaluate the string length expression. */
3276 gfc_conv_string_length (sym
->ts
.u
.cl
, NULL
, &init
);
3278 gfc_trans_vla_type_sizes (sym
, &init
);
3280 decl
= sym
->backend_decl
;
3282 /* Emit a DECL_EXPR for this variable, which will cause the
3283 gimplifier to allocate storage, and all that good stuff. */
3284 tmp
= fold_build1_loc (input_location
, DECL_EXPR
, TREE_TYPE (decl
), decl
);
3285 gfc_add_expr_to_block (&init
, tmp
);
3287 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3290 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3293 gfc_trans_assign_aux_var (gfc_symbol
* sym
, gfc_wrapped_block
* block
)
3297 gcc_assert (sym
->backend_decl
);
3298 gfc_start_block (&init
);
3300 /* Set the initial value to length. See the comments in
3301 function gfc_add_assign_aux_vars in this file. */
3302 gfc_add_modify (&init
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
3303 build_int_cst (gfc_charlen_type_node
, -2));
3305 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3309 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
3311 tree t
= *tp
, var
, val
;
3313 if (t
== NULL
|| t
== error_mark_node
)
3315 if (TREE_CONSTANT (t
) || DECL_P (t
))
3318 if (TREE_CODE (t
) == SAVE_EXPR
)
3320 if (SAVE_EXPR_RESOLVED_P (t
))
3322 *tp
= TREE_OPERAND (t
, 0);
3325 val
= TREE_OPERAND (t
, 0);
3330 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
3331 gfc_add_decl_to_function (var
);
3332 gfc_add_modify (body
, var
, val
);
3333 if (TREE_CODE (t
) == SAVE_EXPR
)
3334 TREE_OPERAND (t
, 0) = var
;
3339 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
3343 if (type
== NULL
|| type
== error_mark_node
)
3346 type
= TYPE_MAIN_VARIANT (type
);
3348 if (TREE_CODE (type
) == INTEGER_TYPE
)
3350 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
3351 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
3353 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3355 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
3356 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
3359 else if (TREE_CODE (type
) == ARRAY_TYPE
)
3361 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
3362 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
3363 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
3364 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
3366 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
3368 TYPE_SIZE (t
) = TYPE_SIZE (type
);
3369 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
3374 /* Make sure all type sizes and array domains are either constant,
3375 or variable or parameter decls. This is a simplified variant
3376 of gimplify_type_sizes, but we can't use it here, as none of the
3377 variables in the expressions have been gimplified yet.
3378 As type sizes and domains for various variable length arrays
3379 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3380 time, without this routine gimplify_type_sizes in the middle-end
3381 could result in the type sizes being gimplified earlier than where
3382 those variables are initialized. */
3385 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
3387 tree type
= TREE_TYPE (sym
->backend_decl
);
3389 if (TREE_CODE (type
) == FUNCTION_TYPE
3390 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
3392 if (! current_fake_result_decl
)
3395 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
3398 while (POINTER_TYPE_P (type
))
3399 type
= TREE_TYPE (type
);
3401 if (GFC_DESCRIPTOR_TYPE_P (type
))
3403 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
3405 while (POINTER_TYPE_P (etype
))
3406 etype
= TREE_TYPE (etype
);
3408 gfc_trans_vla_type_sizes_1 (etype
, body
);
3411 gfc_trans_vla_type_sizes_1 (type
, body
);
3415 /* Initialize a derived type by building an lvalue from the symbol
3416 and using trans_assignment to do the work. Set dealloc to false
3417 if no deallocation prior the assignment is needed. */
3419 gfc_init_default_dt (gfc_symbol
* sym
, stmtblock_t
* block
, bool dealloc
)
3427 gcc_assert (!sym
->attr
.allocatable
);
3428 gfc_set_sym_referenced (sym
);
3429 e
= gfc_lval_expr_from_sym (sym
);
3430 tmp
= gfc_trans_assignment (e
, sym
->value
, false, dealloc
);
3431 if (sym
->attr
.dummy
&& (sym
->attr
.optional
3432 || sym
->ns
->proc_name
->attr
.entry_master
))
3434 present
= gfc_conv_expr_present (sym
);
3435 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
), present
,
3436 tmp
, build_empty_stmt (input_location
));
3438 gfc_add_expr_to_block (block
, tmp
);
3443 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3444 them their default initializer, if they do not have allocatable
3445 components, they have their allocatable components deallocated. */
3448 init_intent_out_dt (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3451 gfc_formal_arglist
*f
;
3455 gfc_init_block (&init
);
3456 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3457 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3458 && !f
->sym
->attr
.pointer
3459 && f
->sym
->ts
.type
== BT_DERIVED
)
3461 if (f
->sym
->ts
.u
.derived
->attr
.alloc_comp
&& !f
->sym
->value
)
3463 tmp
= gfc_deallocate_alloc_comp (f
->sym
->ts
.u
.derived
,
3464 f
->sym
->backend_decl
,
3465 f
->sym
->as
? f
->sym
->as
->rank
: 0);
3467 if (f
->sym
->attr
.optional
3468 || f
->sym
->ns
->proc_name
->attr
.entry_master
)
3470 present
= gfc_conv_expr_present (f
->sym
);
3471 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3473 build_empty_stmt (input_location
));
3476 gfc_add_expr_to_block (&init
, tmp
);
3478 else if (f
->sym
->value
)
3479 gfc_init_default_dt (f
->sym
, &init
, true);
3481 else if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
3482 && f
->sym
->ts
.type
== BT_CLASS
3483 && !CLASS_DATA (f
->sym
)->attr
.class_pointer
3484 && CLASS_DATA (f
->sym
)->ts
.u
.derived
->attr
.alloc_comp
)
3486 tmp
= gfc_class_data_get (f
->sym
->backend_decl
);
3487 if (CLASS_DATA (f
->sym
)->as
== NULL
)
3488 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3489 tmp
= gfc_deallocate_alloc_comp (CLASS_DATA (f
->sym
)->ts
.u
.derived
,
3491 CLASS_DATA (f
->sym
)->as
?
3492 CLASS_DATA (f
->sym
)->as
->rank
: 0);
3494 if (f
->sym
->attr
.optional
|| f
->sym
->ns
->proc_name
->attr
.entry_master
)
3496 present
= gfc_conv_expr_present (f
->sym
);
3497 tmp
= build3_loc (input_location
, COND_EXPR
, TREE_TYPE (tmp
),
3499 build_empty_stmt (input_location
));
3502 gfc_add_expr_to_block (&init
, tmp
);
3505 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), NULL_TREE
);
3509 /* Generate function entry and exit code, and add it to the function body.
3511 Allocation and initialization of array variables.
3512 Allocation of character string variables.
3513 Initialization and possibly repacking of dummy arrays.
3514 Initialization of ASSIGN statement auxiliary variable.
3515 Initialization of ASSOCIATE names.
3516 Automatic deallocation. */
3519 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, gfc_wrapped_block
* block
)
3523 gfc_formal_arglist
*f
;
3524 stmtblock_t tmpblock
;
3525 bool seen_trans_deferred_array
= false;
3531 /* Deal with implicit return variables. Explicit return variables will
3532 already have been added. */
3533 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
3535 if (!current_fake_result_decl
)
3537 gfc_entry_list
*el
= NULL
;
3538 if (proc_sym
->attr
.entry_master
)
3540 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
3541 if (el
->sym
!= el
->sym
->result
)
3544 /* TODO: move to the appropriate place in resolve.c. */
3545 if (warn_return_type
&& el
== NULL
)
3546 gfc_warning ("Return value of function '%s' at %L not set",
3547 proc_sym
->name
, &proc_sym
->declared_at
);
3549 else if (proc_sym
->as
)
3551 tree result
= TREE_VALUE (current_fake_result_decl
);
3552 gfc_trans_dummy_array_bias (proc_sym
, result
, block
);
3554 /* An automatic character length, pointer array result. */
3555 if (proc_sym
->ts
.type
== BT_CHARACTER
3556 && TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3557 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3559 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
3561 if (proc_sym
->ts
.deferred
)
3564 gfc_save_backend_locus (&loc
);
3565 gfc_set_backend_locus (&proc_sym
->declared_at
);
3566 gfc_start_block (&init
);
3567 /* Zero the string length on entry. */
3568 gfc_add_modify (&init
, proc_sym
->ts
.u
.cl
->backend_decl
,
3569 build_int_cst (gfc_charlen_type_node
, 0));
3570 /* Null the pointer. */
3571 e
= gfc_lval_expr_from_sym (proc_sym
);
3572 gfc_init_se (&se
, NULL
);
3573 se
.want_pointer
= 1;
3574 gfc_conv_expr (&se
, e
);
3577 gfc_add_modify (&init
, tmp
,
3578 fold_convert (TREE_TYPE (se
.expr
),
3579 null_pointer_node
));
3580 gfc_restore_backend_locus (&loc
);
3582 /* Pass back the string length on exit. */
3583 tmp
= proc_sym
->ts
.u
.cl
->passed_length
;
3584 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3585 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3586 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3587 gfc_charlen_type_node
, tmp
,
3588 proc_sym
->ts
.u
.cl
->backend_decl
);
3589 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3591 else if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
3592 gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.u
.cl
, block
);
3595 gcc_assert (gfc_option
.flag_f2c
3596 && proc_sym
->ts
.type
== BT_COMPLEX
);
3599 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3600 should be done here so that the offsets and lbounds of arrays
3602 gfc_save_backend_locus (&loc
);
3603 gfc_set_backend_locus (&proc_sym
->declared_at
);
3604 init_intent_out_dt (proc_sym
, block
);
3605 gfc_restore_backend_locus (&loc
);
3607 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
3609 bool sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
3610 && sym
->ts
.u
.derived
->attr
.alloc_comp
;
3614 if (sym
->attr
.subref_array_pointer
3615 && GFC_DECL_SPAN (sym
->backend_decl
)
3616 && !TREE_STATIC (GFC_DECL_SPAN (sym
->backend_decl
)))
3618 gfc_init_block (&tmpblock
);
3619 gfc_add_modify (&tmpblock
, GFC_DECL_SPAN (sym
->backend_decl
),
3620 build_int_cst (gfc_array_index_type
, 0));
3621 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3625 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3627 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3628 array_type tmp
= sym
->as
->type
;
3629 if (tmp
== AS_ASSUMED_SIZE
&& sym
->as
->cp_was_assumed
)
3634 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3635 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3636 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3638 if (TREE_STATIC (sym
->backend_decl
))
3640 gfc_save_backend_locus (&loc
);
3641 gfc_set_backend_locus (&sym
->declared_at
);
3642 gfc_trans_static_array_pointer (sym
);
3643 gfc_restore_backend_locus (&loc
);
3647 seen_trans_deferred_array
= true;
3648 gfc_trans_deferred_array (sym
, block
);
3651 else if (sym
->attr
.codimension
&& TREE_STATIC (sym
->backend_decl
))
3653 gfc_init_block (&tmpblock
);
3654 gfc_trans_array_cobounds (TREE_TYPE (sym
->backend_decl
),
3656 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3660 else if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
3662 gfc_save_backend_locus (&loc
);
3663 gfc_set_backend_locus (&sym
->declared_at
);
3665 if (sym_has_alloc_comp
)
3667 seen_trans_deferred_array
= true;
3668 gfc_trans_deferred_array (sym
, block
);
3670 else if (sym
->ts
.type
== BT_DERIVED
3673 && sym
->attr
.save
== SAVE_NONE
)
3675 gfc_start_block (&tmpblock
);
3676 gfc_init_default_dt (sym
, &tmpblock
, false);
3677 gfc_add_init_cleanup (block
,
3678 gfc_finish_block (&tmpblock
),
3682 gfc_trans_auto_array_allocation (sym
->backend_decl
,
3684 gfc_restore_backend_locus (&loc
);
3688 case AS_ASSUMED_SIZE
:
3689 /* Must be a dummy parameter. */
3690 gcc_assert (sym
->attr
.dummy
|| sym
->as
->cp_was_assumed
);
3692 /* We should always pass assumed size arrays the g77 way. */
3693 if (sym
->attr
.dummy
)
3694 gfc_trans_g77_array (sym
, block
);
3697 case AS_ASSUMED_SHAPE
:
3698 /* Must be a dummy parameter. */
3699 gcc_assert (sym
->attr
.dummy
);
3701 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, block
);
3704 case AS_ASSUMED_RANK
:
3706 seen_trans_deferred_array
= true;
3707 gfc_trans_deferred_array (sym
, block
);
3713 if (sym_has_alloc_comp
&& !seen_trans_deferred_array
)
3714 gfc_trans_deferred_array (sym
, block
);
3716 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3717 && (sym
->ts
.type
== BT_CLASS
3718 && CLASS_DATA (sym
)->attr
.class_pointer
))
3720 else if ((!sym
->attr
.dummy
|| sym
->ts
.deferred
)
3721 && (sym
->attr
.allocatable
3722 || (sym
->ts
.type
== BT_CLASS
3723 && CLASS_DATA (sym
)->attr
.allocatable
)))
3725 if (!sym
->attr
.save
&& gfc_option
.flag_max_stack_var_size
!= 0)
3727 tree descriptor
= NULL_TREE
;
3729 /* Nullify and automatic deallocation of allocatable
3731 e
= gfc_lval_expr_from_sym (sym
);
3732 if (sym
->ts
.type
== BT_CLASS
)
3733 gfc_add_data_component (e
);
3735 gfc_init_se (&se
, NULL
);
3736 if (sym
->ts
.type
!= BT_CLASS
3737 || sym
->ts
.u
.derived
->attr
.dimension
3738 || sym
->ts
.u
.derived
->attr
.codimension
)
3740 se
.want_pointer
= 1;
3741 gfc_conv_expr (&se
, e
);
3743 else if (sym
->ts
.type
== BT_CLASS
3744 && !CLASS_DATA (sym
)->attr
.dimension
3745 && !CLASS_DATA (sym
)->attr
.codimension
)
3747 se
.want_pointer
= 1;
3748 gfc_conv_expr (&se
, e
);
3752 gfc_conv_expr (&se
, e
);
3753 descriptor
= se
.expr
;
3754 se
.expr
= gfc_conv_descriptor_data_addr (se
.expr
);
3755 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
3759 gfc_save_backend_locus (&loc
);
3760 gfc_set_backend_locus (&sym
->declared_at
);
3761 gfc_start_block (&init
);
3763 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3765 /* Nullify when entering the scope. */
3766 gfc_add_modify (&init
, se
.expr
,
3767 fold_convert (TREE_TYPE (se
.expr
),
3768 null_pointer_node
));
3771 if ((sym
->attr
.dummy
||sym
->attr
.result
)
3772 && sym
->ts
.type
== BT_CHARACTER
3773 && sym
->ts
.deferred
)
3775 /* Character length passed by reference. */
3776 tmp
= sym
->ts
.u
.cl
->passed_length
;
3777 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3778 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3780 if (!sym
->attr
.dummy
|| sym
->attr
.intent
== INTENT_OUT
)
3781 /* Zero the string length when entering the scope. */
3782 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
,
3783 build_int_cst (gfc_charlen_type_node
, 0));
3785 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
3787 gfc_restore_backend_locus (&loc
);
3789 /* Pass the final character length back. */
3790 if (sym
->attr
.intent
!= INTENT_IN
)
3791 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3792 gfc_charlen_type_node
, tmp
,
3793 sym
->ts
.u
.cl
->backend_decl
);
3798 gfc_restore_backend_locus (&loc
);
3800 /* Deallocate when leaving the scope. Nullifying is not
3802 if (!sym
->attr
.result
&& !sym
->attr
.dummy
)
3804 if (sym
->ts
.type
== BT_CLASS
3805 && CLASS_DATA (sym
)->attr
.codimension
)
3806 tmp
= gfc_deallocate_with_status (descriptor
, NULL_TREE
,
3807 NULL_TREE
, NULL_TREE
,
3808 NULL_TREE
, true, NULL
,
3811 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, NULL_TREE
,
3813 gfc_lval_expr_from_sym (sym
),
3816 if (sym
->ts
.type
== BT_CLASS
)
3818 /* Initialize _vptr to declared type. */
3819 gfc_symbol
*vtab
= gfc_find_derived_vtab (sym
->ts
.u
.derived
);
3822 gfc_save_backend_locus (&loc
);
3823 gfc_set_backend_locus (&sym
->declared_at
);
3824 e
= gfc_lval_expr_from_sym (sym
);
3825 gfc_add_vptr_component (e
);
3826 gfc_init_se (&se
, NULL
);
3827 se
.want_pointer
= 1;
3828 gfc_conv_expr (&se
, e
);
3830 rhs
= gfc_build_addr_expr (TREE_TYPE (se
.expr
),
3831 gfc_get_symbol_decl (vtab
));
3832 gfc_add_modify (&init
, se
.expr
, rhs
);
3833 gfc_restore_backend_locus (&loc
);
3836 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3839 else if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.deferred
)
3844 /* If we get to here, all that should be left are pointers. */
3845 gcc_assert (sym
->attr
.pointer
);
3847 if (sym
->attr
.dummy
)
3849 gfc_start_block (&init
);
3851 /* Character length passed by reference. */
3852 tmp
= sym
->ts
.u
.cl
->passed_length
;
3853 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3854 tmp
= fold_convert (gfc_charlen_type_node
, tmp
);
3855 gfc_add_modify (&init
, sym
->ts
.u
.cl
->backend_decl
, tmp
);
3856 /* Pass the final character length back. */
3857 if (sym
->attr
.intent
!= INTENT_IN
)
3858 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
,
3859 gfc_charlen_type_node
, tmp
,
3860 sym
->ts
.u
.cl
->backend_decl
);
3863 gfc_add_init_cleanup (block
, gfc_finish_block (&init
), tmp
);
3866 else if (sym
->ts
.deferred
)
3867 gfc_fatal_error ("Deferred type parameter not yet supported");
3868 else if (sym_has_alloc_comp
)
3869 gfc_trans_deferred_array (sym
, block
);
3870 else if (sym
->ts
.type
== BT_CHARACTER
)
3872 gfc_save_backend_locus (&loc
);
3873 gfc_set_backend_locus (&sym
->declared_at
);
3874 if (sym
->attr
.dummy
|| sym
->attr
.result
)
3875 gfc_trans_dummy_character (sym
, sym
->ts
.u
.cl
, block
);
3877 gfc_trans_auto_character_variable (sym
, block
);
3878 gfc_restore_backend_locus (&loc
);
3880 else if (sym
->attr
.assign
)
3882 gfc_save_backend_locus (&loc
);
3883 gfc_set_backend_locus (&sym
->declared_at
);
3884 gfc_trans_assign_aux_var (sym
, block
);
3885 gfc_restore_backend_locus (&loc
);
3887 else if (sym
->ts
.type
== BT_DERIVED
3890 && sym
->attr
.save
== SAVE_NONE
)
3892 gfc_start_block (&tmpblock
);
3893 gfc_init_default_dt (sym
, &tmpblock
, false);
3894 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
),
3901 gfc_init_block (&tmpblock
);
3903 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
3905 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
3907 gcc_assert (f
->sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3908 if (TREE_CODE (f
->sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3909 gfc_trans_vla_type_sizes (f
->sym
, &tmpblock
);
3913 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
3914 && current_fake_result_decl
!= NULL
)
3916 gcc_assert (proc_sym
->ts
.u
.cl
->backend_decl
!= NULL
);
3917 if (TREE_CODE (proc_sym
->ts
.u
.cl
->backend_decl
) == PARM_DECL
)
3918 gfc_trans_vla_type_sizes (proc_sym
, &tmpblock
);
3921 gfc_add_init_cleanup (block
, gfc_finish_block (&tmpblock
), NULL_TREE
);
3924 static GTY ((param_is (struct module_htab_entry
))) htab_t module_htab
;
3926 /* Hash and equality functions for module_htab. */
3929 module_htab_do_hash (const void *x
)
3931 return htab_hash_string (((const struct module_htab_entry
*)x
)->name
);
3935 module_htab_eq (const void *x1
, const void *x2
)
3937 return strcmp ((((const struct module_htab_entry
*)x1
)->name
),
3938 (const char *)x2
) == 0;
3941 /* Hash and equality functions for module_htab's decls. */
3944 module_htab_decls_hash (const void *x
)
3946 const_tree t
= (const_tree
) x
;
3947 const_tree n
= DECL_NAME (t
);
3949 n
= TYPE_NAME (TREE_TYPE (t
));
3950 return htab_hash_string (IDENTIFIER_POINTER (n
));
3954 module_htab_decls_eq (const void *x1
, const void *x2
)
3956 const_tree t1
= (const_tree
) x1
;
3957 const_tree n1
= DECL_NAME (t1
);
3958 if (n1
== NULL_TREE
)
3959 n1
= TYPE_NAME (TREE_TYPE (t1
));
3960 return strcmp (IDENTIFIER_POINTER (n1
), (const char *) x2
) == 0;
3963 struct module_htab_entry
*
3964 gfc_find_module (const char *name
)
3969 module_htab
= htab_create_ggc (10, module_htab_do_hash
,
3970 module_htab_eq
, NULL
);
3972 slot
= htab_find_slot_with_hash (module_htab
, name
,
3973 htab_hash_string (name
), INSERT
);
3976 struct module_htab_entry
*entry
= ggc_alloc_cleared_module_htab_entry ();
3978 entry
->name
= gfc_get_string (name
);
3979 entry
->decls
= htab_create_ggc (10, module_htab_decls_hash
,
3980 module_htab_decls_eq
, NULL
);
3981 *slot
= (void *) entry
;
3983 return (struct module_htab_entry
*) *slot
;
3987 gfc_module_add_decl (struct module_htab_entry
*entry
, tree decl
)
3992 if (DECL_NAME (decl
))
3993 name
= IDENTIFIER_POINTER (DECL_NAME (decl
));
3996 gcc_assert (TREE_CODE (decl
) == TYPE_DECL
);
3997 name
= IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl
)));
3999 slot
= htab_find_slot_with_hash (entry
->decls
, name
,
4000 htab_hash_string (name
), INSERT
);
4002 *slot
= (void *) decl
;
4005 static struct module_htab_entry
*cur_module
;
4007 /* Output an initialized decl for a module variable. */
4010 gfc_create_module_variable (gfc_symbol
* sym
)
4014 /* Module functions with alternate entries are dealt with later and
4015 would get caught by the next condition. */
4016 if (sym
->attr
.entry
)
4019 /* Make sure we convert the types of the derived types from iso_c_binding
4021 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4022 && sym
->ts
.type
== BT_DERIVED
)
4023 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4025 if (sym
->attr
.flavor
== FL_DERIVED
4026 && sym
->backend_decl
4027 && TREE_CODE (sym
->backend_decl
) == RECORD_TYPE
)
4029 decl
= sym
->backend_decl
;
4030 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4032 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
4033 if (!(gfc_option
.flag_whole_file
&& sym
->attr
.use_assoc
))
4035 gcc_assert (TYPE_CONTEXT (decl
) == NULL_TREE
4036 || TYPE_CONTEXT (decl
) == sym
->ns
->proc_name
->backend_decl
);
4037 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl
)) == NULL_TREE
4038 || DECL_CONTEXT (TYPE_STUB_DECL (decl
))
4039 == sym
->ns
->proc_name
->backend_decl
);
4041 TYPE_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4042 DECL_CONTEXT (TYPE_STUB_DECL (decl
)) = sym
->ns
->proc_name
->backend_decl
;
4043 gfc_module_add_decl (cur_module
, TYPE_STUB_DECL (decl
));
4046 /* Only output variables, procedure pointers and array valued,
4047 or derived type, parameters. */
4048 if (sym
->attr
.flavor
!= FL_VARIABLE
4049 && !(sym
->attr
.flavor
== FL_PARAMETER
4050 && (sym
->attr
.dimension
|| sym
->ts
.type
== BT_DERIVED
))
4051 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4054 if ((sym
->attr
.in_common
|| sym
->attr
.in_equivalence
) && sym
->backend_decl
)
4056 decl
= sym
->backend_decl
;
4057 gcc_assert (DECL_FILE_SCOPE_P (decl
));
4058 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4059 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4060 gfc_module_add_decl (cur_module
, decl
);
4063 /* Don't generate variables from other modules. Variables from
4064 COMMONs will already have been generated. */
4065 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
4068 /* Equivalenced variables arrive here after creation. */
4069 if (sym
->backend_decl
4070 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
4073 if (sym
->backend_decl
&& !sym
->attr
.vtab
&& !sym
->attr
.target
)
4074 internal_error ("backend decl for module variable %s already exists",
4077 /* We always want module variables to be created. */
4078 sym
->attr
.referenced
= 1;
4079 /* Create the decl. */
4080 decl
= gfc_get_symbol_decl (sym
);
4082 /* Create the variable. */
4084 gcc_assert (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
);
4085 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4086 rest_of_decl_compilation (decl
, 1, 0);
4087 gfc_module_add_decl (cur_module
, decl
);
4089 /* Also add length of strings. */
4090 if (sym
->ts
.type
== BT_CHARACTER
)
4094 length
= sym
->ts
.u
.cl
->backend_decl
;
4095 gcc_assert (length
|| sym
->attr
.proc_pointer
);
4096 if (length
&& !INTEGER_CST_P (length
))
4099 rest_of_decl_compilation (length
, 1, 0);
4103 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4104 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4105 has_coarray_vars
= true;
4108 /* Emit debug information for USE statements. */
4111 gfc_trans_use_stmts (gfc_namespace
* ns
)
4113 gfc_use_list
*use_stmt
;
4114 for (use_stmt
= ns
->use_stmts
; use_stmt
; use_stmt
= use_stmt
->next
)
4116 struct module_htab_entry
*entry
4117 = gfc_find_module (use_stmt
->module_name
);
4118 gfc_use_rename
*rent
;
4120 if (entry
->namespace_decl
== NULL
)
4122 entry
->namespace_decl
4123 = build_decl (input_location
,
4125 get_identifier (use_stmt
->module_name
),
4127 DECL_EXTERNAL (entry
->namespace_decl
) = 1;
4129 gfc_set_backend_locus (&use_stmt
->where
);
4130 if (!use_stmt
->only_flag
)
4131 (*debug_hooks
->imported_module_or_decl
) (entry
->namespace_decl
,
4133 ns
->proc_name
->backend_decl
,
4135 for (rent
= use_stmt
->rename
; rent
; rent
= rent
->next
)
4137 tree decl
, local_name
;
4140 if (rent
->op
!= INTRINSIC_NONE
)
4143 slot
= htab_find_slot_with_hash (entry
->decls
, rent
->use_name
,
4144 htab_hash_string (rent
->use_name
),
4150 st
= gfc_find_symtree (ns
->sym_root
,
4152 ? rent
->local_name
: rent
->use_name
);
4154 /* The following can happen if a derived type is renamed. */
4158 name
= xstrdup (rent
->local_name
[0]
4159 ? rent
->local_name
: rent
->use_name
);
4160 name
[0] = (char) TOUPPER ((unsigned char) name
[0]);
4161 st
= gfc_find_symtree (ns
->sym_root
, name
);
4166 /* Sometimes, generic interfaces wind up being over-ruled by a
4167 local symbol (see PR41062). */
4168 if (!st
->n
.sym
->attr
.use_assoc
)
4171 if (st
->n
.sym
->backend_decl
4172 && DECL_P (st
->n
.sym
->backend_decl
)
4173 && st
->n
.sym
->module
4174 && strcmp (st
->n
.sym
->module
, use_stmt
->module_name
) == 0)
4176 gcc_assert (DECL_EXTERNAL (entry
->namespace_decl
)
4177 || (TREE_CODE (st
->n
.sym
->backend_decl
)
4179 decl
= copy_node (st
->n
.sym
->backend_decl
);
4180 DECL_CONTEXT (decl
) = entry
->namespace_decl
;
4181 DECL_EXTERNAL (decl
) = 1;
4182 DECL_IGNORED_P (decl
) = 0;
4183 DECL_INITIAL (decl
) = NULL_TREE
;
4187 *slot
= error_mark_node
;
4188 htab_clear_slot (entry
->decls
, slot
);
4193 decl
= (tree
) *slot
;
4194 if (rent
->local_name
[0])
4195 local_name
= get_identifier (rent
->local_name
);
4197 local_name
= NULL_TREE
;
4198 gfc_set_backend_locus (&rent
->where
);
4199 (*debug_hooks
->imported_module_or_decl
) (decl
, local_name
,
4200 ns
->proc_name
->backend_decl
,
4201 !use_stmt
->only_flag
);
4207 /* Return true if expr is a constant initializer that gfc_conv_initializer
4211 check_constant_initializer (gfc_expr
*expr
, gfc_typespec
*ts
, bool array
,
4221 if (expr
->expr_type
== EXPR_CONSTANT
|| expr
->expr_type
== EXPR_NULL
)
4223 else if (expr
->expr_type
== EXPR_STRUCTURE
)
4224 return check_constant_initializer (expr
, ts
, false, false);
4225 else if (expr
->expr_type
!= EXPR_ARRAY
)
4227 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4228 c
; c
= gfc_constructor_next (c
))
4232 if (c
->expr
->expr_type
== EXPR_STRUCTURE
)
4234 if (!check_constant_initializer (c
->expr
, ts
, false, false))
4237 else if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
4242 else switch (ts
->type
)
4245 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4247 cm
= expr
->ts
.u
.derived
->components
;
4248 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4249 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4251 if (!c
->expr
|| cm
->attr
.allocatable
)
4253 if (!check_constant_initializer (c
->expr
, &cm
->ts
,
4260 return expr
->expr_type
== EXPR_CONSTANT
;
4264 /* Emit debug info for parameters and unreferenced variables with
4268 gfc_emit_parameter_debug_info (gfc_symbol
*sym
)
4272 if (sym
->attr
.flavor
!= FL_PARAMETER
4273 && (sym
->attr
.flavor
!= FL_VARIABLE
|| sym
->attr
.referenced
))
4276 if (sym
->backend_decl
!= NULL
4277 || sym
->value
== NULL
4278 || sym
->attr
.use_assoc
4281 || sym
->attr
.function
4282 || sym
->attr
.intrinsic
4283 || sym
->attr
.pointer
4284 || sym
->attr
.allocatable
4285 || sym
->attr
.cray_pointee
4286 || sym
->attr
.threadprivate
4287 || sym
->attr
.is_bind_c
4288 || sym
->attr
.subref_array_pointer
4289 || sym
->attr
.assign
)
4292 if (sym
->ts
.type
== BT_CHARACTER
)
4294 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
4295 if (sym
->ts
.u
.cl
->backend_decl
== NULL
4296 || TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) != INTEGER_CST
)
4299 else if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.alloc_comp
)
4306 if (sym
->as
->type
!= AS_EXPLICIT
)
4308 for (n
= 0; n
< sym
->as
->rank
; n
++)
4309 if (sym
->as
->lower
[n
]->expr_type
!= EXPR_CONSTANT
4310 || sym
->as
->upper
[n
] == NULL
4311 || sym
->as
->upper
[n
]->expr_type
!= EXPR_CONSTANT
)
4315 if (!check_constant_initializer (sym
->value
, &sym
->ts
,
4316 sym
->attr
.dimension
, false))
4319 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& sym
->attr
.codimension
)
4322 /* Create the decl for the variable or constant. */
4323 decl
= build_decl (input_location
,
4324 sym
->attr
.flavor
== FL_PARAMETER
? CONST_DECL
: VAR_DECL
,
4325 gfc_sym_identifier (sym
), gfc_sym_type (sym
));
4326 if (sym
->attr
.flavor
== FL_PARAMETER
)
4327 TREE_READONLY (decl
) = 1;
4328 gfc_set_decl_location (decl
, &sym
->declared_at
);
4329 if (sym
->attr
.dimension
)
4330 GFC_DECL_PACKED_ARRAY (decl
) = 1;
4331 DECL_CONTEXT (decl
) = sym
->ns
->proc_name
->backend_decl
;
4332 TREE_STATIC (decl
) = 1;
4333 TREE_USED (decl
) = 1;
4334 if (DECL_CONTEXT (decl
) && TREE_CODE (DECL_CONTEXT (decl
)) == NAMESPACE_DECL
)
4335 TREE_PUBLIC (decl
) = 1;
4336 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
4338 sym
->attr
.dimension
,
4340 debug_hooks
->global_decl (decl
);
4345 generate_coarray_sym_init (gfc_symbol
*sym
)
4347 tree tmp
, size
, decl
, token
;
4349 if (sym
->attr
.dummy
|| sym
->attr
.allocatable
|| !sym
->attr
.codimension
4350 || sym
->attr
.use_assoc
|| !sym
->attr
.referenced
)
4353 decl
= sym
->backend_decl
;
4354 TREE_USED(decl
) = 1;
4355 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
4357 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4358 to make sure the variable is not optimized away. */
4359 DECL_PRESERVE_P (DECL_CONTEXT (decl
)) = 1;
4361 size
= TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl
)));
4363 /* Ensure that we do not have size=0 for zero-sized arrays. */
4364 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
,
4365 fold_convert (size_type_node
, size
),
4366 build_int_cst (size_type_node
, 1));
4368 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl
)))
4370 tmp
= GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl
));
4371 size
= fold_build2_loc (input_location
, MULT_EXPR
, size_type_node
,
4372 fold_convert (size_type_node
, tmp
), size
);
4375 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl
)) != NULL_TREE
);
4376 token
= gfc_build_addr_expr (ppvoid_type_node
,
4377 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl
)));
4379 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_register
, 6, size
,
4380 build_int_cst (integer_type_node
,
4381 GFC_CAF_COARRAY_STATIC
), /* type. */
4382 token
, null_pointer_node
, /* token, stat. */
4383 null_pointer_node
, /* errgmsg, errmsg_len. */
4384 build_int_cst (integer_type_node
, 0));
4386 gfc_add_modify (&caf_init_block
, decl
, fold_convert (TREE_TYPE (decl
), tmp
));
4389 /* Handle "static" initializer. */
4392 sym
->attr
.pointer
= 1;
4393 tmp
= gfc_trans_assignment (gfc_lval_expr_from_sym (sym
), sym
->value
,
4395 sym
->attr
.pointer
= 0;
4396 gfc_add_expr_to_block (&caf_init_block
, tmp
);
4401 /* Generate constructor function to initialize static, nonallocatable
4405 generate_coarray_init (gfc_namespace
* ns
__attribute((unused
)))
4407 tree fndecl
, tmp
, decl
, save_fn_decl
;
4409 save_fn_decl
= current_function_decl
;
4410 push_function_context ();
4412 tmp
= build_function_type_list (void_type_node
, NULL_TREE
);
4413 fndecl
= build_decl (input_location
, FUNCTION_DECL
,
4414 create_tmp_var_name ("_caf_init"), tmp
);
4416 DECL_STATIC_CONSTRUCTOR (fndecl
) = 1;
4417 SET_DECL_INIT_PRIORITY (fndecl
, DEFAULT_INIT_PRIORITY
);
4419 decl
= build_decl (input_location
, RESULT_DECL
, NULL_TREE
, void_type_node
);
4420 DECL_ARTIFICIAL (decl
) = 1;
4421 DECL_IGNORED_P (decl
) = 1;
4422 DECL_CONTEXT (decl
) = fndecl
;
4423 DECL_RESULT (fndecl
) = decl
;
4426 current_function_decl
= fndecl
;
4427 announce_function (fndecl
);
4429 rest_of_decl_compilation (fndecl
, 0, 0);
4430 make_decl_rtl (fndecl
);
4431 allocate_struct_function (fndecl
, false);
4434 gfc_init_block (&caf_init_block
);
4436 gfc_traverse_ns (ns
, generate_coarray_sym_init
);
4438 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&caf_init_block
);
4442 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
4444 DECL_SAVED_TREE (fndecl
)
4445 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
4446 DECL_INITIAL (fndecl
));
4447 dump_function (TDI_original
, fndecl
);
4449 cfun
->function_end_locus
= input_location
;
4452 if (decl_function_context (fndecl
))
4453 (void) cgraph_create_node (fndecl
);
4455 cgraph_finalize_function (fndecl
, true);
4457 pop_function_context ();
4458 current_function_decl
= save_fn_decl
;
4462 /* Generate all the required code for module variables. */
4465 gfc_generate_module_vars (gfc_namespace
* ns
)
4467 module_namespace
= ns
;
4468 cur_module
= gfc_find_module (ns
->proc_name
->name
);
4470 /* Check if the frontend left the namespace in a reasonable state. */
4471 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
4473 /* Generate COMMON blocks. */
4474 gfc_trans_common (ns
);
4476 has_coarray_vars
= false;
4478 /* Create decls for all the module variables. */
4479 gfc_traverse_ns (ns
, gfc_create_module_variable
);
4481 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
4482 generate_coarray_init (ns
);
4486 gfc_trans_use_stmts (ns
);
4487 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
4492 gfc_generate_contained_functions (gfc_namespace
* parent
)
4496 /* We create all the prototypes before generating any code. */
4497 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4499 /* Skip namespaces from used modules. */
4500 if (ns
->parent
!= parent
)
4503 gfc_create_function_decl (ns
, false);
4506 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
4508 /* Skip namespaces from used modules. */
4509 if (ns
->parent
!= parent
)
4512 gfc_generate_function_code (ns
);
4517 /* Drill down through expressions for the array specification bounds and
4518 character length calling generate_local_decl for all those variables
4519 that have not already been declared. */
4522 generate_local_decl (gfc_symbol
*);
4524 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4527 expr_decls (gfc_expr
*e
, gfc_symbol
*sym
,
4528 int *f ATTRIBUTE_UNUSED
)
4530 if (e
->expr_type
!= EXPR_VARIABLE
4531 || sym
== e
->symtree
->n
.sym
4532 || e
->symtree
->n
.sym
->mark
4533 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
4536 generate_local_decl (e
->symtree
->n
.sym
);
4541 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
4543 gfc_traverse_expr (e
, sym
, expr_decls
, 0);
4547 /* Check for dependencies in the character length and array spec. */
4550 generate_dependency_declarations (gfc_symbol
*sym
)
4554 if (sym
->ts
.type
== BT_CHARACTER
4556 && sym
->ts
.u
.cl
->length
4557 && sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4558 generate_expr_decls (sym
, sym
->ts
.u
.cl
->length
);
4560 if (sym
->as
&& sym
->as
->rank
)
4562 for (i
= 0; i
< sym
->as
->rank
; i
++)
4564 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
4565 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
4571 /* Generate decls for all local variables. We do this to ensure correct
4572 handling of expressions which only appear in the specification of
4576 generate_local_decl (gfc_symbol
* sym
)
4578 if (sym
->attr
.flavor
== FL_VARIABLE
)
4580 if (sym
->attr
.codimension
&& !sym
->attr
.dummy
&& !sym
->attr
.allocatable
4581 && sym
->attr
.referenced
&& !sym
->attr
.use_assoc
)
4582 has_coarray_vars
= true;
4584 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
4585 generate_dependency_declarations (sym
);
4587 if (sym
->attr
.referenced
)
4588 gfc_get_symbol_decl (sym
);
4590 /* Warnings for unused dummy arguments. */
4591 else if (sym
->attr
.dummy
)
4593 /* INTENT(out) dummy arguments are likely meant to be set. */
4594 if (gfc_option
.warn_unused_dummy_argument
4595 && sym
->attr
.intent
== INTENT_OUT
)
4597 if (sym
->ts
.type
!= BT_DERIVED
)
4598 gfc_warning ("Dummy argument '%s' at %L was declared "
4599 "INTENT(OUT) but was not set", sym
->name
,
4601 else if (!gfc_has_default_initializer (sym
->ts
.u
.derived
))
4602 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4603 "declared INTENT(OUT) but was not set and "
4604 "does not have a default initializer",
4605 sym
->name
, &sym
->declared_at
);
4606 if (sym
->backend_decl
!= NULL_TREE
)
4607 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4609 else if (gfc_option
.warn_unused_dummy_argument
)
4611 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4613 if (sym
->backend_decl
!= NULL_TREE
)
4614 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4618 /* Warn for unused variables, but not if they're inside a common
4619 block or a namelist. */
4620 else if (warn_unused_variable
4621 && !(sym
->attr
.in_common
|| sym
->mark
|| sym
->attr
.in_namelist
))
4623 if (sym
->attr
.use_only
)
4625 gfc_warning ("Unused module variable '%s' which has been "
4626 "explicitly imported at %L", sym
->name
,
4628 if (sym
->backend_decl
!= NULL_TREE
)
4629 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4631 else if (!sym
->attr
.use_assoc
)
4633 gfc_warning ("Unused variable '%s' declared at %L",
4634 sym
->name
, &sym
->declared_at
);
4635 if (sym
->backend_decl
!= NULL_TREE
)
4636 TREE_NO_WARNING(sym
->backend_decl
) = 1;
4640 /* For variable length CHARACTER parameters, the PARM_DECL already
4641 references the length variable, so force gfc_get_symbol_decl
4642 even when not referenced. If optimize > 0, it will be optimized
4643 away anyway. But do this only after emitting -Wunused-parameter
4644 warning if requested. */
4645 if (sym
->attr
.dummy
&& !sym
->attr
.referenced
4646 && sym
->ts
.type
== BT_CHARACTER
4647 && sym
->ts
.u
.cl
->backend_decl
!= NULL
4648 && TREE_CODE (sym
->ts
.u
.cl
->backend_decl
) == VAR_DECL
)
4650 sym
->attr
.referenced
= 1;
4651 gfc_get_symbol_decl (sym
);
4654 /* INTENT(out) dummy arguments and result variables with allocatable
4655 components are reset by default and need to be set referenced to
4656 generate the code for nullification and automatic lengths. */
4657 if (!sym
->attr
.referenced
4658 && sym
->ts
.type
== BT_DERIVED
4659 && sym
->ts
.u
.derived
->attr
.alloc_comp
4660 && !sym
->attr
.pointer
4661 && ((sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
4663 (sym
->attr
.result
&& sym
!= sym
->result
)))
4665 sym
->attr
.referenced
= 1;
4666 gfc_get_symbol_decl (sym
);
4669 /* Check for dependencies in the array specification and string
4670 length, adding the necessary declarations to the function. We
4671 mark the symbol now, as well as in traverse_ns, to prevent
4672 getting stuck in a circular dependency. */
4675 else if (sym
->attr
.flavor
== FL_PARAMETER
)
4677 if (warn_unused_parameter
4678 && !sym
->attr
.referenced
)
4680 if (!sym
->attr
.use_assoc
)
4681 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
4683 else if (sym
->attr
.use_only
)
4684 gfc_warning ("Unused parameter '%s' which has been explicitly "
4685 "imported at %L", sym
->name
, &sym
->declared_at
);
4688 else if (sym
->attr
.flavor
== FL_PROCEDURE
)
4690 /* TODO: move to the appropriate place in resolve.c. */
4691 if (warn_return_type
4692 && sym
->attr
.function
4694 && sym
!= sym
->result
4695 && !sym
->result
->attr
.referenced
4696 && !sym
->attr
.use_assoc
4697 && sym
->attr
.if_source
!= IFSRC_IFBODY
)
4699 gfc_warning ("Return value '%s' of function '%s' declared at "
4700 "%L not set", sym
->result
->name
, sym
->name
,
4701 &sym
->result
->declared_at
);
4703 /* Prevents "Unused variable" warning for RESULT variables. */
4704 sym
->result
->mark
= 1;
4708 if (sym
->attr
.dummy
== 1)
4710 /* Modify the tree type for scalar character dummy arguments of bind(c)
4711 procedures if they are passed by value. The tree type for them will
4712 be promoted to INTEGER_TYPE for the middle end, which appears to be
4713 what C would do with characters passed by-value. The value attribute
4714 implies the dummy is a scalar. */
4715 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
4716 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
4717 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
4718 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
4720 /* Unused procedure passed as dummy argument. */
4721 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4723 if (!sym
->attr
.referenced
)
4725 if (gfc_option
.warn_unused_dummy_argument
)
4726 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
4730 /* Silence bogus "unused parameter" warnings from the
4732 if (sym
->backend_decl
!= NULL_TREE
)
4733 TREE_NO_WARNING (sym
->backend_decl
) = 1;
4737 /* Make sure we convert the types of the derived types from iso_c_binding
4739 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
4740 && sym
->ts
.type
== BT_DERIVED
)
4741 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
4745 generate_local_vars (gfc_namespace
* ns
)
4747 gfc_traverse_ns (ns
, generate_local_decl
);
4751 /* Generate a switch statement to jump to the correct entry point. Also
4752 creates the label decls for the entry points. */
4755 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
4762 gfc_init_block (&block
);
4763 for (; el
; el
= el
->next
)
4765 /* Add the case label. */
4766 label
= gfc_build_label_decl (NULL_TREE
);
4767 val
= build_int_cst (gfc_array_index_type
, el
->id
);
4768 tmp
= build_case_label (val
, NULL_TREE
, label
);
4769 gfc_add_expr_to_block (&block
, tmp
);
4771 /* And jump to the actual entry point. */
4772 label
= gfc_build_label_decl (NULL_TREE
);
4773 tmp
= build1_v (GOTO_EXPR
, label
);
4774 gfc_add_expr_to_block (&block
, tmp
);
4776 /* Save the label decl. */
4779 tmp
= gfc_finish_block (&block
);
4780 /* The first argument selects the entry point. */
4781 val
= DECL_ARGUMENTS (current_function_decl
);
4782 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
4783 val
, tmp
, NULL_TREE
);
4788 /* Add code to string lengths of actual arguments passed to a function against
4789 the expected lengths of the dummy arguments. */
4792 add_argument_checking (stmtblock_t
*block
, gfc_symbol
*sym
)
4794 gfc_formal_arglist
*formal
;
4796 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
4797 if (formal
->sym
&& formal
->sym
->ts
.type
== BT_CHARACTER
4798 && !formal
->sym
->ts
.deferred
)
4800 enum tree_code comparison
;
4805 const char *message
;
4811 gcc_assert (cl
->passed_length
!= NULL_TREE
);
4812 gcc_assert (cl
->backend_decl
!= NULL_TREE
);
4814 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4815 string lengths must match exactly. Otherwise, it is only required
4816 that the actual string length is *at least* the expected one.
4817 Sequence association allows for a mismatch of the string length
4818 if the actual argument is (part of) an array, but only if the
4819 dummy argument is an array. (See "Sequence association" in
4820 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4821 if (fsym
->attr
.pointer
|| fsym
->attr
.allocatable
4822 || (fsym
->as
&& (fsym
->as
->type
== AS_ASSUMED_SHAPE
4823 || fsym
->as
->type
== AS_ASSUMED_RANK
)))
4825 comparison
= NE_EXPR
;
4826 message
= _("Actual string length does not match the declared one"
4827 " for dummy argument '%s' (%ld/%ld)");
4829 else if (fsym
->as
&& fsym
->as
->rank
!= 0)
4833 comparison
= LT_EXPR
;
4834 message
= _("Actual string length is shorter than the declared one"
4835 " for dummy argument '%s' (%ld/%ld)");
4838 /* Build the condition. For optional arguments, an actual length
4839 of 0 is also acceptable if the associated string is NULL, which
4840 means the argument was not passed. */
4841 cond
= fold_build2_loc (input_location
, comparison
, boolean_type_node
,
4842 cl
->passed_length
, cl
->backend_decl
);
4843 if (fsym
->attr
.optional
)
4849 not_0length
= fold_build2_loc (input_location
, NE_EXPR
,
4852 build_zero_cst (gfc_charlen_type_node
));
4853 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4854 fsym
->attr
.referenced
= 1;
4855 not_absent
= gfc_conv_expr_present (fsym
);
4857 absent_failed
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
4858 boolean_type_node
, not_0length
,
4861 cond
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
,
4862 boolean_type_node
, cond
, absent_failed
);
4865 /* Build the runtime check. */
4866 argname
= gfc_build_cstring_const (fsym
->name
);
4867 argname
= gfc_build_addr_expr (pchar_type_node
, argname
);
4868 gfc_trans_runtime_check (true, false, cond
, block
, &fsym
->declared_at
,
4870 fold_convert (long_integer_type_node
,
4872 fold_convert (long_integer_type_node
,
4878 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4879 global variables for -fcoarray=lib. They are placed into the translation
4880 unit of the main program. Make sure that in one TU (the one of the main
4881 program), the first call to gfc_init_coarray_decl is done with true.
4882 Otherwise, expect link errors. */
4885 gfc_init_coarray_decl (bool main_tu
)
4887 if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
4890 if (gfort_gvar_caf_this_image
|| gfort_gvar_caf_num_images
)
4895 gfort_gvar_caf_this_image
4896 = build_decl (input_location
, VAR_DECL
,
4897 get_identifier (PREFIX("caf_this_image")),
4899 DECL_ARTIFICIAL (gfort_gvar_caf_this_image
) = 1;
4900 TREE_USED (gfort_gvar_caf_this_image
) = 1;
4901 TREE_PUBLIC (gfort_gvar_caf_this_image
) = 1;
4902 TREE_READONLY (gfort_gvar_caf_this_image
) = 0;
4905 TREE_STATIC (gfort_gvar_caf_this_image
) = 1;
4907 DECL_EXTERNAL (gfort_gvar_caf_this_image
) = 1;
4909 pushdecl_top_level (gfort_gvar_caf_this_image
);
4911 gfort_gvar_caf_num_images
4912 = build_decl (input_location
, VAR_DECL
,
4913 get_identifier (PREFIX("caf_num_images")),
4915 DECL_ARTIFICIAL (gfort_gvar_caf_num_images
) = 1;
4916 TREE_USED (gfort_gvar_caf_num_images
) = 1;
4917 TREE_PUBLIC (gfort_gvar_caf_num_images
) = 1;
4918 TREE_READONLY (gfort_gvar_caf_num_images
) = 0;
4921 TREE_STATIC (gfort_gvar_caf_num_images
) = 1;
4923 DECL_EXTERNAL (gfort_gvar_caf_num_images
) = 1;
4925 pushdecl_top_level (gfort_gvar_caf_num_images
);
4932 create_main_function (tree fndecl
)
4936 tree tmp
, decl
, result_decl
, argc
, argv
, typelist
, arglist
;
4939 old_context
= current_function_decl
;
4943 push_function_context ();
4944 saved_parent_function_decls
= saved_function_decls
;
4945 saved_function_decls
= NULL_TREE
;
4948 /* main() function must be declared with global scope. */
4949 gcc_assert (current_function_decl
== NULL_TREE
);
4951 /* Declare the function. */
4952 tmp
= build_function_type_list (integer_type_node
, integer_type_node
,
4953 build_pointer_type (pchar_type_node
),
4955 main_identifier_node
= get_identifier ("main");
4956 ftn_main
= build_decl (input_location
, FUNCTION_DECL
,
4957 main_identifier_node
, tmp
);
4958 DECL_EXTERNAL (ftn_main
) = 0;
4959 TREE_PUBLIC (ftn_main
) = 1;
4960 TREE_STATIC (ftn_main
) = 1;
4961 DECL_ATTRIBUTES (ftn_main
)
4962 = tree_cons (get_identifier("externally_visible"), NULL_TREE
, NULL_TREE
);
4964 /* Setup the result declaration (for "return 0"). */
4965 result_decl
= build_decl (input_location
,
4966 RESULT_DECL
, NULL_TREE
, integer_type_node
);
4967 DECL_ARTIFICIAL (result_decl
) = 1;
4968 DECL_IGNORED_P (result_decl
) = 1;
4969 DECL_CONTEXT (result_decl
) = ftn_main
;
4970 DECL_RESULT (ftn_main
) = result_decl
;
4972 pushdecl (ftn_main
);
4974 /* Get the arguments. */
4976 arglist
= NULL_TREE
;
4977 typelist
= TYPE_ARG_TYPES (TREE_TYPE (ftn_main
));
4979 tmp
= TREE_VALUE (typelist
);
4980 argc
= build_decl (input_location
, PARM_DECL
, get_identifier ("argc"), tmp
);
4981 DECL_CONTEXT (argc
) = ftn_main
;
4982 DECL_ARG_TYPE (argc
) = TREE_VALUE (typelist
);
4983 TREE_READONLY (argc
) = 1;
4984 gfc_finish_decl (argc
);
4985 arglist
= chainon (arglist
, argc
);
4987 typelist
= TREE_CHAIN (typelist
);
4988 tmp
= TREE_VALUE (typelist
);
4989 argv
= build_decl (input_location
, PARM_DECL
, get_identifier ("argv"), tmp
);
4990 DECL_CONTEXT (argv
) = ftn_main
;
4991 DECL_ARG_TYPE (argv
) = TREE_VALUE (typelist
);
4992 TREE_READONLY (argv
) = 1;
4993 DECL_BY_REFERENCE (argv
) = 1;
4994 gfc_finish_decl (argv
);
4995 arglist
= chainon (arglist
, argv
);
4997 DECL_ARGUMENTS (ftn_main
) = arglist
;
4998 current_function_decl
= ftn_main
;
4999 announce_function (ftn_main
);
5001 rest_of_decl_compilation (ftn_main
, 1, 0);
5002 make_decl_rtl (ftn_main
);
5003 allocate_struct_function (ftn_main
, false);
5006 gfc_init_block (&body
);
5008 /* Call some libgfortran initialization routines, call then MAIN__(). */
5010 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
5011 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5013 tree pint_type
, pppchar_type
;
5014 pint_type
= build_pointer_type (integer_type_node
);
5016 = build_pointer_type (build_pointer_type (pchar_type_node
));
5018 gfc_init_coarray_decl (true);
5019 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_init
, 4,
5020 gfc_build_addr_expr (pint_type
, argc
),
5021 gfc_build_addr_expr (pppchar_type
, argv
),
5022 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_this_image
),
5023 gfc_build_addr_expr (pint_type
, gfort_gvar_caf_num_images
));
5024 gfc_add_expr_to_block (&body
, tmp
);
5027 /* Call _gfortran_set_args (argc, argv). */
5028 TREE_USED (argc
) = 1;
5029 TREE_USED (argv
) = 1;
5030 tmp
= build_call_expr_loc (input_location
,
5031 gfor_fndecl_set_args
, 2, argc
, argv
);
5032 gfc_add_expr_to_block (&body
, tmp
);
5034 /* Add a call to set_options to set up the runtime library Fortran
5035 language standard parameters. */
5037 tree array_type
, array
, var
;
5038 vec
<constructor_elt
, va_gc
> *v
= NULL
;
5040 /* Passing a new option to the library requires four modifications:
5041 + add it to the tree_cons list below
5042 + change the array size in the call to build_array_type
5043 + change the first argument to the library call
5044 gfor_fndecl_set_options
5045 + modify the library (runtime/compile_options.c)! */
5047 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5048 build_int_cst (integer_type_node
,
5049 gfc_option
.warn_std
));
5050 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5051 build_int_cst (integer_type_node
,
5052 gfc_option
.allow_std
));
5053 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5054 build_int_cst (integer_type_node
, pedantic
));
5055 /* TODO: This is the old -fdump-core option, which is unused but
5056 passed due to ABI compatibility; remove when bumping the
5058 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5059 build_int_cst (integer_type_node
,
5061 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5062 build_int_cst (integer_type_node
,
5063 gfc_option
.flag_backtrace
));
5064 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5065 build_int_cst (integer_type_node
,
5066 gfc_option
.flag_sign_zero
));
5067 CONSTRUCTOR_APPEND_ELT (v
, NULL_TREE
,
5068 build_int_cst (integer_type_node
,
5070 & GFC_RTCHECK_BOUNDS
)));
5071 /* TODO: This is the -frange-check option, which no longer affects
5072 library behavior; when bumping the library ABI this slot can be
5073 reused for something else. As it is the last element in the
5074 array, we can instead leave it out altogether.
5075 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5076 build_int_cst (integer_type_node,
5077 gfc_option.flag_range_check));
5080 array_type
= build_array_type (integer_type_node
,
5081 build_index_type (size_int (6)));
5082 array
= build_constructor (array_type
, v
);
5083 TREE_CONSTANT (array
) = 1;
5084 TREE_STATIC (array
) = 1;
5086 /* Create a static variable to hold the jump table. */
5087 var
= gfc_create_var (array_type
, "options");
5088 TREE_CONSTANT (var
) = 1;
5089 TREE_STATIC (var
) = 1;
5090 TREE_READONLY (var
) = 1;
5091 DECL_INITIAL (var
) = array
;
5092 var
= gfc_build_addr_expr (build_pointer_type (integer_type_node
), var
);
5094 tmp
= build_call_expr_loc (input_location
,
5095 gfor_fndecl_set_options
, 2,
5096 build_int_cst (integer_type_node
, 7), var
);
5097 gfc_add_expr_to_block (&body
, tmp
);
5100 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5101 the library will raise a FPE when needed. */
5102 if (gfc_option
.fpe
!= 0)
5104 tmp
= build_call_expr_loc (input_location
,
5105 gfor_fndecl_set_fpe
, 1,
5106 build_int_cst (integer_type_node
,
5108 gfc_add_expr_to_block (&body
, tmp
);
5111 /* If this is the main program and an -fconvert option was provided,
5112 add a call to set_convert. */
5114 if (gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
5116 tmp
= build_call_expr_loc (input_location
,
5117 gfor_fndecl_set_convert
, 1,
5118 build_int_cst (integer_type_node
,
5119 gfc_option
.convert
));
5120 gfc_add_expr_to_block (&body
, tmp
);
5123 /* If this is the main program and an -frecord-marker option was provided,
5124 add a call to set_record_marker. */
5126 if (gfc_option
.record_marker
!= 0)
5128 tmp
= build_call_expr_loc (input_location
,
5129 gfor_fndecl_set_record_marker
, 1,
5130 build_int_cst (integer_type_node
,
5131 gfc_option
.record_marker
));
5132 gfc_add_expr_to_block (&body
, tmp
);
5135 if (gfc_option
.max_subrecord_length
!= 0)
5137 tmp
= build_call_expr_loc (input_location
,
5138 gfor_fndecl_set_max_subrecord_length
, 1,
5139 build_int_cst (integer_type_node
,
5140 gfc_option
.max_subrecord_length
));
5141 gfc_add_expr_to_block (&body
, tmp
);
5144 /* Call MAIN__(). */
5145 tmp
= build_call_expr_loc (input_location
,
5147 gfc_add_expr_to_block (&body
, tmp
);
5149 /* Mark MAIN__ as used. */
5150 TREE_USED (fndecl
) = 1;
5152 /* Coarray: Call _gfortran_caf_finalize(void). */
5153 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
)
5155 /* Per F2008, 8.5.1 END of the main program implies a
5157 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
5158 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
5159 gfc_add_expr_to_block (&body
, tmp
);
5161 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
5162 gfc_add_expr_to_block (&body
, tmp
);
5166 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, integer_type_node
,
5167 DECL_RESULT (ftn_main
),
5168 build_int_cst (integer_type_node
, 0));
5169 tmp
= build1_v (RETURN_EXPR
, tmp
);
5170 gfc_add_expr_to_block (&body
, tmp
);
5173 DECL_SAVED_TREE (ftn_main
) = gfc_finish_block (&body
);
5176 /* Finish off this function and send it for code generation. */
5178 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main
)) = ftn_main
;
5180 DECL_SAVED_TREE (ftn_main
)
5181 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (ftn_main
),
5182 DECL_INITIAL (ftn_main
));
5184 /* Output the GENERIC tree. */
5185 dump_function (TDI_original
, ftn_main
);
5187 cgraph_finalize_function (ftn_main
, true);
5191 pop_function_context ();
5192 saved_function_decls
= saved_parent_function_decls
;
5194 current_function_decl
= old_context
;
5198 /* Get the result expression for a procedure. */
5201 get_proc_result (gfc_symbol
* sym
)
5203 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
5205 if (current_fake_result_decl
!= NULL
)
5206 return TREE_VALUE (current_fake_result_decl
);
5211 return sym
->result
->backend_decl
;
5215 /* Generate an appropriate return-statement for a procedure. */
5218 gfc_generate_return (void)
5224 sym
= current_procedure_symbol
;
5225 fndecl
= sym
->backend_decl
;
5227 if (TREE_TYPE (DECL_RESULT (fndecl
)) == void_type_node
)
5231 result
= get_proc_result (sym
);
5233 /* Set the return value to the dummy result variable. The
5234 types may be different for scalar default REAL functions
5235 with -ff2c, therefore we have to convert. */
5236 if (result
!= NULL_TREE
)
5238 result
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
5239 result
= fold_build2_loc (input_location
, MODIFY_EXPR
,
5240 TREE_TYPE (result
), DECL_RESULT (fndecl
),
5245 return build1_v (RETURN_EXPR
, result
);
5249 /* Generate code for a function. */
5252 gfc_generate_function_code (gfc_namespace
* ns
)
5258 stmtblock_t init
, cleanup
;
5260 gfc_wrapped_block try_block
;
5261 tree recurcheckvar
= NULL_TREE
;
5263 gfc_symbol
*previous_procedure_symbol
;
5267 sym
= ns
->proc_name
;
5268 previous_procedure_symbol
= current_procedure_symbol
;
5269 current_procedure_symbol
= sym
;
5271 /* Check that the frontend isn't still using this. */
5272 gcc_assert (sym
->tlink
== NULL
);
5275 /* Create the declaration for functions with global scope. */
5276 if (!sym
->backend_decl
)
5277 gfc_create_function_decl (ns
, false);
5279 fndecl
= sym
->backend_decl
;
5280 old_context
= current_function_decl
;
5284 push_function_context ();
5285 saved_parent_function_decls
= saved_function_decls
;
5286 saved_function_decls
= NULL_TREE
;
5289 trans_function_start (sym
);
5291 gfc_init_block (&init
);
5293 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
5295 /* Copy length backend_decls to all entry point result
5300 gfc_conv_const_charlen (ns
->proc_name
->ts
.u
.cl
);
5301 backend_decl
= ns
->proc_name
->result
->ts
.u
.cl
->backend_decl
;
5302 for (el
= ns
->entries
; el
; el
= el
->next
)
5303 el
->sym
->result
->ts
.u
.cl
->backend_decl
= backend_decl
;
5306 /* Translate COMMON blocks. */
5307 gfc_trans_common (ns
);
5309 /* Null the parent fake result declaration if this namespace is
5310 a module function or an external procedures. */
5311 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5312 || ns
->parent
== NULL
)
5313 parent_fake_result_decl
= NULL_TREE
;
5315 gfc_generate_contained_functions (ns
);
5317 nonlocal_dummy_decls
= NULL
;
5318 nonlocal_dummy_decl_pset
= NULL
;
5320 has_coarray_vars
= false;
5321 generate_local_vars (ns
);
5323 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5324 generate_coarray_init (ns
);
5326 /* Keep the parent fake result declaration in module functions
5327 or external procedures. */
5328 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
5329 || ns
->parent
== NULL
)
5330 current_fake_result_decl
= parent_fake_result_decl
;
5332 current_fake_result_decl
= NULL_TREE
;
5334 is_recursive
= sym
->attr
.recursive
5335 || (sym
->attr
.entry_master
5336 && sym
->ns
->entries
->sym
->attr
.recursive
);
5337 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5339 && !gfc_option
.flag_recursive
)
5343 asprintf (&msg
, "Recursive call to nonrecursive procedure '%s'",
5345 recurcheckvar
= gfc_create_var (boolean_type_node
, "is_recursive");
5346 TREE_STATIC (recurcheckvar
) = 1;
5347 DECL_INITIAL (recurcheckvar
) = boolean_false_node
;
5348 gfc_add_expr_to_block (&init
, recurcheckvar
);
5349 gfc_trans_runtime_check (true, false, recurcheckvar
, &init
,
5350 &sym
->declared_at
, msg
);
5351 gfc_add_modify (&init
, recurcheckvar
, boolean_true_node
);
5355 /* Now generate the code for the body of this function. */
5356 gfc_init_block (&body
);
5358 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
5359 && sym
->attr
.subroutine
)
5361 tree alternate_return
;
5362 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
5363 gfc_add_modify (&body
, alternate_return
, integer_zero_node
);
5368 /* Jump to the correct entry point. */
5369 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
5370 gfc_add_expr_to_block (&body
, tmp
);
5373 /* If bounds-checking is enabled, generate code to check passed in actual
5374 arguments against the expected dummy argument attributes (e.g. string
5376 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && !sym
->attr
.is_bind_c
)
5377 add_argument_checking (&body
, sym
);
5379 tmp
= gfc_trans_code (ns
->code
);
5380 gfc_add_expr_to_block (&body
, tmp
);
5382 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
5384 tree result
= get_proc_result (sym
);
5386 if (result
!= NULL_TREE
&& sym
->attr
.function
&& !sym
->attr
.pointer
)
5388 if (sym
->attr
.allocatable
&& sym
->attr
.dimension
== 0
5389 && sym
->result
== sym
)
5390 gfc_add_modify (&init
, result
, fold_convert (TREE_TYPE (result
),
5391 null_pointer_node
));
5392 else if (sym
->ts
.type
== BT_CLASS
5393 && CLASS_DATA (sym
)->attr
.allocatable
5394 && CLASS_DATA (sym
)->attr
.dimension
== 0
5395 && sym
->result
== sym
)
5397 tmp
= CLASS_DATA (sym
)->backend_decl
;
5398 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
5399 TREE_TYPE (tmp
), result
, tmp
, NULL_TREE
);
5400 gfc_add_modify (&init
, tmp
, fold_convert (TREE_TYPE (tmp
),
5401 null_pointer_node
));
5403 else if (sym
->ts
.type
== BT_DERIVED
5404 && sym
->ts
.u
.derived
->attr
.alloc_comp
5405 && !sym
->attr
.allocatable
)
5407 rank
= sym
->as
? sym
->as
->rank
: 0;
5408 tmp
= gfc_nullify_alloc_comp (sym
->ts
.u
.derived
, result
, rank
);
5409 gfc_add_expr_to_block (&init
, tmp
);
5413 if (result
== NULL_TREE
)
5415 /* TODO: move to the appropriate place in resolve.c. */
5416 if (warn_return_type
&& sym
== sym
->result
)
5417 gfc_warning ("Return value of function '%s' at %L not set",
5418 sym
->name
, &sym
->declared_at
);
5419 if (warn_return_type
)
5420 TREE_NO_WARNING(sym
->backend_decl
) = 1;
5423 gfc_add_expr_to_block (&body
, gfc_generate_return ());
5426 gfc_init_block (&cleanup
);
5428 /* Reset recursion-check variable. */
5429 if ((gfc_option
.rtcheck
& GFC_RTCHECK_RECURSION
)
5431 && !gfc_option
.gfc_flag_openmp
5432 && recurcheckvar
!= NULL_TREE
)
5434 gfc_add_modify (&cleanup
, recurcheckvar
, boolean_false_node
);
5435 recurcheckvar
= NULL
;
5438 /* Finish the function body and add init and cleanup code. */
5439 tmp
= gfc_finish_block (&body
);
5440 gfc_start_wrapped_block (&try_block
, tmp
);
5441 /* Add code to create and cleanup arrays. */
5442 gfc_trans_deferred_vars (sym
, &try_block
);
5443 gfc_add_init_cleanup (&try_block
, gfc_finish_block (&init
),
5444 gfc_finish_block (&cleanup
));
5446 /* Add all the decls we created during processing. */
5447 decl
= saved_function_decls
;
5452 next
= DECL_CHAIN (decl
);
5453 DECL_CHAIN (decl
) = NULL_TREE
;
5457 saved_function_decls
= NULL_TREE
;
5459 DECL_SAVED_TREE (fndecl
) = gfc_finish_wrapped_block (&try_block
);
5462 /* Finish off this function and send it for code generation. */
5464 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5466 DECL_SAVED_TREE (fndecl
)
5467 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5468 DECL_INITIAL (fndecl
));
5470 if (nonlocal_dummy_decls
)
5472 BLOCK_VARS (DECL_INITIAL (fndecl
))
5473 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl
)), nonlocal_dummy_decls
);
5474 pointer_set_destroy (nonlocal_dummy_decl_pset
);
5475 nonlocal_dummy_decls
= NULL
;
5476 nonlocal_dummy_decl_pset
= NULL
;
5479 /* Output the GENERIC tree. */
5480 dump_function (TDI_original
, fndecl
);
5482 /* Store the end of the function, so that we get good line number
5483 info for the epilogue. */
5484 cfun
->function_end_locus
= input_location
;
5486 /* We're leaving the context of this function, so zap cfun.
5487 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5488 tree_rest_of_compilation. */
5493 pop_function_context ();
5494 saved_function_decls
= saved_parent_function_decls
;
5496 current_function_decl
= old_context
;
5498 if (decl_function_context (fndecl
) && gfc_option
.coarray
!= GFC_FCOARRAY_LIB
5499 && has_coarray_vars
)
5500 /* Register this function with cgraph just far enough to get it
5501 added to our parent's nested function list.
5502 If there are static coarrays in this function, the nested _caf_init
5503 function has already called cgraph_create_node, which also created
5504 the cgraph node for this function. */
5505 (void) cgraph_create_node (fndecl
);
5507 cgraph_finalize_function (fndecl
, true);
5509 gfc_trans_use_stmts (ns
);
5510 gfc_traverse_ns (ns
, gfc_emit_parameter_debug_info
);
5512 if (sym
->attr
.is_main_program
)
5513 create_main_function (fndecl
);
5515 current_procedure_symbol
= previous_procedure_symbol
;
5520 gfc_generate_constructors (void)
5522 gcc_assert (gfc_static_ctors
== NULL_TREE
);
5530 if (gfc_static_ctors
== NULL_TREE
)
5533 fnname
= get_file_function_name ("I");
5534 type
= build_function_type_list (void_type_node
, NULL_TREE
);
5536 fndecl
= build_decl (input_location
,
5537 FUNCTION_DECL
, fnname
, type
);
5538 TREE_PUBLIC (fndecl
) = 1;
5540 decl
= build_decl (input_location
,
5541 RESULT_DECL
, NULL_TREE
, void_type_node
);
5542 DECL_ARTIFICIAL (decl
) = 1;
5543 DECL_IGNORED_P (decl
) = 1;
5544 DECL_CONTEXT (decl
) = fndecl
;
5545 DECL_RESULT (fndecl
) = decl
;
5549 current_function_decl
= fndecl
;
5551 rest_of_decl_compilation (fndecl
, 1, 0);
5553 make_decl_rtl (fndecl
);
5555 allocate_struct_function (fndecl
, false);
5559 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
5561 tmp
= build_call_expr_loc (input_location
,
5562 TREE_VALUE (gfc_static_ctors
), 0);
5563 DECL_SAVED_TREE (fndecl
) = build_stmt (input_location
, EXPR_STMT
, tmp
);
5569 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
5570 DECL_SAVED_TREE (fndecl
)
5571 = build3_v (BIND_EXPR
, decl
, DECL_SAVED_TREE (fndecl
),
5572 DECL_INITIAL (fndecl
));
5574 free_after_parsing (cfun
);
5575 free_after_compilation (cfun
);
5577 tree_rest_of_compilation (fndecl
);
5579 current_function_decl
= NULL_TREE
;
5583 /* Translates a BLOCK DATA program unit. This means emitting the
5584 commons contained therein plus their initializations. We also emit
5585 a globally visible symbol to make sure that each BLOCK DATA program
5586 unit remains unique. */
5589 gfc_generate_block_data (gfc_namespace
* ns
)
5594 /* Tell the backend the source location of the block data. */
5596 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
5598 gfc_set_backend_locus (&gfc_current_locus
);
5600 /* Process the DATA statements. */
5601 gfc_trans_common (ns
);
5603 /* Create a global symbol with the mane of the block data. This is to
5604 generate linker errors if the same name is used twice. It is never
5607 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
5609 id
= get_identifier ("__BLOCK_DATA__");
5611 decl
= build_decl (input_location
,
5612 VAR_DECL
, id
, gfc_array_index_type
);
5613 TREE_PUBLIC (decl
) = 1;
5614 TREE_STATIC (decl
) = 1;
5615 DECL_IGNORED_P (decl
) = 1;
5618 rest_of_decl_compilation (decl
, 1, 0);
5622 /* Process the local variables of a BLOCK construct. */
5625 gfc_process_block_locals (gfc_namespace
* ns
)
5629 gcc_assert (saved_local_decls
== NULL_TREE
);
5630 has_coarray_vars
= false;
5632 generate_local_vars (ns
);
5634 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& has_coarray_vars
)
5635 generate_coarray_init (ns
);
5637 decl
= saved_local_decls
;
5642 next
= DECL_CHAIN (decl
);
5643 DECL_CHAIN (decl
) = NULL_TREE
;
5647 saved_local_decls
= NULL_TREE
;
5651 #include "gt-fortran-trans-decl.h"