1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "trans-const.h"
43 /* Only for gfc_trans_code. Shouldn't need to include this. */
44 #include "trans-stmt.h"
46 #define MAX_LABEL_VALUE 99999
49 /* Holds the result of the function if no result variable specified. */
51 static GTY(()) tree current_fake_result_decl
;
52 static GTY(()) tree parent_fake_result_decl
;
54 static GTY(()) tree current_function_return_label
;
57 /* Holds the variable DECLs for the current function. */
59 static GTY(()) tree saved_function_decls
;
60 static GTY(()) tree saved_parent_function_decls
;
63 /* The namespace of the module we're currently generating. Only used while
64 outputting decls for module variables. Do not rely on this being set. */
66 static gfc_namespace
*module_namespace
;
69 /* List of static constructor functions. */
71 tree gfc_static_ctors
;
74 /* Function declarations for builtin library functions. */
76 tree gfor_fndecl_pause_numeric
;
77 tree gfor_fndecl_pause_string
;
78 tree gfor_fndecl_stop_numeric
;
79 tree gfor_fndecl_stop_string
;
80 tree gfor_fndecl_select_string
;
81 tree gfor_fndecl_runtime_error
;
82 tree gfor_fndecl_runtime_error_at
;
83 tree gfor_fndecl_os_error
;
84 tree gfor_fndecl_generate_error
;
85 tree gfor_fndecl_set_fpe
;
86 tree gfor_fndecl_set_options
;
87 tree gfor_fndecl_set_convert
;
88 tree gfor_fndecl_set_record_marker
;
89 tree gfor_fndecl_set_max_subrecord_length
;
90 tree gfor_fndecl_ctime
;
91 tree gfor_fndecl_fdate
;
92 tree gfor_fndecl_ttynam
;
93 tree gfor_fndecl_in_pack
;
94 tree gfor_fndecl_in_unpack
;
95 tree gfor_fndecl_associated
;
98 /* Math functions. Many other math functions are handled in
101 gfc_powdecl_list gfor_fndecl_math_powi
[4][3];
102 tree gfor_fndecl_math_cpowf
;
103 tree gfor_fndecl_math_cpow
;
104 tree gfor_fndecl_math_cpowl10
;
105 tree gfor_fndecl_math_cpowl16
;
106 tree gfor_fndecl_math_ishftc4
;
107 tree gfor_fndecl_math_ishftc8
;
108 tree gfor_fndecl_math_ishftc16
;
109 tree gfor_fndecl_math_exponent4
;
110 tree gfor_fndecl_math_exponent8
;
111 tree gfor_fndecl_math_exponent10
;
112 tree gfor_fndecl_math_exponent16
;
115 /* String functions. */
117 tree gfor_fndecl_compare_string
;
118 tree gfor_fndecl_concat_string
;
119 tree gfor_fndecl_string_len_trim
;
120 tree gfor_fndecl_string_index
;
121 tree gfor_fndecl_string_scan
;
122 tree gfor_fndecl_string_verify
;
123 tree gfor_fndecl_string_trim
;
124 tree gfor_fndecl_string_minmax
;
125 tree gfor_fndecl_adjustl
;
126 tree gfor_fndecl_adjustr
;
129 /* Other misc. runtime library functions. */
131 tree gfor_fndecl_size0
;
132 tree gfor_fndecl_size1
;
133 tree gfor_fndecl_iargc
;
135 /* Intrinsic functions implemented in FORTRAN. */
136 tree gfor_fndecl_si_kind
;
137 tree gfor_fndecl_sr_kind
;
139 /* BLAS gemm functions. */
140 tree gfor_fndecl_sgemm
;
141 tree gfor_fndecl_dgemm
;
142 tree gfor_fndecl_cgemm
;
143 tree gfor_fndecl_zgemm
;
147 gfc_add_decl_to_parent_function (tree decl
)
150 DECL_CONTEXT (decl
) = DECL_CONTEXT (current_function_decl
);
151 DECL_NONLOCAL (decl
) = 1;
152 TREE_CHAIN (decl
) = saved_parent_function_decls
;
153 saved_parent_function_decls
= decl
;
157 gfc_add_decl_to_function (tree decl
)
160 TREE_USED (decl
) = 1;
161 DECL_CONTEXT (decl
) = current_function_decl
;
162 TREE_CHAIN (decl
) = saved_function_decls
;
163 saved_function_decls
= decl
;
167 /* Build a backend label declaration. Set TREE_USED for named labels.
168 The context of the label is always the current_function_decl. All
169 labels are marked artificial. */
172 gfc_build_label_decl (tree label_id
)
174 /* 2^32 temporaries should be enough. */
175 static unsigned int tmp_num
= 1;
179 if (label_id
== NULL_TREE
)
181 /* Build an internal label name. */
182 ASM_FORMAT_PRIVATE_NAME (label_name
, "L", tmp_num
++);
183 label_id
= get_identifier (label_name
);
188 /* Build the LABEL_DECL node. Labels have no type. */
189 label_decl
= build_decl (LABEL_DECL
, label_id
, void_type_node
);
190 DECL_CONTEXT (label_decl
) = current_function_decl
;
191 DECL_MODE (label_decl
) = VOIDmode
;
193 /* We always define the label as used, even if the original source
194 file never references the label. We don't want all kinds of
195 spurious warnings for old-style Fortran code with too many
197 TREE_USED (label_decl
) = 1;
199 DECL_ARTIFICIAL (label_decl
) = 1;
204 /* Returns the return label for the current function. */
207 gfc_get_return_label (void)
209 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
211 if (current_function_return_label
)
212 return current_function_return_label
;
214 sprintf (name
, "__return_%s",
215 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
217 current_function_return_label
=
218 gfc_build_label_decl (get_identifier (name
));
220 DECL_ARTIFICIAL (current_function_return_label
) = 1;
222 return current_function_return_label
;
226 /* Set the backend source location of a decl. */
229 gfc_set_decl_location (tree decl
, locus
* loc
)
231 #ifdef USE_MAPPED_LOCATION
232 DECL_SOURCE_LOCATION (decl
) = loc
->lb
->location
;
234 DECL_SOURCE_LINE (decl
) = loc
->lb
->linenum
;
235 DECL_SOURCE_FILE (decl
) = loc
->lb
->file
->filename
;
240 /* Return the backend label declaration for a given label structure,
241 or create it if it doesn't exist yet. */
244 gfc_get_label_decl (gfc_st_label
* lp
)
246 if (lp
->backend_decl
)
247 return lp
->backend_decl
;
250 char label_name
[GFC_MAX_SYMBOL_LEN
+ 1];
253 /* Validate the label declaration from the front end. */
254 gcc_assert (lp
!= NULL
&& lp
->value
<= MAX_LABEL_VALUE
);
256 /* Build a mangled name for the label. */
257 sprintf (label_name
, "__label_%.6d", lp
->value
);
259 /* Build the LABEL_DECL node. */
260 label_decl
= gfc_build_label_decl (get_identifier (label_name
));
262 /* Tell the debugger where the label came from. */
263 if (lp
->value
<= MAX_LABEL_VALUE
) /* An internal label. */
264 gfc_set_decl_location (label_decl
, &lp
->where
);
266 DECL_ARTIFICIAL (label_decl
) = 1;
268 /* Store the label in the label list and return the LABEL_DECL. */
269 lp
->backend_decl
= label_decl
;
275 /* Convert a gfc_symbol to an identifier of the same name. */
278 gfc_sym_identifier (gfc_symbol
* sym
)
280 return (get_identifier (sym
->name
));
284 /* Construct mangled name from symbol name. */
287 gfc_sym_mangled_identifier (gfc_symbol
* sym
)
289 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
291 /* Prevent the mangling of identifiers that have an assigned
292 binding label (mainly those that are bind(c)). */
293 if (sym
->attr
.is_bind_c
== 1
294 && sym
->binding_label
[0] != '\0')
295 return get_identifier(sym
->binding_label
);
297 if (sym
->module
== NULL
)
298 return gfc_sym_identifier (sym
);
301 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
302 return get_identifier (name
);
307 /* Construct mangled function name from symbol name. */
310 gfc_sym_mangled_function_id (gfc_symbol
* sym
)
313 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
315 /* It may be possible to simply use the binding label if it's
316 provided, and remove the other checks. Then we could use it
317 for other things if we wished. */
318 if ((sym
->attr
.is_bind_c
== 1 || sym
->attr
.is_iso_c
== 1) &&
319 sym
->binding_label
[0] != '\0')
320 /* use the binding label rather than the mangled name */
321 return get_identifier (sym
->binding_label
);
323 if (sym
->module
== NULL
|| sym
->attr
.proc
== PROC_EXTERNAL
324 || (sym
->module
!= NULL
&& (sym
->attr
.external
325 || sym
->attr
.if_source
== IFSRC_IFBODY
)))
327 if (strcmp (sym
->name
, "MAIN__") == 0
328 || sym
->attr
.proc
== PROC_INTRINSIC
)
329 return get_identifier (sym
->name
);
331 if (gfc_option
.flag_underscoring
)
333 has_underscore
= strchr (sym
->name
, '_') != 0;
334 if (gfc_option
.flag_second_underscore
&& has_underscore
)
335 snprintf (name
, sizeof name
, "%s__", sym
->name
);
337 snprintf (name
, sizeof name
, "%s_", sym
->name
);
338 return get_identifier (name
);
341 return get_identifier (sym
->name
);
345 snprintf (name
, sizeof name
, "__%s_MOD_%s", sym
->module
, sym
->name
);
346 return get_identifier (name
);
351 /* Returns true if a variable of specified size should go on the stack. */
354 gfc_can_put_var_on_stack (tree size
)
356 unsigned HOST_WIDE_INT low
;
358 if (!INTEGER_CST_P (size
))
361 if (gfc_option
.flag_max_stack_var_size
< 0)
364 if (TREE_INT_CST_HIGH (size
) != 0)
367 low
= TREE_INT_CST_LOW (size
);
368 if (low
> (unsigned HOST_WIDE_INT
) gfc_option
.flag_max_stack_var_size
)
371 /* TODO: Set a per-function stack size limit. */
377 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
378 an expression involving its corresponding pointer. There are
379 2 cases; one for variable size arrays, and one for everything else,
380 because variable-sized arrays require one fewer level of
384 gfc_finish_cray_pointee (tree decl
, gfc_symbol
*sym
)
386 tree ptr_decl
= gfc_get_symbol_decl (sym
->cp_pointer
);
389 /* Parameters need to be dereferenced. */
390 if (sym
->cp_pointer
->attr
.dummy
)
391 ptr_decl
= build_fold_indirect_ref (ptr_decl
);
393 /* Check to see if we're dealing with a variable-sized array. */
394 if (sym
->attr
.dimension
395 && TREE_CODE (TREE_TYPE (decl
)) == POINTER_TYPE
)
397 /* These decls will be dereferenced later, so we don't dereference
399 value
= convert (TREE_TYPE (decl
), ptr_decl
);
403 ptr_decl
= convert (build_pointer_type (TREE_TYPE (decl
)),
405 value
= build_fold_indirect_ref (ptr_decl
);
408 SET_DECL_VALUE_EXPR (decl
, value
);
409 DECL_HAS_VALUE_EXPR_P (decl
) = 1;
410 GFC_DECL_CRAY_POINTEE (decl
) = 1;
411 /* This is a fake variable just for debugging purposes. */
412 TREE_ASM_WRITTEN (decl
) = 1;
416 /* Finish processing of a declaration without an initial value. */
419 gfc_finish_decl (tree decl
)
421 gcc_assert (TREE_CODE (decl
) == PARM_DECL
422 || DECL_INITIAL (decl
) == NULL_TREE
);
424 if (TREE_CODE (decl
) != VAR_DECL
)
427 if (DECL_SIZE (decl
) == NULL_TREE
428 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
429 layout_decl (decl
, 0);
431 /* A few consistency checks. */
432 /* A static variable with an incomplete type is an error if it is
433 initialized. Also if it is not file scope. Otherwise, let it
434 through, but if it is not `extern' then it may cause an error
436 /* An automatic variable with an incomplete type is an error. */
438 /* We should know the storage size. */
439 gcc_assert (DECL_SIZE (decl
) != NULL_TREE
440 || (TREE_STATIC (decl
)
441 ? (!DECL_INITIAL (decl
) || !DECL_CONTEXT (decl
))
442 : DECL_EXTERNAL (decl
)));
444 /* The storage size should be constant. */
445 gcc_assert ((!DECL_EXTERNAL (decl
) && !TREE_STATIC (decl
))
447 || TREE_CODE (DECL_SIZE (decl
)) == INTEGER_CST
);
451 /* Apply symbol attributes to a variable, and add it to the function scope. */
454 gfc_finish_var_decl (tree decl
, gfc_symbol
* sym
)
457 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
458 This is the equivalent of the TARGET variables.
459 We also need to set this if the variable is passed by reference in a
462 /* Set DECL_VALUE_EXPR for Cray Pointees. */
463 if (sym
->attr
.cray_pointee
)
464 gfc_finish_cray_pointee (decl
, sym
);
466 if (sym
->attr
.target
)
467 TREE_ADDRESSABLE (decl
) = 1;
468 /* If it wasn't used we wouldn't be getting it. */
469 TREE_USED (decl
) = 1;
471 /* Chain this decl to the pending declarations. Don't do pushdecl()
472 because this would add them to the current scope rather than the
474 if (current_function_decl
!= NULL_TREE
)
476 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
477 || sym
->result
== sym
)
478 gfc_add_decl_to_function (decl
);
480 gfc_add_decl_to_parent_function (decl
);
483 if (sym
->attr
.cray_pointee
)
486 if(sym
->attr
.is_bind_c
== 1)
488 /* We need to put variables that are bind(c) into the common
489 segment of the object file, because this is what C would do.
490 gfortran would typically put them in either the BSS or
491 initialized data segments, and only mark them as common if
492 they were part of common blocks. However, if they are not put
493 into common space, then C cannot initialize global fortran
494 variables that it interoperates with and the draft says that
495 either Fortran or C should be able to initialize it (but not
496 both, of course.) (J3/04-007, section 15.3). */
497 TREE_PUBLIC(decl
) = 1;
498 DECL_COMMON(decl
) = 1;
501 /* If a variable is USE associated, it's always external. */
502 if (sym
->attr
.use_assoc
)
504 DECL_EXTERNAL (decl
) = 1;
505 TREE_PUBLIC (decl
) = 1;
507 else if (sym
->module
&& !sym
->attr
.result
&& !sym
->attr
.dummy
)
509 /* TODO: Don't set sym->module for result or dummy variables. */
510 gcc_assert (current_function_decl
== NULL_TREE
|| sym
->result
== sym
);
511 /* This is the declaration of a module variable. */
512 TREE_PUBLIC (decl
) = 1;
513 TREE_STATIC (decl
) = 1;
516 if ((sym
->attr
.save
|| sym
->attr
.data
|| sym
->value
)
517 && !sym
->attr
.use_assoc
)
518 TREE_STATIC (decl
) = 1;
520 if (sym
->attr
.volatile_
)
522 TREE_THIS_VOLATILE (decl
) = 1;
523 new = build_qualified_type (TREE_TYPE (decl
), TYPE_QUAL_VOLATILE
);
524 TREE_TYPE (decl
) = new;
527 /* Keep variables larger than max-stack-var-size off stack. */
528 if (!sym
->ns
->proc_name
->attr
.recursive
529 && INTEGER_CST_P (DECL_SIZE_UNIT (decl
))
530 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl
))
531 /* Put variable length auto array pointers always into stack. */
532 && (TREE_CODE (TREE_TYPE (decl
)) != POINTER_TYPE
533 || sym
->attr
.dimension
== 0
534 || sym
->as
->type
!= AS_EXPLICIT
536 || sym
->attr
.allocatable
)
537 && !DECL_ARTIFICIAL (decl
))
538 TREE_STATIC (decl
) = 1;
540 /* Handle threadprivate variables. */
541 if (sym
->attr
.threadprivate
542 && (TREE_STATIC (decl
) || DECL_EXTERNAL (decl
)))
543 DECL_TLS_MODEL (decl
) = decl_default_tls_model (decl
);
547 /* Allocate the lang-specific part of a decl. */
550 gfc_allocate_lang_decl (tree decl
)
552 DECL_LANG_SPECIFIC (decl
) = (struct lang_decl
*)
553 ggc_alloc_cleared (sizeof (struct lang_decl
));
556 /* Remember a symbol to generate initialization/cleanup code at function
560 gfc_defer_symbol_init (gfc_symbol
* sym
)
566 /* Don't add a symbol twice. */
570 last
= head
= sym
->ns
->proc_name
;
573 /* Make sure that setup code for dummy variables which are used in the
574 setup of other variables is generated first. */
577 /* Find the first dummy arg seen after us, or the first non-dummy arg.
578 This is a circular list, so don't go past the head. */
580 && (!p
->attr
.dummy
|| p
->dummy_order
> sym
->dummy_order
))
586 /* Insert in between last and p. */
592 /* Create an array index type variable with function scope. */
595 create_index_var (const char * pfx
, int nest
)
599 decl
= gfc_create_var_np (gfc_array_index_type
, pfx
);
601 gfc_add_decl_to_parent_function (decl
);
603 gfc_add_decl_to_function (decl
);
608 /* Create variables to hold all the non-constant bits of info for a
609 descriptorless array. Remember these in the lang-specific part of the
613 gfc_build_qualified_array (tree decl
, gfc_symbol
* sym
)
619 type
= TREE_TYPE (decl
);
621 /* We just use the descriptor, if there is one. */
622 if (GFC_DESCRIPTOR_TYPE_P (type
))
625 gcc_assert (GFC_ARRAY_TYPE_P (type
));
626 nest
= (sym
->ns
->proc_name
->backend_decl
!= current_function_decl
)
627 && !sym
->attr
.contained
;
629 for (dim
= 0; dim
< GFC_TYPE_ARRAY_RANK (type
); dim
++)
631 if (GFC_TYPE_ARRAY_LBOUND (type
, dim
) == NULL_TREE
)
633 GFC_TYPE_ARRAY_LBOUND (type
, dim
) = create_index_var ("lbound", nest
);
634 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type
, dim
)) = 1;
636 /* Don't try to use the unknown bound for assumed shape arrays. */
637 if (GFC_TYPE_ARRAY_UBOUND (type
, dim
) == NULL_TREE
638 && (sym
->as
->type
!= AS_ASSUMED_SIZE
639 || dim
< GFC_TYPE_ARRAY_RANK (type
) - 1))
641 GFC_TYPE_ARRAY_UBOUND (type
, dim
) = create_index_var ("ubound", nest
);
642 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type
, dim
)) = 1;
645 if (GFC_TYPE_ARRAY_STRIDE (type
, dim
) == NULL_TREE
)
647 GFC_TYPE_ARRAY_STRIDE (type
, dim
) = create_index_var ("stride", nest
);
648 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type
, dim
)) = 1;
651 if (GFC_TYPE_ARRAY_OFFSET (type
) == NULL_TREE
)
653 GFC_TYPE_ARRAY_OFFSET (type
) = gfc_create_var_np (gfc_array_index_type
,
655 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type
)) = 1;
658 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type
));
660 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type
));
663 if (GFC_TYPE_ARRAY_SIZE (type
) == NULL_TREE
664 && sym
->as
->type
!= AS_ASSUMED_SIZE
)
666 GFC_TYPE_ARRAY_SIZE (type
) = create_index_var ("size", nest
);
667 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type
)) = 1;
670 if (POINTER_TYPE_P (type
))
672 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type
)));
673 gcc_assert (TYPE_LANG_SPECIFIC (type
)
674 == TYPE_LANG_SPECIFIC (TREE_TYPE (type
)));
675 type
= TREE_TYPE (type
);
678 if (! COMPLETE_TYPE_P (type
) && GFC_TYPE_ARRAY_SIZE (type
))
682 size
= build2 (MINUS_EXPR
, gfc_array_index_type
,
683 GFC_TYPE_ARRAY_SIZE (type
), gfc_index_one_node
);
684 range
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
,
686 TYPE_DOMAIN (type
) = range
;
692 /* For some dummy arguments we don't use the actual argument directly.
693 Instead we create a local decl and use that. This allows us to perform
694 initialization, and construct full type information. */
697 gfc_build_dummy_array_decl (gfc_symbol
* sym
, tree dummy
)
707 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
710 /* Add to list of variables if not a fake result variable. */
711 if (sym
->attr
.result
|| sym
->attr
.dummy
)
712 gfc_defer_symbol_init (sym
);
714 type
= TREE_TYPE (dummy
);
715 gcc_assert (TREE_CODE (dummy
) == PARM_DECL
716 && POINTER_TYPE_P (type
));
718 /* Do we know the element size? */
719 known_size
= sym
->ts
.type
!= BT_CHARACTER
720 || INTEGER_CST_P (sym
->ts
.cl
->backend_decl
);
722 if (known_size
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type
)))
724 /* For descriptorless arrays with known element size the actual
725 argument is sufficient. */
726 gcc_assert (GFC_ARRAY_TYPE_P (type
));
727 gfc_build_qualified_array (dummy
, sym
);
731 type
= TREE_TYPE (type
);
732 if (GFC_DESCRIPTOR_TYPE_P (type
))
734 /* Create a descriptorless array pointer. */
737 if (!gfc_option
.flag_repack_arrays
)
739 if (as
->type
== AS_ASSUMED_SIZE
)
740 packed
= PACKED_FULL
;
744 if (as
->type
== AS_EXPLICIT
)
746 packed
= PACKED_FULL
;
747 for (n
= 0; n
< as
->rank
; n
++)
751 && as
->upper
[n
]->expr_type
== EXPR_CONSTANT
752 && as
->lower
[n
]->expr_type
== EXPR_CONSTANT
))
753 packed
= PACKED_PARTIAL
;
757 packed
= PACKED_PARTIAL
;
760 type
= gfc_typenode_for_spec (&sym
->ts
);
761 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
765 /* We now have an expression for the element size, so create a fully
766 qualified type. Reset sym->backend decl or this will just return the
768 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
769 sym
->backend_decl
= NULL_TREE
;
770 type
= gfc_sym_type (sym
);
771 packed
= PACKED_FULL
;
774 ASM_FORMAT_PRIVATE_NAME (name
, IDENTIFIER_POINTER (DECL_NAME (dummy
)), 0);
775 decl
= build_decl (VAR_DECL
, get_identifier (name
), type
);
777 DECL_ARTIFICIAL (decl
) = 1;
778 TREE_PUBLIC (decl
) = 0;
779 TREE_STATIC (decl
) = 0;
780 DECL_EXTERNAL (decl
) = 0;
782 /* We should never get deferred shape arrays here. We used to because of
784 gcc_assert (sym
->as
->type
!= AS_DEFERRED
);
786 if (packed
== PACKED_PARTIAL
)
787 GFC_DECL_PARTIAL_PACKED_ARRAY (decl
) = 1;
788 else if (packed
== PACKED_FULL
)
789 GFC_DECL_PACKED_ARRAY (decl
) = 1;
791 gfc_build_qualified_array (decl
, sym
);
793 if (DECL_LANG_SPECIFIC (dummy
))
794 DECL_LANG_SPECIFIC (decl
) = DECL_LANG_SPECIFIC (dummy
);
796 gfc_allocate_lang_decl (decl
);
798 GFC_DECL_SAVED_DESCRIPTOR (decl
) = dummy
;
800 if (sym
->ns
->proc_name
->backend_decl
== current_function_decl
801 || sym
->attr
.contained
)
802 gfc_add_decl_to_function (decl
);
804 gfc_add_decl_to_parent_function (decl
);
810 /* Return a constant or a variable to use as a string length. Does not
811 add the decl to the current scope. */
814 gfc_create_string_length (gfc_symbol
* sym
)
818 gcc_assert (sym
->ts
.cl
);
819 gfc_conv_const_charlen (sym
->ts
.cl
);
821 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
823 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
825 /* Also prefix the mangled name. */
826 strcpy (&name
[1], sym
->name
);
828 length
= build_decl (VAR_DECL
, get_identifier (name
),
829 gfc_charlen_type_node
);
830 DECL_ARTIFICIAL (length
) = 1;
831 TREE_USED (length
) = 1;
832 if (sym
->ns
->proc_name
->tlink
!= NULL
)
833 gfc_defer_symbol_init (sym
);
834 sym
->ts
.cl
->backend_decl
= length
;
837 return sym
->ts
.cl
->backend_decl
;
840 /* If a variable is assigned a label, we add another two auxiliary
844 gfc_add_assign_aux_vars (gfc_symbol
* sym
)
850 gcc_assert (sym
->backend_decl
);
852 decl
= sym
->backend_decl
;
853 gfc_allocate_lang_decl (decl
);
854 GFC_DECL_ASSIGN (decl
) = 1;
855 length
= build_decl (VAR_DECL
, create_tmp_var_name (sym
->name
),
856 gfc_charlen_type_node
);
857 addr
= build_decl (VAR_DECL
, create_tmp_var_name (sym
->name
),
859 gfc_finish_var_decl (length
, sym
);
860 gfc_finish_var_decl (addr
, sym
);
861 /* STRING_LENGTH is also used as flag. Less than -1 means that
862 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
863 target label's address. Otherwise, value is the length of a format string
864 and ASSIGN_ADDR is its address. */
865 if (TREE_STATIC (length
))
866 DECL_INITIAL (length
) = build_int_cst (NULL_TREE
, -2);
868 gfc_defer_symbol_init (sym
);
870 GFC_DECL_STRING_LEN (decl
) = length
;
871 GFC_DECL_ASSIGN_ADDR (decl
) = addr
;
874 /* Return the decl for a gfc_symbol, create it if it doesn't already
878 gfc_get_symbol_decl (gfc_symbol
* sym
)
881 tree length
= NULL_TREE
;
884 gcc_assert (sym
->attr
.referenced
885 || sym
->attr
.use_assoc
886 || sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
);
888 if (sym
->ns
&& sym
->ns
->proc_name
->attr
.function
)
889 byref
= gfc_return_by_reference (sym
->ns
->proc_name
);
893 if ((sym
->attr
.dummy
&& ! sym
->attr
.function
) || (sym
->attr
.result
&& byref
))
895 /* Return via extra parameter. */
896 if (sym
->attr
.result
&& byref
897 && !sym
->backend_decl
)
900 DECL_ARGUMENTS (sym
->ns
->proc_name
->backend_decl
);
901 /* For entry master function skip over the __entry
903 if (sym
->ns
->proc_name
->attr
.entry_master
)
904 sym
->backend_decl
= TREE_CHAIN (sym
->backend_decl
);
907 /* Dummy variables should already have been created. */
908 gcc_assert (sym
->backend_decl
);
910 /* Create a character length variable. */
911 if (sym
->ts
.type
== BT_CHARACTER
)
913 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
914 length
= gfc_create_string_length (sym
);
916 length
= sym
->ts
.cl
->backend_decl
;
917 if (TREE_CODE (length
) == VAR_DECL
918 && DECL_CONTEXT (length
) == NULL_TREE
)
920 /* Add the string length to the same context as the symbol. */
921 if (DECL_CONTEXT (sym
->backend_decl
) == current_function_decl
)
922 gfc_add_decl_to_function (length
);
924 gfc_add_decl_to_parent_function (length
);
926 gcc_assert (DECL_CONTEXT (sym
->backend_decl
) ==
927 DECL_CONTEXT (length
));
929 gfc_defer_symbol_init (sym
);
933 /* Use a copy of the descriptor for dummy arrays. */
934 if (sym
->attr
.dimension
&& !TREE_USED (sym
->backend_decl
))
936 decl
= gfc_build_dummy_array_decl (sym
, sym
->backend_decl
);
937 /* Prevent the dummy from being detected as unused if it is copied. */
938 if (sym
->backend_decl
!= NULL
&& decl
!= sym
->backend_decl
)
939 DECL_ARTIFICIAL (sym
->backend_decl
) = 1;
940 sym
->backend_decl
= decl
;
943 TREE_USED (sym
->backend_decl
) = 1;
944 if (sym
->attr
.assign
&& GFC_DECL_ASSIGN (sym
->backend_decl
) == 0)
946 gfc_add_assign_aux_vars (sym
);
948 return sym
->backend_decl
;
951 if (sym
->backend_decl
)
952 return sym
->backend_decl
;
954 /* Catch function declarations. Only used for actual parameters. */
955 if (sym
->attr
.flavor
== FL_PROCEDURE
)
957 decl
= gfc_get_extern_function_decl (sym
);
961 if (sym
->attr
.intrinsic
)
962 internal_error ("intrinsic variable which isn't a procedure");
964 /* Create string length decl first so that they can be used in the
966 if (sym
->ts
.type
== BT_CHARACTER
)
967 length
= gfc_create_string_length (sym
);
969 /* Create the decl for the variable. */
970 decl
= build_decl (VAR_DECL
, gfc_sym_identifier (sym
), gfc_sym_type (sym
));
972 gfc_set_decl_location (decl
, &sym
->declared_at
);
974 /* Symbols from modules should have their assembler names mangled.
975 This is done here rather than in gfc_finish_var_decl because it
976 is different for string length variables. */
978 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_identifier (sym
));
980 if (sym
->attr
.dimension
)
982 /* Create variables to hold the non-constant bits of array info. */
983 gfc_build_qualified_array (decl
, sym
);
985 /* Remember this variable for allocation/cleanup. */
986 gfc_defer_symbol_init (sym
);
988 if ((sym
->attr
.allocatable
|| !sym
->attr
.dummy
) && !sym
->attr
.pointer
)
989 GFC_DECL_PACKED_ARRAY (decl
) = 1;
992 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->attr
.alloc_comp
)
993 gfc_defer_symbol_init (sym
);
995 gfc_finish_var_decl (decl
, sym
);
997 if (sym
->ts
.type
== BT_CHARACTER
)
999 /* Character variables need special handling. */
1000 gfc_allocate_lang_decl (decl
);
1002 if (TREE_CODE (length
) != INTEGER_CST
)
1004 char name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 2];
1008 /* Also prefix the mangled name for symbols from modules. */
1009 strcpy (&name
[1], sym
->name
);
1012 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length
)));
1013 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (name
));
1015 gfc_finish_var_decl (length
, sym
);
1016 gcc_assert (!sym
->value
);
1019 sym
->backend_decl
= decl
;
1021 if (sym
->attr
.assign
)
1022 gfc_add_assign_aux_vars (sym
);
1024 if (TREE_STATIC (decl
) && !sym
->attr
.use_assoc
)
1026 /* Add static initializer. */
1027 DECL_INITIAL (decl
) = gfc_conv_initializer (sym
->value
, &sym
->ts
,
1028 TREE_TYPE (decl
), sym
->attr
.dimension
,
1029 sym
->attr
.pointer
|| sym
->attr
.allocatable
);
1036 /* Substitute a temporary variable in place of the real one. */
1039 gfc_shadow_sym (gfc_symbol
* sym
, tree decl
, gfc_saved_var
* save
)
1041 save
->attr
= sym
->attr
;
1042 save
->decl
= sym
->backend_decl
;
1044 gfc_clear_attr (&sym
->attr
);
1045 sym
->attr
.referenced
= 1;
1046 sym
->attr
.flavor
= FL_VARIABLE
;
1048 sym
->backend_decl
= decl
;
1052 /* Restore the original variable. */
1055 gfc_restore_sym (gfc_symbol
* sym
, gfc_saved_var
* save
)
1057 sym
->attr
= save
->attr
;
1058 sym
->backend_decl
= save
->decl
;
1062 /* Get a basic decl for an external function. */
1065 gfc_get_extern_function_decl (gfc_symbol
* sym
)
1070 gfc_intrinsic_sym
*isym
;
1072 char s
[GFC_MAX_SYMBOL_LEN
+ 23]; /* "_gfortran_f2c_specific" and '\0'. */
1076 if (sym
->backend_decl
)
1077 return sym
->backend_decl
;
1079 /* We should never be creating external decls for alternate entry points.
1080 The procedure may be an alternate entry point, but we don't want/need
1082 gcc_assert (!(sym
->attr
.entry
|| sym
->attr
.entry_master
));
1084 if (sym
->attr
.intrinsic
)
1086 /* Call the resolution function to get the actual name. This is
1087 a nasty hack which relies on the resolution functions only looking
1088 at the first argument. We pass NULL for the second argument
1089 otherwise things like AINT get confused. */
1090 isym
= gfc_find_function (sym
->name
);
1091 gcc_assert (isym
->resolve
.f0
!= NULL
);
1093 memset (&e
, 0, sizeof (e
));
1094 e
.expr_type
= EXPR_FUNCTION
;
1096 memset (&argexpr
, 0, sizeof (argexpr
));
1097 gcc_assert (isym
->formal
);
1098 argexpr
.ts
= isym
->formal
->ts
;
1100 if (isym
->formal
->next
== NULL
)
1101 isym
->resolve
.f1 (&e
, &argexpr
);
1104 if (isym
->formal
->next
->next
== NULL
)
1105 isym
->resolve
.f2 (&e
, &argexpr
, NULL
);
1108 if (isym
->formal
->next
->next
->next
== NULL
)
1109 isym
->resolve
.f3 (&e
, &argexpr
, NULL
, NULL
);
1112 /* All specific intrinsics take less than 5 arguments. */
1113 gcc_assert (isym
->formal
->next
->next
->next
->next
== NULL
);
1114 isym
->resolve
.f4 (&e
, &argexpr
, NULL
, NULL
, NULL
);
1119 if (gfc_option
.flag_f2c
1120 && ((e
.ts
.type
== BT_REAL
&& e
.ts
.kind
== gfc_default_real_kind
)
1121 || e
.ts
.type
== BT_COMPLEX
))
1123 /* Specific which needs a different implementation if f2c
1124 calling conventions are used. */
1125 sprintf (s
, "_gfortran_f2c_specific%s", e
.value
.function
.name
);
1128 sprintf (s
, "_gfortran_specific%s", e
.value
.function
.name
);
1130 name
= get_identifier (s
);
1131 mangled_name
= name
;
1135 name
= gfc_sym_identifier (sym
);
1136 mangled_name
= gfc_sym_mangled_function_id (sym
);
1139 type
= gfc_get_function_type (sym
);
1140 fndecl
= build_decl (FUNCTION_DECL
, name
, type
);
1142 SET_DECL_ASSEMBLER_NAME (fndecl
, mangled_name
);
1143 /* If the return type is a pointer, avoid alias issues by setting
1144 DECL_IS_MALLOC to nonzero. This means that the function should be
1145 treated as if it were a malloc, meaning it returns a pointer that
1147 if (POINTER_TYPE_P (type
))
1148 DECL_IS_MALLOC (fndecl
) = 1;
1150 /* Set the context of this decl. */
1151 if (0 && sym
->ns
&& sym
->ns
->proc_name
)
1153 /* TODO: Add external decls to the appropriate scope. */
1154 DECL_CONTEXT (fndecl
) = sym
->ns
->proc_name
->backend_decl
;
1158 /* Global declaration, e.g. intrinsic subroutine. */
1159 DECL_CONTEXT (fndecl
) = NULL_TREE
;
1162 DECL_EXTERNAL (fndecl
) = 1;
1164 /* This specifies if a function is globally addressable, i.e. it is
1165 the opposite of declaring static in C. */
1166 TREE_PUBLIC (fndecl
) = 1;
1168 /* Set attributes for PURE functions. A call to PURE function in the
1169 Fortran 95 sense is both pure and without side effects in the C
1171 if (sym
->attr
.pure
|| sym
->attr
.elemental
)
1173 if (sym
->attr
.function
&& !gfc_return_by_reference (sym
))
1174 DECL_IS_PURE (fndecl
) = 1;
1175 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1176 parameters and don't use alternate returns (is this
1177 allowed?). In that case, calls to them are meaningless, and
1178 can be optimized away. See also in build_function_decl(). */
1179 TREE_SIDE_EFFECTS (fndecl
) = 0;
1182 /* Mark non-returning functions. */
1183 if (sym
->attr
.noreturn
)
1184 TREE_THIS_VOLATILE(fndecl
) = 1;
1186 sym
->backend_decl
= fndecl
;
1188 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1189 pushdecl_top_level (fndecl
);
1195 /* Create a declaration for a procedure. For external functions (in the C
1196 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1197 a master function with alternate entry points. */
1200 build_function_decl (gfc_symbol
* sym
)
1203 symbol_attribute attr
;
1205 gfc_formal_arglist
*f
;
1207 gcc_assert (!sym
->backend_decl
);
1208 gcc_assert (!sym
->attr
.external
);
1210 /* Set the line and filename. sym->declared_at seems to point to the
1211 last statement for subroutines, but it'll do for now. */
1212 gfc_set_backend_locus (&sym
->declared_at
);
1214 /* Allow only one nesting level. Allow public declarations. */
1215 gcc_assert (current_function_decl
== NULL_TREE
1216 || DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
1218 type
= gfc_get_function_type (sym
);
1219 fndecl
= build_decl (FUNCTION_DECL
, gfc_sym_identifier (sym
), type
);
1221 /* Perform name mangling if this is a top level or module procedure. */
1222 if (current_function_decl
== NULL_TREE
)
1223 SET_DECL_ASSEMBLER_NAME (fndecl
, gfc_sym_mangled_function_id (sym
));
1225 /* Figure out the return type of the declared function, and build a
1226 RESULT_DECL for it. If this is a subroutine with alternate
1227 returns, build a RESULT_DECL for it. */
1230 result_decl
= NULL_TREE
;
1231 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1234 if (gfc_return_by_reference (sym
))
1235 type
= void_type_node
;
1238 if (sym
->result
!= sym
)
1239 result_decl
= gfc_sym_identifier (sym
->result
);
1241 type
= TREE_TYPE (TREE_TYPE (fndecl
));
1246 /* Look for alternate return placeholders. */
1247 int has_alternate_returns
= 0;
1248 for (f
= sym
->formal
; f
; f
= f
->next
)
1252 has_alternate_returns
= 1;
1257 if (has_alternate_returns
)
1258 type
= integer_type_node
;
1260 type
= void_type_node
;
1263 result_decl
= build_decl (RESULT_DECL
, result_decl
, type
);
1264 DECL_ARTIFICIAL (result_decl
) = 1;
1265 DECL_IGNORED_P (result_decl
) = 1;
1266 DECL_CONTEXT (result_decl
) = fndecl
;
1267 DECL_RESULT (fndecl
) = result_decl
;
1269 /* Don't call layout_decl for a RESULT_DECL.
1270 layout_decl (result_decl, 0); */
1272 /* If the return type is a pointer, avoid alias issues by setting
1273 DECL_IS_MALLOC to nonzero. This means that the function should be
1274 treated as if it were a malloc, meaning it returns a pointer that
1276 if (POINTER_TYPE_P (type
))
1277 DECL_IS_MALLOC (fndecl
) = 1;
1279 /* Set up all attributes for the function. */
1280 DECL_CONTEXT (fndecl
) = current_function_decl
;
1281 DECL_EXTERNAL (fndecl
) = 0;
1283 /* This specifies if a function is globally visible, i.e. it is
1284 the opposite of declaring static in C. */
1285 if (DECL_CONTEXT (fndecl
) == NULL_TREE
1286 && !sym
->attr
.entry_master
)
1287 TREE_PUBLIC (fndecl
) = 1;
1289 /* TREE_STATIC means the function body is defined here. */
1290 TREE_STATIC (fndecl
) = 1;
1292 /* Set attributes for PURE functions. A call to a PURE function in the
1293 Fortran 95 sense is both pure and without side effects in the C
1295 if (attr
.pure
|| attr
.elemental
)
1297 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1298 including an alternate return. In that case it can also be
1299 marked as PURE. See also in gfc_get_extern_function_decl(). */
1300 if (attr
.function
&& !gfc_return_by_reference (sym
))
1301 DECL_IS_PURE (fndecl
) = 1;
1302 TREE_SIDE_EFFECTS (fndecl
) = 0;
1305 /* Layout the function declaration and put it in the binding level
1306 of the current function. */
1309 sym
->backend_decl
= fndecl
;
1313 /* Create the DECL_ARGUMENTS for a procedure. */
1316 create_function_arglist (gfc_symbol
* sym
)
1319 gfc_formal_arglist
*f
;
1320 tree typelist
, hidden_typelist
;
1321 tree arglist
, hidden_arglist
;
1325 fndecl
= sym
->backend_decl
;
1327 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1328 the new FUNCTION_DECL node. */
1329 arglist
= NULL_TREE
;
1330 hidden_arglist
= NULL_TREE
;
1331 typelist
= TYPE_ARG_TYPES (TREE_TYPE (fndecl
));
1333 if (sym
->attr
.entry_master
)
1335 type
= TREE_VALUE (typelist
);
1336 parm
= build_decl (PARM_DECL
, get_identifier ("__entry"), type
);
1338 DECL_CONTEXT (parm
) = fndecl
;
1339 DECL_ARG_TYPE (parm
) = type
;
1340 TREE_READONLY (parm
) = 1;
1341 gfc_finish_decl (parm
);
1342 DECL_ARTIFICIAL (parm
) = 1;
1344 arglist
= chainon (arglist
, parm
);
1345 typelist
= TREE_CHAIN (typelist
);
1348 if (gfc_return_by_reference (sym
))
1350 tree type
= TREE_VALUE (typelist
), length
= NULL
;
1352 if (sym
->ts
.type
== BT_CHARACTER
)
1354 /* Length of character result. */
1355 tree len_type
= TREE_VALUE (TREE_CHAIN (typelist
));
1356 gcc_assert (len_type
== gfc_charlen_type_node
);
1358 length
= build_decl (PARM_DECL
,
1359 get_identifier (".__result"),
1361 if (!sym
->ts
.cl
->length
)
1363 sym
->ts
.cl
->backend_decl
= length
;
1364 TREE_USED (length
) = 1;
1366 gcc_assert (TREE_CODE (length
) == PARM_DECL
);
1367 DECL_CONTEXT (length
) = fndecl
;
1368 DECL_ARG_TYPE (length
) = len_type
;
1369 TREE_READONLY (length
) = 1;
1370 DECL_ARTIFICIAL (length
) = 1;
1371 gfc_finish_decl (length
);
1372 if (sym
->ts
.cl
->backend_decl
== NULL
1373 || sym
->ts
.cl
->backend_decl
== length
)
1378 if (sym
->ts
.cl
->backend_decl
== NULL
)
1380 tree len
= build_decl (VAR_DECL
,
1381 get_identifier ("..__result"),
1382 gfc_charlen_type_node
);
1383 DECL_ARTIFICIAL (len
) = 1;
1384 TREE_USED (len
) = 1;
1385 sym
->ts
.cl
->backend_decl
= len
;
1388 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1389 arg
= sym
->result
? sym
->result
: sym
;
1390 backend_decl
= arg
->backend_decl
;
1391 /* Temporary clear it, so that gfc_sym_type creates complete
1393 arg
->backend_decl
= NULL
;
1394 type
= gfc_sym_type (arg
);
1395 arg
->backend_decl
= backend_decl
;
1396 type
= build_reference_type (type
);
1400 parm
= build_decl (PARM_DECL
, get_identifier ("__result"), type
);
1402 DECL_CONTEXT (parm
) = fndecl
;
1403 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
1404 TREE_READONLY (parm
) = 1;
1405 DECL_ARTIFICIAL (parm
) = 1;
1406 gfc_finish_decl (parm
);
1408 arglist
= chainon (arglist
, parm
);
1409 typelist
= TREE_CHAIN (typelist
);
1411 if (sym
->ts
.type
== BT_CHARACTER
)
1413 gfc_allocate_lang_decl (parm
);
1414 arglist
= chainon (arglist
, length
);
1415 typelist
= TREE_CHAIN (typelist
);
1419 hidden_typelist
= typelist
;
1420 for (f
= sym
->formal
; f
; f
= f
->next
)
1421 if (f
->sym
!= NULL
) /* Ignore alternate returns. */
1422 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
1424 for (f
= sym
->formal
; f
; f
= f
->next
)
1426 char name
[GFC_MAX_SYMBOL_LEN
+ 2];
1428 /* Ignore alternate returns. */
1432 type
= TREE_VALUE (typelist
);
1434 if (f
->sym
->ts
.type
== BT_CHARACTER
)
1436 tree len_type
= TREE_VALUE (hidden_typelist
);
1437 tree length
= NULL_TREE
;
1438 gcc_assert (len_type
== gfc_charlen_type_node
);
1440 strcpy (&name
[1], f
->sym
->name
);
1442 length
= build_decl (PARM_DECL
, get_identifier (name
), len_type
);
1444 hidden_arglist
= chainon (hidden_arglist
, length
);
1445 DECL_CONTEXT (length
) = fndecl
;
1446 DECL_ARTIFICIAL (length
) = 1;
1447 DECL_ARG_TYPE (length
) = len_type
;
1448 TREE_READONLY (length
) = 1;
1449 gfc_finish_decl (length
);
1451 /* TODO: Check string lengths when -fbounds-check. */
1453 /* Use the passed value for assumed length variables. */
1454 if (!f
->sym
->ts
.cl
->length
)
1456 TREE_USED (length
) = 1;
1457 gcc_assert (!f
->sym
->ts
.cl
->backend_decl
);
1458 f
->sym
->ts
.cl
->backend_decl
= length
;
1461 hidden_typelist
= TREE_CHAIN (hidden_typelist
);
1463 if (f
->sym
->ts
.cl
->backend_decl
== NULL
1464 || f
->sym
->ts
.cl
->backend_decl
== length
)
1466 if (f
->sym
->ts
.cl
->backend_decl
== NULL
)
1467 gfc_create_string_length (f
->sym
);
1469 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1470 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1471 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
1473 type
= gfc_sym_type (f
->sym
);
1477 /* For non-constant length array arguments, make sure they use
1478 a different type node from TYPE_ARG_TYPES type. */
1479 if (f
->sym
->attr
.dimension
1480 && type
== TREE_VALUE (typelist
)
1481 && TREE_CODE (type
) == POINTER_TYPE
1482 && GFC_ARRAY_TYPE_P (type
)
1483 && f
->sym
->as
->type
!= AS_ASSUMED_SIZE
1484 && ! COMPLETE_TYPE_P (TREE_TYPE (type
)))
1486 if (f
->sym
->attr
.flavor
== FL_PROCEDURE
)
1487 type
= build_pointer_type (gfc_get_function_type (f
->sym
));
1489 type
= gfc_sym_type (f
->sym
);
1492 /* Build a the argument declaration. */
1493 parm
= build_decl (PARM_DECL
, gfc_sym_identifier (f
->sym
), type
);
1495 /* Fill in arg stuff. */
1496 DECL_CONTEXT (parm
) = fndecl
;
1497 DECL_ARG_TYPE (parm
) = TREE_VALUE (typelist
);
1498 /* All implementation args are read-only. */
1499 TREE_READONLY (parm
) = 1;
1501 gfc_finish_decl (parm
);
1503 f
->sym
->backend_decl
= parm
;
1505 arglist
= chainon (arglist
, parm
);
1506 typelist
= TREE_CHAIN (typelist
);
1509 /* Add the hidden string length parameters. */
1510 arglist
= chainon (arglist
, hidden_arglist
);
1512 gcc_assert (hidden_typelist
== NULL_TREE
1513 || TREE_VALUE (hidden_typelist
) == void_type_node
);
1514 DECL_ARGUMENTS (fndecl
) = arglist
;
1517 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1520 gfc_gimplify_function (tree fndecl
)
1522 struct cgraph_node
*cgn
;
1524 gimplify_function_tree (fndecl
);
1525 dump_function (TDI_generic
, fndecl
);
1527 /* Generate errors for structured block violations. */
1528 /* ??? Could be done as part of resolve_labels. */
1530 diagnose_omp_structured_block_errors (fndecl
);
1532 /* Convert all nested functions to GIMPLE now. We do things in this order
1533 so that items like VLA sizes are expanded properly in the context of the
1534 correct function. */
1535 cgn
= cgraph_node (fndecl
);
1536 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1537 gfc_gimplify_function (cgn
->decl
);
1541 /* Do the setup necessary before generating the body of a function. */
1544 trans_function_start (gfc_symbol
* sym
)
1548 fndecl
= sym
->backend_decl
;
1550 /* Let GCC know the current scope is this function. */
1551 current_function_decl
= fndecl
;
1553 /* Let the world know what we're about to do. */
1554 announce_function (fndecl
);
1556 if (DECL_CONTEXT (fndecl
) == NULL_TREE
)
1558 /* Create RTL for function declaration. */
1559 rest_of_decl_compilation (fndecl
, 1, 0);
1562 /* Create RTL for function definition. */
1563 make_decl_rtl (fndecl
);
1565 init_function_start (fndecl
);
1567 /* Even though we're inside a function body, we still don't want to
1568 call expand_expr to calculate the size of a variable-sized array.
1569 We haven't necessarily assigned RTL to all variables yet, so it's
1570 not safe to try to expand expressions involving them. */
1571 cfun
->x_dont_save_pending_sizes_p
= 1;
1573 /* function.c requires a push at the start of the function. */
1577 /* Create thunks for alternate entry points. */
1580 build_entry_thunks (gfc_namespace
* ns
)
1582 gfc_formal_arglist
*formal
;
1583 gfc_formal_arglist
*thunk_formal
;
1585 gfc_symbol
*thunk_sym
;
1593 /* This should always be a toplevel function. */
1594 gcc_assert (current_function_decl
== NULL_TREE
);
1596 gfc_get_backend_locus (&old_loc
);
1597 for (el
= ns
->entries
; el
; el
= el
->next
)
1599 thunk_sym
= el
->sym
;
1601 build_function_decl (thunk_sym
);
1602 create_function_arglist (thunk_sym
);
1604 trans_function_start (thunk_sym
);
1606 thunk_fndecl
= thunk_sym
->backend_decl
;
1608 gfc_start_block (&body
);
1610 /* Pass extra parameter identifying this entry point. */
1611 tmp
= build_int_cst (gfc_array_index_type
, el
->id
);
1612 args
= tree_cons (NULL_TREE
, tmp
, NULL_TREE
);
1613 string_args
= NULL_TREE
;
1615 if (thunk_sym
->attr
.function
)
1617 if (gfc_return_by_reference (ns
->proc_name
))
1619 tree ref
= DECL_ARGUMENTS (current_function_decl
);
1620 args
= tree_cons (NULL_TREE
, ref
, args
);
1621 if (ns
->proc_name
->ts
.type
== BT_CHARACTER
)
1622 args
= tree_cons (NULL_TREE
, TREE_CHAIN (ref
),
1627 for (formal
= ns
->proc_name
->formal
; formal
; formal
= formal
->next
)
1629 /* Ignore alternate returns. */
1630 if (formal
->sym
== NULL
)
1633 /* We don't have a clever way of identifying arguments, so resort to
1634 a brute-force search. */
1635 for (thunk_formal
= thunk_sym
->formal
;
1637 thunk_formal
= thunk_formal
->next
)
1639 if (thunk_formal
->sym
== formal
->sym
)
1645 /* Pass the argument. */
1646 DECL_ARTIFICIAL (thunk_formal
->sym
->backend_decl
) = 1;
1647 args
= tree_cons (NULL_TREE
, thunk_formal
->sym
->backend_decl
,
1649 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1651 tmp
= thunk_formal
->sym
->ts
.cl
->backend_decl
;
1652 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1657 /* Pass NULL for a missing argument. */
1658 args
= tree_cons (NULL_TREE
, null_pointer_node
, args
);
1659 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1661 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
1662 string_args
= tree_cons (NULL_TREE
, tmp
, string_args
);
1667 /* Call the master function. */
1668 args
= nreverse (args
);
1669 args
= chainon (args
, nreverse (string_args
));
1670 tmp
= ns
->proc_name
->backend_decl
;
1671 tmp
= build_function_call_expr (tmp
, args
);
1672 if (ns
->proc_name
->attr
.mixed_entry_master
)
1674 tree union_decl
, field
;
1675 tree master_type
= TREE_TYPE (ns
->proc_name
->backend_decl
);
1677 union_decl
= build_decl (VAR_DECL
, get_identifier ("__result"),
1678 TREE_TYPE (master_type
));
1679 DECL_ARTIFICIAL (union_decl
) = 1;
1680 DECL_EXTERNAL (union_decl
) = 0;
1681 TREE_PUBLIC (union_decl
) = 0;
1682 TREE_USED (union_decl
) = 1;
1683 layout_decl (union_decl
, 0);
1684 pushdecl (union_decl
);
1686 DECL_CONTEXT (union_decl
) = current_function_decl
;
1687 tmp
= build2 (MODIFY_EXPR
,
1688 TREE_TYPE (union_decl
),
1690 gfc_add_expr_to_block (&body
, tmp
);
1692 for (field
= TYPE_FIELDS (TREE_TYPE (union_decl
));
1693 field
; field
= TREE_CHAIN (field
))
1694 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
1695 thunk_sym
->result
->name
) == 0)
1697 gcc_assert (field
!= NULL_TREE
);
1698 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), union_decl
, field
,
1700 tmp
= build2 (MODIFY_EXPR
,
1701 TREE_TYPE (DECL_RESULT (current_function_decl
)),
1702 DECL_RESULT (current_function_decl
), tmp
);
1703 tmp
= build1_v (RETURN_EXPR
, tmp
);
1705 else if (TREE_TYPE (DECL_RESULT (current_function_decl
))
1708 tmp
= build2 (MODIFY_EXPR
,
1709 TREE_TYPE (DECL_RESULT (current_function_decl
)),
1710 DECL_RESULT (current_function_decl
), tmp
);
1711 tmp
= build1_v (RETURN_EXPR
, tmp
);
1713 gfc_add_expr_to_block (&body
, tmp
);
1715 /* Finish off this function and send it for code generation. */
1716 DECL_SAVED_TREE (thunk_fndecl
) = gfc_finish_block (&body
);
1718 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl
)) = thunk_fndecl
;
1720 /* Output the GENERIC tree. */
1721 dump_function (TDI_original
, thunk_fndecl
);
1723 /* Store the end of the function, so that we get good line number
1724 info for the epilogue. */
1725 cfun
->function_end_locus
= input_location
;
1727 /* We're leaving the context of this function, so zap cfun.
1728 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1729 tree_rest_of_compilation. */
1732 current_function_decl
= NULL_TREE
;
1734 gfc_gimplify_function (thunk_fndecl
);
1735 cgraph_finalize_function (thunk_fndecl
, false);
1737 /* We share the symbols in the formal argument list with other entry
1738 points and the master function. Clear them so that they are
1739 recreated for each function. */
1740 for (formal
= thunk_sym
->formal
; formal
; formal
= formal
->next
)
1741 if (formal
->sym
!= NULL
) /* Ignore alternate returns. */
1743 formal
->sym
->backend_decl
= NULL_TREE
;
1744 if (formal
->sym
->ts
.type
== BT_CHARACTER
)
1745 formal
->sym
->ts
.cl
->backend_decl
= NULL_TREE
;
1748 if (thunk_sym
->attr
.function
)
1750 if (thunk_sym
->ts
.type
== BT_CHARACTER
)
1751 thunk_sym
->ts
.cl
->backend_decl
= NULL_TREE
;
1752 if (thunk_sym
->result
->ts
.type
== BT_CHARACTER
)
1753 thunk_sym
->result
->ts
.cl
->backend_decl
= NULL_TREE
;
1757 gfc_set_backend_locus (&old_loc
);
1761 /* Create a decl for a function, and create any thunks for alternate entry
1765 gfc_create_function_decl (gfc_namespace
* ns
)
1767 /* Create a declaration for the master function. */
1768 build_function_decl (ns
->proc_name
);
1770 /* Compile the entry thunks. */
1772 build_entry_thunks (ns
);
1774 /* Now create the read argument list. */
1775 create_function_arglist (ns
->proc_name
);
1778 /* Return the decl used to hold the function return value. If
1779 parent_flag is set, the context is the parent_scope. */
1782 gfc_get_fake_result_decl (gfc_symbol
* sym
, int parent_flag
)
1786 tree this_fake_result_decl
;
1787 tree this_function_decl
;
1789 char name
[GFC_MAX_SYMBOL_LEN
+ 10];
1793 this_fake_result_decl
= parent_fake_result_decl
;
1794 this_function_decl
= DECL_CONTEXT (current_function_decl
);
1798 this_fake_result_decl
= current_fake_result_decl
;
1799 this_function_decl
= current_function_decl
;
1803 && sym
->ns
->proc_name
->backend_decl
== this_function_decl
1804 && sym
->ns
->proc_name
->attr
.entry_master
1805 && sym
!= sym
->ns
->proc_name
)
1808 if (this_fake_result_decl
!= NULL
)
1809 for (t
= TREE_CHAIN (this_fake_result_decl
); t
; t
= TREE_CHAIN (t
))
1810 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t
)), sym
->name
) == 0)
1813 return TREE_VALUE (t
);
1814 decl
= gfc_get_fake_result_decl (sym
->ns
->proc_name
, parent_flag
);
1817 this_fake_result_decl
= parent_fake_result_decl
;
1819 this_fake_result_decl
= current_fake_result_decl
;
1821 if (decl
&& sym
->ns
->proc_name
->attr
.mixed_entry_master
)
1825 for (field
= TYPE_FIELDS (TREE_TYPE (decl
));
1826 field
; field
= TREE_CHAIN (field
))
1827 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field
)),
1831 gcc_assert (field
!= NULL_TREE
);
1832 decl
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
,
1836 var
= create_tmp_var_raw (TREE_TYPE (decl
), sym
->name
);
1838 gfc_add_decl_to_parent_function (var
);
1840 gfc_add_decl_to_function (var
);
1842 SET_DECL_VALUE_EXPR (var
, decl
);
1843 DECL_HAS_VALUE_EXPR_P (var
) = 1;
1844 GFC_DECL_RESULT (var
) = 1;
1846 TREE_CHAIN (this_fake_result_decl
)
1847 = tree_cons (get_identifier (sym
->name
), var
,
1848 TREE_CHAIN (this_fake_result_decl
));
1852 if (this_fake_result_decl
!= NULL_TREE
)
1853 return TREE_VALUE (this_fake_result_decl
);
1855 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1860 if (sym
->ts
.type
== BT_CHARACTER
)
1862 if (sym
->ts
.cl
->backend_decl
== NULL_TREE
)
1863 length
= gfc_create_string_length (sym
);
1865 length
= sym
->ts
.cl
->backend_decl
;
1866 if (TREE_CODE (length
) == VAR_DECL
1867 && DECL_CONTEXT (length
) == NULL_TREE
)
1868 gfc_add_decl_to_function (length
);
1871 if (gfc_return_by_reference (sym
))
1873 decl
= DECL_ARGUMENTS (this_function_decl
);
1875 if (sym
->ns
->proc_name
->backend_decl
== this_function_decl
1876 && sym
->ns
->proc_name
->attr
.entry_master
)
1877 decl
= TREE_CHAIN (decl
);
1879 TREE_USED (decl
) = 1;
1881 decl
= gfc_build_dummy_array_decl (sym
, decl
);
1885 sprintf (name
, "__result_%.20s",
1886 IDENTIFIER_POINTER (DECL_NAME (this_function_decl
)));
1888 if (!sym
->attr
.mixed_entry_master
&& sym
->attr
.function
)
1889 decl
= build_decl (VAR_DECL
, get_identifier (name
),
1890 gfc_sym_type (sym
));
1892 decl
= build_decl (VAR_DECL
, get_identifier (name
),
1893 TREE_TYPE (TREE_TYPE (this_function_decl
)));
1894 DECL_ARTIFICIAL (decl
) = 1;
1895 DECL_EXTERNAL (decl
) = 0;
1896 TREE_PUBLIC (decl
) = 0;
1897 TREE_USED (decl
) = 1;
1898 GFC_DECL_RESULT (decl
) = 1;
1899 TREE_ADDRESSABLE (decl
) = 1;
1901 layout_decl (decl
, 0);
1904 gfc_add_decl_to_parent_function (decl
);
1906 gfc_add_decl_to_function (decl
);
1910 parent_fake_result_decl
= build_tree_list (NULL
, decl
);
1912 current_fake_result_decl
= build_tree_list (NULL
, decl
);
1918 /* Builds a function decl. The remaining parameters are the types of the
1919 function arguments. Negative nargs indicates a varargs function. */
1922 gfc_build_library_function_decl (tree name
, tree rettype
, int nargs
, ...)
1931 /* Library functions must be declared with global scope. */
1932 gcc_assert (current_function_decl
== NULL_TREE
);
1934 va_start (p
, nargs
);
1937 /* Create a list of the argument types. */
1938 for (arglist
= NULL_TREE
, n
= abs (nargs
); n
> 0; n
--)
1940 argtype
= va_arg (p
, tree
);
1941 arglist
= gfc_chainon_list (arglist
, argtype
);
1946 /* Terminate the list. */
1947 arglist
= gfc_chainon_list (arglist
, void_type_node
);
1950 /* Build the function type and decl. */
1951 fntype
= build_function_type (rettype
, arglist
);
1952 fndecl
= build_decl (FUNCTION_DECL
, name
, fntype
);
1954 /* Mark this decl as external. */
1955 DECL_EXTERNAL (fndecl
) = 1;
1956 TREE_PUBLIC (fndecl
) = 1;
1962 rest_of_decl_compilation (fndecl
, 1, 0);
1968 gfc_build_intrinsic_function_decls (void)
1970 tree gfc_int4_type_node
= gfc_get_int_type (4);
1971 tree gfc_int8_type_node
= gfc_get_int_type (8);
1972 tree gfc_int16_type_node
= gfc_get_int_type (16);
1973 tree gfc_logical4_type_node
= gfc_get_logical_type (4);
1974 tree gfc_real4_type_node
= gfc_get_real_type (4);
1975 tree gfc_real8_type_node
= gfc_get_real_type (8);
1976 tree gfc_real10_type_node
= gfc_get_real_type (10);
1977 tree gfc_real16_type_node
= gfc_get_real_type (16);
1978 tree gfc_complex4_type_node
= gfc_get_complex_type (4);
1979 tree gfc_complex8_type_node
= gfc_get_complex_type (8);
1980 tree gfc_complex10_type_node
= gfc_get_complex_type (10);
1981 tree gfc_complex16_type_node
= gfc_get_complex_type (16);
1983 /* String functions. */
1984 gfor_fndecl_compare_string
=
1985 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1986 integer_type_node
, 4,
1987 gfc_charlen_type_node
, pchar_type_node
,
1988 gfc_charlen_type_node
, pchar_type_node
);
1990 gfor_fndecl_concat_string
=
1991 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1994 gfc_charlen_type_node
, pchar_type_node
,
1995 gfc_charlen_type_node
, pchar_type_node
,
1996 gfc_charlen_type_node
, pchar_type_node
);
1998 gfor_fndecl_string_len_trim
=
1999 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2001 2, gfc_charlen_type_node
,
2004 gfor_fndecl_string_index
=
2005 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2007 5, gfc_charlen_type_node
, pchar_type_node
,
2008 gfc_charlen_type_node
, pchar_type_node
,
2009 gfc_logical4_type_node
);
2011 gfor_fndecl_string_scan
=
2012 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2014 5, gfc_charlen_type_node
, pchar_type_node
,
2015 gfc_charlen_type_node
, pchar_type_node
,
2016 gfc_logical4_type_node
);
2018 gfor_fndecl_string_verify
=
2019 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2021 5, gfc_charlen_type_node
, pchar_type_node
,
2022 gfc_charlen_type_node
, pchar_type_node
,
2023 gfc_logical4_type_node
);
2025 gfor_fndecl_string_trim
=
2026 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2029 build_pointer_type (gfc_charlen_type_node
),
2031 gfc_charlen_type_node
,
2034 gfor_fndecl_string_minmax
=
2035 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2037 build_pointer_type (gfc_charlen_type_node
),
2038 ppvoid_type_node
, integer_type_node
,
2041 gfor_fndecl_ttynam
=
2042 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2046 gfc_charlen_type_node
,
2050 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2054 gfc_charlen_type_node
);
2057 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2061 gfc_charlen_type_node
,
2062 gfc_int8_type_node
);
2064 gfor_fndecl_adjustl
=
2065 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2069 gfc_charlen_type_node
, pchar_type_node
);
2071 gfor_fndecl_adjustr
=
2072 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2076 gfc_charlen_type_node
, pchar_type_node
);
2078 gfor_fndecl_si_kind
=
2079 gfc_build_library_function_decl (get_identifier
2080 (PREFIX("selected_int_kind")),
2085 gfor_fndecl_sr_kind
=
2086 gfc_build_library_function_decl (get_identifier
2087 (PREFIX("selected_real_kind")),
2092 /* Power functions. */
2094 tree ctype
, rtype
, itype
, jtype
;
2095 int rkind
, ikind
, jkind
;
2098 static int ikinds
[NIKINDS
] = {4, 8, 16};
2099 static int rkinds
[NRKINDS
] = {4, 8, 10, 16};
2100 char name
[PREFIX_LEN
+ 12]; /* _gfortran_pow_?n_?n */
2102 for (ikind
=0; ikind
< NIKINDS
; ikind
++)
2104 itype
= gfc_get_int_type (ikinds
[ikind
]);
2106 for (jkind
=0; jkind
< NIKINDS
; jkind
++)
2108 jtype
= gfc_get_int_type (ikinds
[jkind
]);
2111 sprintf(name
, PREFIX("pow_i%d_i%d"), ikinds
[ikind
],
2113 gfor_fndecl_math_powi
[jkind
][ikind
].integer
=
2114 gfc_build_library_function_decl (get_identifier (name
),
2115 jtype
, 2, jtype
, itype
);
2116 TREE_READONLY (gfor_fndecl_math_powi
[jkind
][ikind
].integer
) = 1;
2120 for (rkind
= 0; rkind
< NRKINDS
; rkind
++)
2122 rtype
= gfc_get_real_type (rkinds
[rkind
]);
2125 sprintf(name
, PREFIX("pow_r%d_i%d"), rkinds
[rkind
],
2127 gfor_fndecl_math_powi
[rkind
][ikind
].real
=
2128 gfc_build_library_function_decl (get_identifier (name
),
2129 rtype
, 2, rtype
, itype
);
2130 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].real
) = 1;
2133 ctype
= gfc_get_complex_type (rkinds
[rkind
]);
2136 sprintf(name
, PREFIX("pow_c%d_i%d"), rkinds
[rkind
],
2138 gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
=
2139 gfc_build_library_function_decl (get_identifier (name
),
2140 ctype
, 2,ctype
, itype
);
2141 TREE_READONLY (gfor_fndecl_math_powi
[rkind
][ikind
].cmplx
) = 1;
2149 gfor_fndecl_math_cpowf
=
2150 gfc_build_library_function_decl (get_identifier ("cpowf"),
2151 gfc_complex4_type_node
,
2152 1, gfc_complex4_type_node
);
2153 gfor_fndecl_math_cpow
=
2154 gfc_build_library_function_decl (get_identifier ("cpow"),
2155 gfc_complex8_type_node
,
2156 1, gfc_complex8_type_node
);
2157 if (gfc_complex10_type_node
)
2158 gfor_fndecl_math_cpowl10
=
2159 gfc_build_library_function_decl (get_identifier ("cpowl"),
2160 gfc_complex10_type_node
, 1,
2161 gfc_complex10_type_node
);
2162 if (gfc_complex16_type_node
)
2163 gfor_fndecl_math_cpowl16
=
2164 gfc_build_library_function_decl (get_identifier ("cpowl"),
2165 gfc_complex16_type_node
, 1,
2166 gfc_complex16_type_node
);
2168 gfor_fndecl_math_ishftc4
=
2169 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2171 3, gfc_int4_type_node
,
2172 gfc_int4_type_node
, gfc_int4_type_node
);
2173 gfor_fndecl_math_ishftc8
=
2174 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2176 3, gfc_int8_type_node
,
2177 gfc_int4_type_node
, gfc_int4_type_node
);
2178 if (gfc_int16_type_node
)
2179 gfor_fndecl_math_ishftc16
=
2180 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2181 gfc_int16_type_node
, 3,
2182 gfc_int16_type_node
,
2184 gfc_int4_type_node
);
2186 gfor_fndecl_math_exponent4
=
2187 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2189 1, gfc_real4_type_node
);
2190 gfor_fndecl_math_exponent8
=
2191 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2193 1, gfc_real8_type_node
);
2194 if (gfc_real10_type_node
)
2195 gfor_fndecl_math_exponent10
=
2196 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2197 gfc_int4_type_node
, 1,
2198 gfc_real10_type_node
);
2199 if (gfc_real16_type_node
)
2200 gfor_fndecl_math_exponent16
=
2201 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2202 gfc_int4_type_node
, 1,
2203 gfc_real16_type_node
);
2205 /* BLAS functions. */
2207 tree pint
= build_pointer_type (integer_type_node
);
2208 tree ps
= build_pointer_type (gfc_get_real_type (gfc_default_real_kind
));
2209 tree pd
= build_pointer_type (gfc_get_real_type (gfc_default_double_kind
));
2210 tree pc
= build_pointer_type (gfc_get_complex_type (gfc_default_real_kind
));
2211 tree pz
= build_pointer_type
2212 (gfc_get_complex_type (gfc_default_double_kind
));
2214 gfor_fndecl_sgemm
= gfc_build_library_function_decl
2216 (gfc_option
.flag_underscoring
? "sgemm_"
2218 void_type_node
, 15, pchar_type_node
,
2219 pchar_type_node
, pint
, pint
, pint
, ps
, ps
, pint
,
2220 ps
, pint
, ps
, ps
, pint
, integer_type_node
,
2222 gfor_fndecl_dgemm
= gfc_build_library_function_decl
2224 (gfc_option
.flag_underscoring
? "dgemm_"
2226 void_type_node
, 15, pchar_type_node
,
2227 pchar_type_node
, pint
, pint
, pint
, pd
, pd
, pint
,
2228 pd
, pint
, pd
, pd
, pint
, integer_type_node
,
2230 gfor_fndecl_cgemm
= gfc_build_library_function_decl
2232 (gfc_option
.flag_underscoring
? "cgemm_"
2234 void_type_node
, 15, pchar_type_node
,
2235 pchar_type_node
, pint
, pint
, pint
, pc
, pc
, pint
,
2236 pc
, pint
, pc
, pc
, pint
, integer_type_node
,
2238 gfor_fndecl_zgemm
= gfc_build_library_function_decl
2240 (gfc_option
.flag_underscoring
? "zgemm_"
2242 void_type_node
, 15, pchar_type_node
,
2243 pchar_type_node
, pint
, pint
, pint
, pz
, pz
, pint
,
2244 pz
, pint
, pz
, pz
, pint
, integer_type_node
,
2248 /* Other functions. */
2250 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2251 gfc_array_index_type
,
2252 1, pvoid_type_node
);
2254 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2255 gfc_array_index_type
,
2257 gfc_array_index_type
);
2260 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2266 /* Make prototypes for runtime library functions. */
2269 gfc_build_builtin_function_decls (void)
2271 tree gfc_int4_type_node
= gfc_get_int_type (4);
2273 gfor_fndecl_stop_numeric
=
2274 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2275 void_type_node
, 1, gfc_int4_type_node
);
2276 /* Stop doesn't return. */
2277 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric
) = 1;
2279 gfor_fndecl_stop_string
=
2280 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2281 void_type_node
, 2, pchar_type_node
,
2282 gfc_int4_type_node
);
2283 /* Stop doesn't return. */
2284 TREE_THIS_VOLATILE (gfor_fndecl_stop_string
) = 1;
2286 gfor_fndecl_pause_numeric
=
2287 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2288 void_type_node
, 1, gfc_int4_type_node
);
2290 gfor_fndecl_pause_string
=
2291 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2292 void_type_node
, 2, pchar_type_node
,
2293 gfc_int4_type_node
);
2295 gfor_fndecl_select_string
=
2296 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2297 integer_type_node
, 0);
2299 gfor_fndecl_runtime_error
=
2300 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2301 void_type_node
, -1, pchar_type_node
);
2302 /* The runtime_error function does not return. */
2303 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error
) = 1;
2305 gfor_fndecl_runtime_error_at
=
2306 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2307 void_type_node
, -2, pchar_type_node
,
2309 /* The runtime_error_at function does not return. */
2310 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at
) = 1;
2312 gfor_fndecl_generate_error
=
2313 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2314 void_type_node
, 3, pvoid_type_node
,
2315 integer_type_node
, pchar_type_node
);
2317 gfor_fndecl_os_error
=
2318 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2319 void_type_node
, 1, pchar_type_node
);
2320 /* The runtime_error function does not return. */
2321 TREE_THIS_VOLATILE (gfor_fndecl_os_error
) = 1;
2323 gfor_fndecl_set_fpe
=
2324 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2325 void_type_node
, 1, integer_type_node
);
2327 /* Keep the array dimension in sync with the call, later in this file. */
2328 gfor_fndecl_set_options
=
2329 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2330 void_type_node
, 2, integer_type_node
,
2333 gfor_fndecl_set_convert
=
2334 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2335 void_type_node
, 1, integer_type_node
);
2337 gfor_fndecl_set_record_marker
=
2338 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2339 void_type_node
, 1, integer_type_node
);
2341 gfor_fndecl_set_max_subrecord_length
=
2342 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2343 void_type_node
, 1, integer_type_node
);
2345 gfor_fndecl_in_pack
= gfc_build_library_function_decl (
2346 get_identifier (PREFIX("internal_pack")),
2347 pvoid_type_node
, 1, pvoid_type_node
);
2349 gfor_fndecl_in_unpack
= gfc_build_library_function_decl (
2350 get_identifier (PREFIX("internal_unpack")),
2351 pvoid_type_node
, 1, pvoid_type_node
);
2353 gfor_fndecl_associated
=
2354 gfc_build_library_function_decl (
2355 get_identifier (PREFIX("associated")),
2356 integer_type_node
, 2, ppvoid_type_node
,
2359 gfc_build_intrinsic_function_decls ();
2360 gfc_build_intrinsic_lib_fndecls ();
2361 gfc_build_io_library_fndecls ();
2365 /* Evaluate the length of dummy character variables. */
2368 gfc_trans_dummy_character (gfc_symbol
*sym
, gfc_charlen
*cl
, tree fnbody
)
2372 gfc_finish_decl (cl
->backend_decl
);
2374 gfc_start_block (&body
);
2376 /* Evaluate the string length expression. */
2377 gfc_conv_string_length (cl
, &body
);
2379 gfc_trans_vla_type_sizes (sym
, &body
);
2381 gfc_add_expr_to_block (&body
, fnbody
);
2382 return gfc_finish_block (&body
);
2386 /* Allocate and cleanup an automatic character variable. */
2389 gfc_trans_auto_character_variable (gfc_symbol
* sym
, tree fnbody
)
2395 gcc_assert (sym
->backend_decl
);
2396 gcc_assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
);
2398 gfc_start_block (&body
);
2400 /* Evaluate the string length expression. */
2401 gfc_conv_string_length (sym
->ts
.cl
, &body
);
2403 gfc_trans_vla_type_sizes (sym
, &body
);
2405 decl
= sym
->backend_decl
;
2407 /* Emit a DECL_EXPR for this variable, which will cause the
2408 gimplifier to allocate storage, and all that good stuff. */
2409 tmp
= build1 (DECL_EXPR
, TREE_TYPE (decl
), decl
);
2410 gfc_add_expr_to_block (&body
, tmp
);
2412 gfc_add_expr_to_block (&body
, fnbody
);
2413 return gfc_finish_block (&body
);
2416 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2419 gfc_trans_assign_aux_var (gfc_symbol
* sym
, tree fnbody
)
2423 gcc_assert (sym
->backend_decl
);
2424 gfc_start_block (&body
);
2426 /* Set the initial value to length. See the comments in
2427 function gfc_add_assign_aux_vars in this file. */
2428 gfc_add_modify_expr (&body
, GFC_DECL_STRING_LEN (sym
->backend_decl
),
2429 build_int_cst (NULL_TREE
, -2));
2431 gfc_add_expr_to_block (&body
, fnbody
);
2432 return gfc_finish_block (&body
);
2436 gfc_trans_vla_one_sizepos (tree
*tp
, stmtblock_t
*body
)
2438 tree t
= *tp
, var
, val
;
2440 if (t
== NULL
|| t
== error_mark_node
)
2442 if (TREE_CONSTANT (t
) || DECL_P (t
))
2445 if (TREE_CODE (t
) == SAVE_EXPR
)
2447 if (SAVE_EXPR_RESOLVED_P (t
))
2449 *tp
= TREE_OPERAND (t
, 0);
2452 val
= TREE_OPERAND (t
, 0);
2457 var
= gfc_create_var_np (TREE_TYPE (t
), NULL
);
2458 gfc_add_decl_to_function (var
);
2459 gfc_add_modify_expr (body
, var
, val
);
2460 if (TREE_CODE (t
) == SAVE_EXPR
)
2461 TREE_OPERAND (t
, 0) = var
;
2466 gfc_trans_vla_type_sizes_1 (tree type
, stmtblock_t
*body
)
2470 if (type
== NULL
|| type
== error_mark_node
)
2473 type
= TYPE_MAIN_VARIANT (type
);
2475 if (TREE_CODE (type
) == INTEGER_TYPE
)
2477 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type
), body
);
2478 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type
), body
);
2480 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
2482 TYPE_MIN_VALUE (t
) = TYPE_MIN_VALUE (type
);
2483 TYPE_MAX_VALUE (t
) = TYPE_MAX_VALUE (type
);
2486 else if (TREE_CODE (type
) == ARRAY_TYPE
)
2488 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type
), body
);
2489 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type
), body
);
2490 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type
), body
);
2491 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type
), body
);
2493 for (t
= TYPE_NEXT_VARIANT (type
); t
; t
= TYPE_NEXT_VARIANT (t
))
2495 TYPE_SIZE (t
) = TYPE_SIZE (type
);
2496 TYPE_SIZE_UNIT (t
) = TYPE_SIZE_UNIT (type
);
2501 /* Make sure all type sizes and array domains are either constant,
2502 or variable or parameter decls. This is a simplified variant
2503 of gimplify_type_sizes, but we can't use it here, as none of the
2504 variables in the expressions have been gimplified yet.
2505 As type sizes and domains for various variable length arrays
2506 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2507 time, without this routine gimplify_type_sizes in the middle-end
2508 could result in the type sizes being gimplified earlier than where
2509 those variables are initialized. */
2512 gfc_trans_vla_type_sizes (gfc_symbol
*sym
, stmtblock_t
*body
)
2514 tree type
= TREE_TYPE (sym
->backend_decl
);
2516 if (TREE_CODE (type
) == FUNCTION_TYPE
2517 && (sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.entry
))
2519 if (! current_fake_result_decl
)
2522 type
= TREE_TYPE (TREE_VALUE (current_fake_result_decl
));
2525 while (POINTER_TYPE_P (type
))
2526 type
= TREE_TYPE (type
);
2528 if (GFC_DESCRIPTOR_TYPE_P (type
))
2530 tree etype
= GFC_TYPE_ARRAY_DATAPTR_TYPE (type
);
2532 while (POINTER_TYPE_P (etype
))
2533 etype
= TREE_TYPE (etype
);
2535 gfc_trans_vla_type_sizes_1 (etype
, body
);
2538 gfc_trans_vla_type_sizes_1 (type
, body
);
2542 /* Generate function entry and exit code, and add it to the function body.
2544 Allocation and initialization of array variables.
2545 Allocation of character string variables.
2546 Initialization and possibly repacking of dummy arrays.
2547 Initialization of ASSIGN statement auxiliary variable. */
2550 gfc_trans_deferred_vars (gfc_symbol
* proc_sym
, tree fnbody
)
2554 gfc_formal_arglist
*f
;
2556 bool seen_trans_deferred_array
= false;
2558 /* Deal with implicit return variables. Explicit return variables will
2559 already have been added. */
2560 if (gfc_return_by_reference (proc_sym
) && proc_sym
->result
== proc_sym
)
2562 if (!current_fake_result_decl
)
2564 gfc_entry_list
*el
= NULL
;
2565 if (proc_sym
->attr
.entry_master
)
2567 for (el
= proc_sym
->ns
->entries
; el
; el
= el
->next
)
2568 if (el
->sym
!= el
->sym
->result
)
2572 warning (0, "Function does not return a value");
2574 else if (proc_sym
->as
)
2576 tree result
= TREE_VALUE (current_fake_result_decl
);
2577 fnbody
= gfc_trans_dummy_array_bias (proc_sym
, result
, fnbody
);
2579 /* An automatic character length, pointer array result. */
2580 if (proc_sym
->ts
.type
== BT_CHARACTER
2581 && TREE_CODE (proc_sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
2582 fnbody
= gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.cl
,
2585 else if (proc_sym
->ts
.type
== BT_CHARACTER
)
2587 if (TREE_CODE (proc_sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
2588 fnbody
= gfc_trans_dummy_character (proc_sym
, proc_sym
->ts
.cl
,
2592 gcc_assert (gfc_option
.flag_f2c
2593 && proc_sym
->ts
.type
== BT_COMPLEX
);
2596 for (sym
= proc_sym
->tlink
; sym
!= proc_sym
; sym
= sym
->tlink
)
2598 bool sym_has_alloc_comp
= (sym
->ts
.type
== BT_DERIVED
)
2599 && sym
->ts
.derived
->attr
.alloc_comp
;
2600 if (sym
->attr
.dimension
)
2602 switch (sym
->as
->type
)
2605 if (sym
->attr
.dummy
|| sym
->attr
.result
)
2607 gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
, fnbody
);
2608 else if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2610 if (TREE_STATIC (sym
->backend_decl
))
2611 gfc_trans_static_array_pointer (sym
);
2614 seen_trans_deferred_array
= true;
2615 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
2620 if (sym_has_alloc_comp
)
2622 seen_trans_deferred_array
= true;
2623 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
2626 gfc_get_backend_locus (&loc
);
2627 gfc_set_backend_locus (&sym
->declared_at
);
2628 fnbody
= gfc_trans_auto_array_allocation (sym
->backend_decl
,
2630 gfc_set_backend_locus (&loc
);
2634 case AS_ASSUMED_SIZE
:
2635 /* Must be a dummy parameter. */
2636 gcc_assert (sym
->attr
.dummy
);
2638 /* We should always pass assumed size arrays the g77 way. */
2639 fnbody
= gfc_trans_g77_array (sym
, fnbody
);
2642 case AS_ASSUMED_SHAPE
:
2643 /* Must be a dummy parameter. */
2644 gcc_assert (sym
->attr
.dummy
);
2646 fnbody
= gfc_trans_dummy_array_bias (sym
, sym
->backend_decl
,
2651 seen_trans_deferred_array
= true;
2652 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
2658 if (sym_has_alloc_comp
&& !seen_trans_deferred_array
)
2659 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
2661 else if (sym_has_alloc_comp
)
2662 fnbody
= gfc_trans_deferred_array (sym
, fnbody
);
2663 else if (sym
->ts
.type
== BT_CHARACTER
)
2665 gfc_get_backend_locus (&loc
);
2666 gfc_set_backend_locus (&sym
->declared_at
);
2667 if (sym
->attr
.dummy
|| sym
->attr
.result
)
2668 fnbody
= gfc_trans_dummy_character (sym
, sym
->ts
.cl
, fnbody
);
2670 fnbody
= gfc_trans_auto_character_variable (sym
, fnbody
);
2671 gfc_set_backend_locus (&loc
);
2673 else if (sym
->attr
.assign
)
2675 gfc_get_backend_locus (&loc
);
2676 gfc_set_backend_locus (&sym
->declared_at
);
2677 fnbody
= gfc_trans_assign_aux_var (sym
, fnbody
);
2678 gfc_set_backend_locus (&loc
);
2684 gfc_init_block (&body
);
2686 for (f
= proc_sym
->formal
; f
; f
= f
->next
)
2688 if (f
->sym
&& f
->sym
->tlink
== NULL
&& f
->sym
->ts
.type
== BT_CHARACTER
)
2690 gcc_assert (f
->sym
->ts
.cl
->backend_decl
!= NULL
);
2691 if (TREE_CODE (f
->sym
->ts
.cl
->backend_decl
) == PARM_DECL
)
2692 gfc_trans_vla_type_sizes (f
->sym
, &body
);
2695 /* If an INTENT(OUT) dummy of derived type has a default
2696 initializer, it must be initialized here. */
2697 if (f
->sym
&& f
->sym
->attr
.intent
== INTENT_OUT
2698 && f
->sym
->ts
.type
== BT_DERIVED
2699 && !f
->sym
->ts
.derived
->attr
.alloc_comp
2704 gcc_assert (!f
->sym
->attr
.allocatable
);
2705 gfc_set_sym_referenced (f
->sym
);
2706 tmpe
= gfc_lval_expr_from_sym (f
->sym
);
2707 tmp
= gfc_trans_assignment (tmpe
, f
->sym
->value
, false);
2709 present
= gfc_conv_expr_present (f
->sym
);
2710 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
,
2711 tmp
, build_empty_stmt ());
2712 gfc_add_expr_to_block (&body
, tmp
);
2713 gfc_free_expr (tmpe
);
2717 if (gfc_return_by_reference (proc_sym
) && proc_sym
->ts
.type
== BT_CHARACTER
2718 && current_fake_result_decl
!= NULL
)
2720 gcc_assert (proc_sym
->ts
.cl
->backend_decl
!= NULL
);
2721 if (TREE_CODE (proc_sym
->ts
.cl
->backend_decl
) == PARM_DECL
)
2722 gfc_trans_vla_type_sizes (proc_sym
, &body
);
2725 gfc_add_expr_to_block (&body
, fnbody
);
2726 return gfc_finish_block (&body
);
2730 /* Output an initialized decl for a module variable. */
2733 gfc_create_module_variable (gfc_symbol
* sym
)
2737 /* Module functions with alternate entries are dealt with later and
2738 would get caught by the next condition. */
2739 if (sym
->attr
.entry
)
2742 /* Make sure we convert the types of the derived types from iso_c_binding
2744 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
2745 && sym
->ts
.type
== BT_DERIVED
)
2746 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
2748 /* Only output variables and array valued parameters. */
2749 if (sym
->attr
.flavor
!= FL_VARIABLE
2750 && (sym
->attr
.flavor
!= FL_PARAMETER
|| sym
->attr
.dimension
== 0))
2753 /* Don't generate variables from other modules. Variables from
2754 COMMONs will already have been generated. */
2755 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
2758 /* Equivalenced variables arrive here after creation. */
2759 if (sym
->backend_decl
2760 && (sym
->equiv_built
|| sym
->attr
.in_equivalence
))
2763 if (sym
->backend_decl
)
2764 internal_error ("backend decl for module variable %s already exists",
2767 /* We always want module variables to be created. */
2768 sym
->attr
.referenced
= 1;
2769 /* Create the decl. */
2770 decl
= gfc_get_symbol_decl (sym
);
2772 /* Create the variable. */
2774 rest_of_decl_compilation (decl
, 1, 0);
2776 /* Also add length of strings. */
2777 if (sym
->ts
.type
== BT_CHARACTER
)
2781 length
= sym
->ts
.cl
->backend_decl
;
2782 if (!INTEGER_CST_P (length
))
2785 rest_of_decl_compilation (length
, 1, 0);
2791 /* Generate all the required code for module variables. */
2794 gfc_generate_module_vars (gfc_namespace
* ns
)
2796 module_namespace
= ns
;
2798 /* Check if the frontend left the namespace in a reasonable state. */
2799 gcc_assert (ns
->proc_name
&& !ns
->proc_name
->tlink
);
2801 /* Generate COMMON blocks. */
2802 gfc_trans_common (ns
);
2804 /* Create decls for all the module variables. */
2805 gfc_traverse_ns (ns
, gfc_create_module_variable
);
2809 gfc_generate_contained_functions (gfc_namespace
* parent
)
2813 /* We create all the prototypes before generating any code. */
2814 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2816 /* Skip namespaces from used modules. */
2817 if (ns
->parent
!= parent
)
2820 gfc_create_function_decl (ns
);
2823 for (ns
= parent
->contained
; ns
; ns
= ns
->sibling
)
2825 /* Skip namespaces from used modules. */
2826 if (ns
->parent
!= parent
)
2829 gfc_generate_function_code (ns
);
2834 /* Drill down through expressions for the array specification bounds and
2835 character length calling generate_local_decl for all those variables
2836 that have not already been declared. */
2839 generate_local_decl (gfc_symbol
*);
2842 generate_expr_decls (gfc_symbol
*sym
, gfc_expr
*e
)
2844 gfc_actual_arglist
*arg
;
2851 switch (e
->expr_type
)
2854 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2855 generate_expr_decls (sym
, arg
->expr
);
2858 /* If the variable is not the same as the dependent, 'sym', and
2859 it is not marked as being declared and it is in the same
2860 namespace as 'sym', add it to the local declarations. */
2862 if (sym
== e
->symtree
->n
.sym
2863 || e
->symtree
->n
.sym
->mark
2864 || e
->symtree
->n
.sym
->ns
!= sym
->ns
)
2867 generate_local_decl (e
->symtree
->n
.sym
);
2871 generate_expr_decls (sym
, e
->value
.op
.op1
);
2872 generate_expr_decls (sym
, e
->value
.op
.op2
);
2881 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2886 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2888 generate_expr_decls (sym
, ref
->u
.ar
.start
[i
]);
2889 generate_expr_decls (sym
, ref
->u
.ar
.end
[i
]);
2890 generate_expr_decls (sym
, ref
->u
.ar
.stride
[i
]);
2895 generate_expr_decls (sym
, ref
->u
.ss
.start
);
2896 generate_expr_decls (sym
, ref
->u
.ss
.end
);
2900 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
2901 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
2903 generate_expr_decls (sym
, ref
->u
.c
.component
->ts
.cl
->length
);
2905 if (ref
->u
.c
.component
->as
)
2906 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
2908 generate_expr_decls (sym
, ref
->u
.c
.component
->as
->lower
[i
]);
2909 generate_expr_decls (sym
, ref
->u
.c
.component
->as
->upper
[i
]);
2918 /* Check for dependencies in the character length and array spec. */
2921 generate_dependency_declarations (gfc_symbol
*sym
)
2925 if (sym
->ts
.type
== BT_CHARACTER
2926 && sym
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2927 generate_expr_decls (sym
, sym
->ts
.cl
->length
);
2929 if (sym
->as
&& sym
->as
->rank
)
2931 for (i
= 0; i
< sym
->as
->rank
; i
++)
2933 generate_expr_decls (sym
, sym
->as
->lower
[i
]);
2934 generate_expr_decls (sym
, sym
->as
->upper
[i
]);
2940 /* Generate decls for all local variables. We do this to ensure correct
2941 handling of expressions which only appear in the specification of
2945 generate_local_decl (gfc_symbol
* sym
)
2947 if (sym
->attr
.flavor
== FL_VARIABLE
)
2949 /* Check for dependencies in the array specification and string
2950 length, adding the necessary declarations to the function. We
2951 mark the symbol now, as well as in traverse_ns, to prevent
2952 getting stuck in a circular dependency. */
2954 if (!sym
->attr
.dummy
&& !sym
->ns
->proc_name
->attr
.entry_master
)
2955 generate_dependency_declarations (sym
);
2957 if (sym
->attr
.referenced
)
2958 gfc_get_symbol_decl (sym
);
2959 /* INTENT(out) dummy arguments are likely meant to be set. */
2960 else if (warn_unused_variable
2962 && sym
->attr
.intent
== INTENT_OUT
)
2963 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
2964 sym
->name
, &sym
->declared_at
);
2965 /* Specific warning for unused dummy arguments. */
2966 else if (warn_unused_variable
&& sym
->attr
.dummy
)
2967 gfc_warning ("Unused dummy argument '%s' at %L", sym
->name
,
2969 /* Warn for unused variables, but not if they're inside a common
2970 block or are use-associated. */
2971 else if (warn_unused_variable
2972 && !(sym
->attr
.in_common
|| sym
->attr
.use_assoc
))
2973 gfc_warning ("Unused variable '%s' declared at %L", sym
->name
,
2975 /* For variable length CHARACTER parameters, the PARM_DECL already
2976 references the length variable, so force gfc_get_symbol_decl
2977 even when not referenced. If optimize > 0, it will be optimized
2978 away anyway. But do this only after emitting -Wunused-parameter
2979 warning if requested. */
2980 if (sym
->attr
.dummy
&& ! sym
->attr
.referenced
2981 && sym
->ts
.type
== BT_CHARACTER
2982 && sym
->ts
.cl
->backend_decl
!= NULL
2983 && TREE_CODE (sym
->ts
.cl
->backend_decl
) == VAR_DECL
)
2985 sym
->attr
.referenced
= 1;
2986 gfc_get_symbol_decl (sym
);
2989 /* We do not want the middle-end to warn about unused parameters
2990 as this was already done above. */
2991 if (sym
->attr
.dummy
&& sym
->backend_decl
!= NULL_TREE
)
2992 TREE_NO_WARNING(sym
->backend_decl
) = 1;
2994 else if (sym
->attr
.flavor
== FL_PARAMETER
)
2996 if (warn_unused_parameter
2997 && !sym
->attr
.referenced
2998 && !sym
->attr
.use_assoc
)
2999 gfc_warning ("Unused parameter '%s' declared at %L", sym
->name
,
3003 if (sym
->attr
.dummy
== 1)
3005 /* Modify the tree type for scalar character dummy arguments of bind(c)
3006 procedures if they are passed by value. The tree type for them will
3007 be promoted to INTEGER_TYPE for the middle end, which appears to be
3008 what C would do with characters passed by-value. The value attribute
3009 implies the dummy is a scalar. */
3010 if (sym
->attr
.value
== 1 && sym
->backend_decl
!= NULL
3011 && sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.is_c_interop
3012 && sym
->ns
->proc_name
!= NULL
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
3013 gfc_conv_scalar_char_value (sym
, NULL
, NULL
);
3016 /* Make sure we convert the types of the derived types from iso_c_binding
3018 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.is_iso_c
3019 && sym
->ts
.type
== BT_DERIVED
)
3020 sym
->backend_decl
= gfc_typenode_for_spec (&(sym
->ts
));
3024 generate_local_vars (gfc_namespace
* ns
)
3026 gfc_traverse_ns (ns
, generate_local_decl
);
3030 /* Generate a switch statement to jump to the correct entry point. Also
3031 creates the label decls for the entry points. */
3034 gfc_trans_entry_master_switch (gfc_entry_list
* el
)
3041 gfc_init_block (&block
);
3042 for (; el
; el
= el
->next
)
3044 /* Add the case label. */
3045 label
= gfc_build_label_decl (NULL_TREE
);
3046 val
= build_int_cst (gfc_array_index_type
, el
->id
);
3047 tmp
= build3_v (CASE_LABEL_EXPR
, val
, NULL_TREE
, label
);
3048 gfc_add_expr_to_block (&block
, tmp
);
3050 /* And jump to the actual entry point. */
3051 label
= gfc_build_label_decl (NULL_TREE
);
3052 tmp
= build1_v (GOTO_EXPR
, label
);
3053 gfc_add_expr_to_block (&block
, tmp
);
3055 /* Save the label decl. */
3058 tmp
= gfc_finish_block (&block
);
3059 /* The first argument selects the entry point. */
3060 val
= DECL_ARGUMENTS (current_function_decl
);
3061 tmp
= build3_v (SWITCH_EXPR
, val
, tmp
, NULL_TREE
);
3066 /* Generate code for a function. */
3069 gfc_generate_function_code (gfc_namespace
* ns
)
3082 sym
= ns
->proc_name
;
3084 /* Check that the frontend isn't still using this. */
3085 gcc_assert (sym
->tlink
== NULL
);
3088 /* Create the declaration for functions with global scope. */
3089 if (!sym
->backend_decl
)
3090 gfc_create_function_decl (ns
);
3092 fndecl
= sym
->backend_decl
;
3093 old_context
= current_function_decl
;
3097 push_function_context ();
3098 saved_parent_function_decls
= saved_function_decls
;
3099 saved_function_decls
= NULL_TREE
;
3102 trans_function_start (sym
);
3104 gfc_start_block (&block
);
3106 if (ns
->entries
&& ns
->proc_name
->ts
.type
== BT_CHARACTER
)
3108 /* Copy length backend_decls to all entry point result
3113 gfc_conv_const_charlen (ns
->proc_name
->ts
.cl
);
3114 backend_decl
= ns
->proc_name
->result
->ts
.cl
->backend_decl
;
3115 for (el
= ns
->entries
; el
; el
= el
->next
)
3116 el
->sym
->result
->ts
.cl
->backend_decl
= backend_decl
;
3119 /* Translate COMMON blocks. */
3120 gfc_trans_common (ns
);
3122 /* Null the parent fake result declaration if this namespace is
3123 a module function or an external procedures. */
3124 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
3125 || ns
->parent
== NULL
)
3126 parent_fake_result_decl
= NULL_TREE
;
3128 gfc_generate_contained_functions (ns
);
3130 generate_local_vars (ns
);
3132 /* Keep the parent fake result declaration in module functions
3133 or external procedures. */
3134 if ((ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
3135 || ns
->parent
== NULL
)
3136 current_fake_result_decl
= parent_fake_result_decl
;
3138 current_fake_result_decl
= NULL_TREE
;
3140 current_function_return_label
= NULL
;
3142 /* Now generate the code for the body of this function. */
3143 gfc_init_block (&body
);
3145 /* If this is the main program, add a call to set_options to set up the
3146 runtime library Fortran language standard parameters. */
3147 if (sym
->attr
.is_main_program
)
3149 tree array_type
, array
, var
;
3151 /* Passing a new option to the library requires four modifications:
3152 + add it to the tree_cons list below
3153 + change the array size in the call to build_array_type
3154 + change the first argument to the library call
3155 gfor_fndecl_set_options
3156 + modify the library (runtime/compile_options.c)! */
3157 array
= tree_cons (NULL_TREE
,
3158 build_int_cst (integer_type_node
,
3159 gfc_option
.warn_std
), NULL_TREE
);
3160 array
= tree_cons (NULL_TREE
,
3161 build_int_cst (integer_type_node
,
3162 gfc_option
.allow_std
), array
);
3163 array
= tree_cons (NULL_TREE
,
3164 build_int_cst (integer_type_node
, pedantic
), array
);
3165 array
= tree_cons (NULL_TREE
,
3166 build_int_cst (integer_type_node
,
3167 gfc_option
.flag_dump_core
), array
);
3168 array
= tree_cons (NULL_TREE
,
3169 build_int_cst (integer_type_node
,
3170 gfc_option
.flag_backtrace
), array
);
3171 array
= tree_cons (NULL_TREE
,
3172 build_int_cst (integer_type_node
,
3173 gfc_option
.flag_sign_zero
), array
);
3175 array
= tree_cons (NULL_TREE
,
3176 build_int_cst (integer_type_node
,
3177 flag_bounds_check
), array
);
3179 array_type
= build_array_type (integer_type_node
,
3180 build_index_type (build_int_cst (NULL_TREE
,
3182 array
= build_constructor_from_list (array_type
, nreverse (array
));
3183 TREE_CONSTANT (array
) = 1;
3184 TREE_INVARIANT (array
) = 1;
3185 TREE_STATIC (array
) = 1;
3187 /* Create a static variable to hold the jump table. */
3188 var
= gfc_create_var (array_type
, "options");
3189 TREE_CONSTANT (var
) = 1;
3190 TREE_INVARIANT (var
) = 1;
3191 TREE_STATIC (var
) = 1;
3192 TREE_READONLY (var
) = 1;
3193 DECL_INITIAL (var
) = array
;
3194 var
= gfc_build_addr_expr (pvoid_type_node
, var
);
3196 tmp
= build_call_expr (gfor_fndecl_set_options
, 2,
3197 build_int_cst (integer_type_node
, 7), var
);
3198 gfc_add_expr_to_block (&body
, tmp
);
3201 /* If this is the main program and a -ffpe-trap option was provided,
3202 add a call to set_fpe so that the library will raise a FPE when
3204 if (sym
->attr
.is_main_program
&& gfc_option
.fpe
!= 0)
3206 tmp
= build_call_expr (gfor_fndecl_set_fpe
, 1,
3207 build_int_cst (integer_type_node
,
3209 gfc_add_expr_to_block (&body
, tmp
);
3212 /* If this is the main program and an -fconvert option was provided,
3213 add a call to set_convert. */
3215 if (sym
->attr
.is_main_program
&& gfc_option
.convert
!= GFC_CONVERT_NATIVE
)
3217 tmp
= build_call_expr (gfor_fndecl_set_convert
, 1,
3218 build_int_cst (integer_type_node
,
3219 gfc_option
.convert
));
3220 gfc_add_expr_to_block (&body
, tmp
);
3223 /* If this is the main program and an -frecord-marker option was provided,
3224 add a call to set_record_marker. */
3226 if (sym
->attr
.is_main_program
&& gfc_option
.record_marker
!= 0)
3228 tmp
= build_call_expr (gfor_fndecl_set_record_marker
, 1,
3229 build_int_cst (integer_type_node
,
3230 gfc_option
.record_marker
));
3231 gfc_add_expr_to_block (&body
, tmp
);
3234 if (sym
->attr
.is_main_program
&& gfc_option
.max_subrecord_length
!= 0)
3236 tmp
= build_call_expr (gfor_fndecl_set_max_subrecord_length
,
3238 build_int_cst (integer_type_node
,
3239 gfc_option
.max_subrecord_length
));
3240 gfc_add_expr_to_block (&body
, tmp
);
3243 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
3244 && sym
->attr
.subroutine
)
3246 tree alternate_return
;
3247 alternate_return
= gfc_get_fake_result_decl (sym
, 0);
3248 gfc_add_modify_expr (&body
, alternate_return
, integer_zero_node
);
3253 /* Jump to the correct entry point. */
3254 tmp
= gfc_trans_entry_master_switch (ns
->entries
);
3255 gfc_add_expr_to_block (&body
, tmp
);
3258 tmp
= gfc_trans_code (ns
->code
);
3259 gfc_add_expr_to_block (&body
, tmp
);
3261 /* Add a return label if needed. */
3262 if (current_function_return_label
)
3264 tmp
= build1_v (LABEL_EXPR
, current_function_return_label
);
3265 gfc_add_expr_to_block (&body
, tmp
);
3268 tmp
= gfc_finish_block (&body
);
3269 /* Add code to create and cleanup arrays. */
3270 tmp
= gfc_trans_deferred_vars (sym
, tmp
);
3272 if (TREE_TYPE (DECL_RESULT (fndecl
)) != void_type_node
)
3274 if (sym
->attr
.subroutine
|| sym
== sym
->result
)
3276 if (current_fake_result_decl
!= NULL
)
3277 result
= TREE_VALUE (current_fake_result_decl
);
3280 current_fake_result_decl
= NULL_TREE
;
3283 result
= sym
->result
->backend_decl
;
3285 if (result
!= NULL_TREE
&& sym
->attr
.function
3286 && sym
->ts
.type
== BT_DERIVED
3287 && sym
->ts
.derived
->attr
.alloc_comp
3288 && !sym
->attr
.pointer
)
3290 rank
= sym
->as
? sym
->as
->rank
: 0;
3291 tmp2
= gfc_nullify_alloc_comp (sym
->ts
.derived
, result
, rank
);
3292 gfc_add_expr_to_block (&block
, tmp2
);
3295 gfc_add_expr_to_block (&block
, tmp
);
3297 if (result
== NULL_TREE
)
3298 warning (0, "Function return value not set");
3301 /* Set the return value to the dummy result variable. The
3302 types may be different for scalar default REAL functions
3303 with -ff2c, therefore we have to convert. */
3304 tmp
= convert (TREE_TYPE (DECL_RESULT (fndecl
)), result
);
3305 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (tmp
),
3306 DECL_RESULT (fndecl
), tmp
);
3307 tmp
= build1_v (RETURN_EXPR
, tmp
);
3308 gfc_add_expr_to_block (&block
, tmp
);
3312 gfc_add_expr_to_block (&block
, tmp
);
3315 /* Add all the decls we created during processing. */
3316 decl
= saved_function_decls
;
3321 next
= TREE_CHAIN (decl
);
3322 TREE_CHAIN (decl
) = NULL_TREE
;
3326 saved_function_decls
= NULL_TREE
;
3328 DECL_SAVED_TREE (fndecl
) = gfc_finish_block (&block
);
3330 /* Finish off this function and send it for code generation. */
3332 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
3334 /* Output the GENERIC tree. */
3335 dump_function (TDI_original
, fndecl
);
3337 /* Store the end of the function, so that we get good line number
3338 info for the epilogue. */
3339 cfun
->function_end_locus
= input_location
;
3341 /* We're leaving the context of this function, so zap cfun.
3342 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3343 tree_rest_of_compilation. */
3348 pop_function_context ();
3349 saved_function_decls
= saved_parent_function_decls
;
3351 current_function_decl
= old_context
;
3353 if (decl_function_context (fndecl
))
3354 /* Register this function with cgraph just far enough to get it
3355 added to our parent's nested function list. */
3356 (void) cgraph_node (fndecl
);
3359 gfc_gimplify_function (fndecl
);
3360 cgraph_finalize_function (fndecl
, false);
3365 gfc_generate_constructors (void)
3367 gcc_assert (gfc_static_ctors
== NULL_TREE
);
3375 if (gfc_static_ctors
== NULL_TREE
)
3378 fnname
= get_file_function_name ("I");
3379 type
= build_function_type (void_type_node
,
3380 gfc_chainon_list (NULL_TREE
, void_type_node
));
3382 fndecl
= build_decl (FUNCTION_DECL
, fnname
, type
);
3383 TREE_PUBLIC (fndecl
) = 1;
3385 decl
= build_decl (RESULT_DECL
, NULL_TREE
, void_type_node
);
3386 DECL_ARTIFICIAL (decl
) = 1;
3387 DECL_IGNORED_P (decl
) = 1;
3388 DECL_CONTEXT (decl
) = fndecl
;
3389 DECL_RESULT (fndecl
) = decl
;
3393 current_function_decl
= fndecl
;
3395 rest_of_decl_compilation (fndecl
, 1, 0);
3397 make_decl_rtl (fndecl
);
3399 init_function_start (fndecl
);
3403 for (; gfc_static_ctors
; gfc_static_ctors
= TREE_CHAIN (gfc_static_ctors
))
3405 tmp
= build_call_expr (TREE_VALUE (gfc_static_ctors
), 0);
3406 DECL_SAVED_TREE (fndecl
) = build_stmt (EXPR_STMT
, tmp
);
3411 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
3413 free_after_parsing (cfun
);
3414 free_after_compilation (cfun
);
3416 tree_rest_of_compilation (fndecl
);
3418 current_function_decl
= NULL_TREE
;
3422 /* Translates a BLOCK DATA program unit. This means emitting the
3423 commons contained therein plus their initializations. We also emit
3424 a globally visible symbol to make sure that each BLOCK DATA program
3425 unit remains unique. */
3428 gfc_generate_block_data (gfc_namespace
* ns
)
3433 /* Tell the backend the source location of the block data. */
3435 gfc_set_backend_locus (&ns
->proc_name
->declared_at
);
3437 gfc_set_backend_locus (&gfc_current_locus
);
3439 /* Process the DATA statements. */
3440 gfc_trans_common (ns
);
3442 /* Create a global symbol with the mane of the block data. This is to
3443 generate linker errors if the same name is used twice. It is never
3446 id
= gfc_sym_mangled_function_id (ns
->proc_name
);
3448 id
= get_identifier ("__BLOCK_DATA__");
3450 decl
= build_decl (VAR_DECL
, id
, gfc_array_index_type
);
3451 TREE_PUBLIC (decl
) = 1;
3452 TREE_STATIC (decl
) = 1;
3455 rest_of_decl_compilation (decl
, 1, 0);
3459 #include "gt-fortran-trans-decl.h"