Bug Summary

File:build/gcc/fortran/trans-expr.cc
Warning:line 9468, column 4
Passed-by-value struct argument contains uninitialized data (e.g., field: 'dimension')

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name trans-expr.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-aZrI2e.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc
1/* Expression translation
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
6This file is part of GCC.
7
8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 3, or (at your option) any later
11version.
12
13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
17
18You should have received a copy of the GNU General Public License
19along with GCC; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. */
21
22/* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "options.h"
28#include "tree.h"
29#include "gfortran.h"
30#include "trans.h"
31#include "stringpool.h"
32#include "diagnostic-core.h" /* For fatal_error. */
33#include "fold-const.h"
34#include "langhooks.h"
35#include "arith.h"
36#include "constructor.h"
37#include "trans-const.h"
38#include "trans-types.h"
39#include "trans-array.h"
40/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41#include "trans-stmt.h"
42#include "dependency.h"
43#include "gimplify.h"
44#include "tm.h" /* For CHAR_TYPE_SIZE. */
45
46
47/* Calculate the number of characters in a string. */
48
49static tree
50gfc_get_character_len (tree type)
51{
52 tree len;
53
54 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE((void)(!(type && ((enum tree_code) (type)->base.code
) == ARRAY_TYPE && ((tree_check2 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 55, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 55, __FUNCTION__), 0 : 0))
55 && TYPE_STRING_FLAG (type))((void)(!(type && ((enum tree_code) (type)->base.code
) == ARRAY_TYPE && ((tree_check2 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 55, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 55, __FUNCTION__), 0 : 0))
;
56
57 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type))((tree_check5 ((((tree_check ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 57, __FUNCTION__, (ARRAY_TYPE)))->type_non_common.values
)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 57, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
;
58 len = (len) ? (len) : (integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
59 return fold_convert (gfc_charlen_type_node, len)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, len
)
;
60}
61
62
63
64/* Calculate the number of bytes in a string. */
65
66tree
67gfc_get_character_len_in_bytes (tree type)
68{
69 tree tmp, len;
70
71 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE((void)(!(type && ((enum tree_code) (type)->base.code
) == ARRAY_TYPE && ((tree_check2 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 72, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 72, __FUNCTION__), 0 : 0))
72 && TYPE_STRING_FLAG (type))((void)(!(type && ((enum tree_code) (type)->base.code
) == ARRAY_TYPE && ((tree_check2 ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 72, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 72, __FUNCTION__), 0 : 0))
;
73
74 tmp = TYPE_SIZE_UNIT (TREE_TYPE (type))((tree_class_check ((((contains_struct_check ((type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 74, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 74, __FUNCTION__))->type_common.size_unit)
;
75 tmp = (tmp && !integer_zerop (tmp))
76 ? (fold_convert (gfc_charlen_type_node, tmp)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, tmp
)
) : (NULL_TREE(tree) __null);
77 len = gfc_get_character_len (type);
78 if (tmp && len && !integer_zerop (len))
79 len = fold_build2_loc (input_location, MULT_EXPR,
80 gfc_charlen_type_node, len, tmp);
81 return len;
82}
83
84
85/* Convert a scalar to an array descriptor. To be used for assumed-rank
86 arrays. */
87
88static tree
89get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
90{
91 enum gfc_array_kind akind;
92
93 if (attr.pointer)
94 akind = GFC_ARRAY_POINTER_CONT;
95 else if (attr.allocatable)
96 akind = GFC_ARRAY_ALLOCATABLE;
97 else
98 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
99
100 if (POINTER_TYPE_P (TREE_TYPE (scalar))(((enum tree_code) (((contains_struct_check ((scalar), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 100, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((scalar), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 100, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
101 scalar = TREE_TYPE (scalar)((contains_struct_check ((scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 101, __FUNCTION__))->typed.type)
;
102 return gfc_get_array_type_bounds (TREE_TYPE (scalar)((contains_struct_check ((scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 102, __FUNCTION__))->typed.type)
, 0, 0, NULL__null, NULL__null, 1,
103 akind, !(attr.pointer || attr.target));
104}
105
106tree
107gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
108{
109 tree desc, type, etype;
110
111 type = get_scalar_to_descriptor_type (scalar, attr);
112 etype = TREE_TYPE (scalar)((contains_struct_check ((scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 112, __FUNCTION__))->typed.type)
;
113 desc = gfc_create_var (type, "desc");
114 DECL_ARTIFICIAL (desc)((contains_struct_check ((desc), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 114, __FUNCTION__))->decl_common.artificial_flag)
= 1;
115
116 if (CONSTANT_CLASS_P (scalar)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (scalar)->base.code))] == tcc_constant)
)
117 {
118 tree tmp;
119 tmp = gfc_create_var (TREE_TYPE (scalar)((contains_struct_check ((scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 119, __FUNCTION__))->typed.type)
, "scalar");
120 gfc_add_modify (&se->pre, tmp, scalar);
121 scalar = tmp;
122 }
123 if (!POINTER_TYPE_P (TREE_TYPE (scalar))(((enum tree_code) (((contains_struct_check ((scalar), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 123, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((scalar), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 123, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
124 scalar = gfc_build_addr_expr (NULL_TREE(tree) __null, scalar);
125 else if (TREE_TYPE (etype)((contains_struct_check ((etype), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 125, __FUNCTION__))->typed.type)
&& TREE_CODE (TREE_TYPE (etype))((enum tree_code) (((contains_struct_check ((etype), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 125, __FUNCTION__))->typed.type))->base.code)
== ARRAY_TYPE)
126 etype = TREE_TYPE (etype)((contains_struct_check ((etype), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 126, __FUNCTION__))->typed.type)
;
127 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
128 gfc_get_dtype_rank_type (0, etype));
129 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
130 gfc_conv_descriptor_span_set (&se->pre, desc,
131 gfc_conv_descriptor_elem_len (desc));
132
133 /* Copy pointer address back - but only if it could have changed and
134 if the actual argument is a pointer and not, e.g., NULL(). */
135 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
136 gfc_add_modify (&se->post, scalar,
137 fold_convert (TREE_TYPE (scalar),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 137, __FUNCTION__))->typed.type), gfc_conv_descriptor_data_get
(desc))
138 gfc_conv_descriptor_data_get (desc))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(scalar), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 137, __FUNCTION__))->typed.type), gfc_conv_descriptor_data_get
(desc))
);
139 return desc;
140}
141
142
143/* Get the coarray token from the ultimate array or component ref.
144 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
145
146tree
147gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
148{
149 gfc_symbol *sym = expr->symtree->n.sym;
150 bool is_coarray = sym->attr.codimension;
151 gfc_expr *caf_expr = gfc_copy_expr (expr);
152 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL__null;
153
154 while (ref)
155 {
156 if (ref->type == REF_COMPONENT
157 && (ref->u.c.component->attr.allocatable
158 || ref->u.c.component->attr.pointer)
159 && (is_coarray || ref->u.c.component->attr.codimension))
160 last_caf_ref = ref;
161 ref = ref->next;
162 }
163
164 if (last_caf_ref == NULL__null)
165 return NULL_TREE(tree) __null;
166
167 tree comp = last_caf_ref->u.c.component->caf_token, caf;
168 gfc_se se;
169 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
170 if (comp == NULL_TREE(tree) __null && comp_ref)
171 return NULL_TREE(tree) __null;
172 gfc_init_se (&se, outerse);
173 gfc_free_ref_list (last_caf_ref->next);
174 last_caf_ref->next = NULL__null;
175 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
176 se.want_pointer = comp_ref;
177 gfc_conv_expr (&se, caf_expr);
178 gfc_add_block_to_block (&outerse->pre, &se.pre);
179
180 if (TREE_CODE (se.expr)((enum tree_code) (se.expr)->base.code) == COMPONENT_REF && comp_ref)
181 se.expr = TREE_OPERAND (se.expr, 0)(*((const_cast<tree*> (tree_operand_check ((se.expr), (
0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 181, __FUNCTION__)))))
;
182 gfc_free_expr (caf_expr);
183
184 if (comp_ref)
185 caf = fold_build3_loc (input_location, COMPONENT_REF,
186 TREE_TYPE (comp)((contains_struct_check ((comp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 186, __FUNCTION__))->typed.type)
, se.expr, comp, NULL_TREE(tree) __null);
187 else
188 caf = gfc_conv_descriptor_token (se.expr);
189 return gfc_build_addr_expr (NULL_TREE(tree) __null, caf);
190}
191
192
193/* This is the seed for an eventual trans-class.c
194
195 The following parameters should not be used directly since they might
196 in future implementations. Use the corresponding APIs. */
197#define CLASS_DATA_FIELD 0
198#define CLASS_VPTR_FIELD 1
199#define CLASS_LEN_FIELD 2
200#define VTABLE_HASH_FIELD 0
201#define VTABLE_SIZE_FIELD 1
202#define VTABLE_EXTENDS_FIELD 2
203#define VTABLE_DEF_INIT_FIELD 3
204#define VTABLE_COPY_FIELD 4
205#define VTABLE_FINAL_FIELD 5
206#define VTABLE_DEALLOCATE_FIELD6 6
207
208
209tree
210gfc_class_set_static_fields (tree decl, tree vptr, tree data)
211{
212 tree tmp;
213 tree field;
214 vec<constructor_elt, va_gc> *init = NULL__null;
215
216 field = TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 216, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 216, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
;
217 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
218 CONSTRUCTOR_APPEND_ELT (init, tmp, data)do { constructor_elt _ce___ = {tmp, data}; vec_safe_push ((init
), _ce___); } while (0)
;
219
220 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
221 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr)do { constructor_elt _ce___ = {tmp, vptr}; vec_safe_push ((init
), _ce___); } while (0)
;
222
223 return build_constructor (TREE_TYPE (decl)((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 223, __FUNCTION__))->typed.type)
, init);
224}
225
226
227tree
228gfc_class_data_get (tree decl)
229{
230 tree data;
231 if (POINTER_TYPE_P (TREE_TYPE (decl))(((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 231, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 231, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
232 decl = build_fold_indirect_ref_loc (input_location, decl);
233 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 233, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 233, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
234 CLASS_DATA_FIELD);
235 return fold_build3_loc (input_location, COMPONENT_REF,
236 TREE_TYPE (data)((contains_struct_check ((data), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 236, __FUNCTION__))->typed.type)
, decl, data,
237 NULL_TREE(tree) __null);
238}
239
240
241tree
242gfc_class_vptr_get (tree decl)
243{
244 tree vptr;
245 /* For class arrays decl may be a temporary descriptor handle, the vptr is
246 then available through the saved descriptor. */
247 if (VAR_P (decl)(((enum tree_code) (decl)->base.code) == VAR_DECL) && DECL_LANG_SPECIFIC (decl)((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 247, __FUNCTION__))->decl_common.lang_specific)
248 && GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 248, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
)
249 decl = GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 249, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
250 if (POINTER_TYPE_P (TREE_TYPE (decl))(((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 250, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 250, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
251 decl = build_fold_indirect_ref_loc (input_location, decl);
252 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 252, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 252, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
253 CLASS_VPTR_FIELD);
254 return fold_build3_loc (input_location, COMPONENT_REF,
255 TREE_TYPE (vptr)((contains_struct_check ((vptr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 255, __FUNCTION__))->typed.type)
, decl, vptr,
256 NULL_TREE(tree) __null);
257}
258
259
260tree
261gfc_class_len_get (tree decl)
262{
263 tree len;
264 /* For class arrays decl may be a temporary descriptor handle, the len is
265 then available through the saved descriptor. */
266 if (VAR_P (decl)(((enum tree_code) (decl)->base.code) == VAR_DECL) && DECL_LANG_SPECIFIC (decl)((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 266, __FUNCTION__))->decl_common.lang_specific)
267 && GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 267, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
)
268 decl = GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 268, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
269 if (POINTER_TYPE_P (TREE_TYPE (decl))(((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 269, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 269, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
270 decl = build_fold_indirect_ref_loc (input_location, decl);
271 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 271, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 271, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
272 CLASS_LEN_FIELD);
273 return fold_build3_loc (input_location, COMPONENT_REF,
274 TREE_TYPE (len)((contains_struct_check ((len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 274, __FUNCTION__))->typed.type)
, decl, len,
275 NULL_TREE(tree) __null);
276}
277
278
279/* Try to get the _len component of a class. When the class is not unlimited
280 poly, i.e. no _len field exists, then return a zero node. */
281
282static tree
283gfc_class_len_or_zero_get (tree decl)
284{
285 tree len;
286 /* For class arrays decl may be a temporary descriptor handle, the vptr is
287 then available through the saved descriptor. */
288 if (VAR_P (decl)(((enum tree_code) (decl)->base.code) == VAR_DECL) && DECL_LANG_SPECIFIC (decl)((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 288, __FUNCTION__))->decl_common.lang_specific)
289 && GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 289, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
)
290 decl = GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 290, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
291 if (POINTER_TYPE_P (TREE_TYPE (decl))(((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 291, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 291, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
292 decl = build_fold_indirect_ref_loc (input_location, decl);
293 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 293, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 293, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
294 CLASS_LEN_FIELD);
295 return len != NULL_TREE(tree) __null ? fold_build3_loc (input_location, COMPONENT_REF,
296 TREE_TYPE (len)((contains_struct_check ((len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 296, __FUNCTION__))->typed.type)
, decl, len,
297 NULL_TREE(tree) __null)
298 : build_zero_cst (gfc_charlen_type_node);
299}
300
301
302tree
303gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
304{
305 tree tmp;
306 tree tmp2;
307 tree type;
308
309 tmp = gfc_class_len_or_zero_get (class_expr);
310
311 /* Include the len value in the element size if present. */
312 if (!integer_zerop (tmp))
313 {
314 type = TREE_TYPE (size)((contains_struct_check ((size), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 314, __FUNCTION__))->typed.type)
;
315 if (block)
316 {
317 size = gfc_evaluate_now (size, block);
318 tmp = gfc_evaluate_now (fold_convert (type , tmp)fold_convert_loc (((location_t) 0), type, tmp), block);
319 }
320 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
321 type, size, tmp);
322 tmp = fold_build2_loc (input_location, GT_EXPR,
323 logical_type_node, tmp,
324 build_zero_cst (type));
325 size = fold_build3_loc (input_location, COND_EXPR,
326 type, tmp, tmp2, size);
327 }
328 else
329 return size;
330
331 if (block)
332 size = gfc_evaluate_now (size, block);
333
334 return size;
335}
336
337
338/* Get the specified FIELD from the VPTR. */
339
340static tree
341vptr_field_get (tree vptr, int fieldno)
342{
343 tree field;
344 vptr = build_fold_indirect_ref_loc (input_location, vptr);
345 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr))((tree_check3 ((((contains_struct_check ((vptr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 345, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 345, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
346 fieldno);
347 field = fold_build3_loc (input_location, COMPONENT_REF,
348 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 348, __FUNCTION__))->typed.type)
, vptr, field,
349 NULL_TREE(tree) __null);
350 gcc_assert (field)((void)(!(field) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 350, __FUNCTION__), 0 : 0))
;
351 return field;
352}
353
354
355/* Get the field from the class' vptr. */
356
357static tree
358class_vtab_field_get (tree decl, int fieldno)
359{
360 tree vptr;
361 vptr = gfc_class_vptr_get (decl);
362 return vptr_field_get (vptr, fieldno);
363}
364
365
366/* Define a macro for creating the class_vtab_* and vptr_* accessors in
367 unison. */
368#define VTAB_GET_FIELD_GEN(name, field) tree \
369gfc_class_vtab_## name ##_get (tree cl) \
370{ \
371 return class_vtab_field_get (cl, field); \
372} \
373 \
374tree \
375gfc_vptr_## name ##_get (tree vptr) \
376{ \
377 return vptr_field_get (vptr, field); \
378}
379
380VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
381VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
382VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
383VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
384VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
385VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD6)
386#undef VTAB_GET_FIELD_GEN
387
388/* The size field is returned as an array index type. Therefore treat
389 it and only it specially. */
390
391tree
392gfc_class_vtab_size_get (tree cl)
393{
394 tree size;
395 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
396 /* Always return size as an array index type. */
397 size = fold_convert (gfc_array_index_type, size)fold_convert_loc (((location_t) 0), gfc_array_index_type, size
)
;
398 gcc_assert (size)((void)(!(size) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 398, __FUNCTION__), 0 : 0))
;
399 return size;
400}
401
402tree
403gfc_vptr_size_get (tree vptr)
404{
405 tree size;
406 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
407 /* Always return size as an array index type. */
408 size = fold_convert (gfc_array_index_type, size)fold_convert_loc (((location_t) 0), gfc_array_index_type, size
)
;
409 gcc_assert (size)((void)(!(size) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 409, __FUNCTION__), 0 : 0))
;
410 return size;
411}
412
413
414#undef CLASS_DATA_FIELD
415#undef CLASS_VPTR_FIELD
416#undef CLASS_LEN_FIELD
417#undef VTABLE_HASH_FIELD
418#undef VTABLE_SIZE_FIELD
419#undef VTABLE_EXTENDS_FIELD
420#undef VTABLE_DEF_INIT_FIELD
421#undef VTABLE_COPY_FIELD
422#undef VTABLE_FINAL_FIELD
423
424
425/* IF ts is null (default), search for the last _class ref in the chain
426 of references of the expression and cut the chain there. Although
427 this routine is similiar to class.cc:gfc_add_component_ref (), there
428 is a significant difference: gfc_add_component_ref () concentrates
429 on an array ref that is the last ref in the chain and is oblivious
430 to the kind of refs following.
431 ELSE IF ts is non-null the cut is at the class entity or component
432 that is followed by an array reference, which is not an element.
433 These calls come from trans-array.cc:build_class_array_ref, which
434 handles scalarized class array references.*/
435
436gfc_expr *
437gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
438 gfc_typespec **ts)
439{
440 gfc_expr *base_expr;
441 gfc_ref *ref, *class_ref, *tail = NULL__null, *array_ref;
442
443 /* Find the last class reference. */
444 class_ref = NULL__null;
445 array_ref = NULL__null;
446
447 if (ts)
448 {
449 if (e->symtree
450 && e->symtree->n.sym->ts.type == BT_CLASS)
451 *ts = &e->symtree->n.sym->ts;
452 else
453 *ts = NULL__null;
454 }
455
456 for (ref = e->ref; ref; ref = ref->next)
457 {
458 if (ts)
459 {
460 if (ref->type == REF_COMPONENT
461 && ref->u.c.component->ts.type == BT_CLASS
462 && ref->next && ref->next->type == REF_COMPONENT
463 && !strcmp (ref->next->u.c.component->name, "_data")
464 && ref->next->next
465 && ref->next->next->type == REF_ARRAY
466 && ref->next->next->u.ar.type != AR_ELEMENT)
467 {
468 *ts = &ref->u.c.component->ts;
469 class_ref = ref;
470 break;
471 }
472
473 if (ref->next == NULL__null)
474 break;
475 }
476 else
477 {
478 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
479 array_ref = ref;
480
481 if (ref->type == REF_COMPONENT
482 && ref->u.c.component->ts.type == BT_CLASS)
483 {
484 /* Component to the right of a part reference with nonzero
485 rank must not have the ALLOCATABLE attribute. If attempts
486 are made to reference such a component reference, an error
487 results followed by an ICE. */
488 if (array_ref
489 && CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.allocatable)
490 return NULL__null;
491 class_ref = ref;
492 }
493 }
494 }
495
496 if (ts && *ts == NULL__null)
497 return NULL__null;
498
499 /* Remove and store all subsequent references after the
500 CLASS reference. */
501 if (class_ref)
502 {
503 tail = class_ref->next;
504 class_ref->next = NULL__null;
505 }
506 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
507 {
508 tail = e->ref;
509 e->ref = NULL__null;
510 }
511
512 if (is_mold)
513 base_expr = gfc_expr_to_initialize (e);
514 else
515 base_expr = gfc_copy_expr (e);
516
517 /* Restore the original tail expression. */
518 if (class_ref)
519 {
520 gfc_free_ref_list (class_ref->next);
521 class_ref->next = tail;
522 }
523 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
524 {
525 gfc_free_ref_list (e->ref);
526 e->ref = tail;
527 }
528 return base_expr;
529}
530
531
532/* Reset the vptr to the declared type, e.g. after deallocation. */
533
534void
535gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
536{
537 gfc_symbol *vtab;
538 tree vptr;
539 tree vtable;
540 gfc_se se;
541
542 /* Evaluate the expression and obtain the vptr from it. */
543 gfc_init_se (&se, NULL__null);
544 if (e->rank)
545 gfc_conv_expr_descriptor (&se, e);
546 else
547 gfc_conv_expr (&se, e);
548 gfc_add_block_to_block (block, &se.pre);
549 vptr = gfc_get_vptr_from_expr (se.expr);
550
551 /* If a vptr is not found, we can do nothing more. */
552 if (vptr == NULL_TREE(tree) __null)
553 return;
554
555 if (UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
)
556 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr)((contains_struct_check ((vptr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 556, __FUNCTION__))->typed.type)
, 0));
557 else
558 {
559 /* Return the vptr to the address of the declared type. */
560 vtab = gfc_find_derived_vtab (e->ts.u.derived);
561 vtable = vtab->backend_decl;
562 if (vtable == NULL_TREE(tree) __null)
563 vtable = gfc_get_symbol_decl (vtab);
564 vtable = gfc_build_addr_expr (NULL__null, vtable);
565 vtable = fold_convert (TREE_TYPE (vptr), vtable)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(vptr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 565, __FUNCTION__))->typed.type), vtable)
;
566 gfc_add_modify (block, vptr, vtable);
567 }
568}
569
570
571/* Reset the len for unlimited polymorphic objects. */
572
573void
574gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
575{
576 gfc_expr *e;
577 gfc_se se_len;
578 e = gfc_find_and_cut_at_last_class_ref (expr);
579 if (e == NULL__null)
580 return;
581 gfc_add_len_component (e)gfc_add_component_ref(e,"_len");
582 gfc_init_se (&se_len, NULL__null);
583 gfc_conv_expr (&se_len, e);
584 gfc_add_modify (block, se_len.expr,
585 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(se_len.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 585, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ZERO
])
);
586 gfc_free_expr (e);
587}
588
589
590/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
591 reference is found. Note that it is up to the caller to avoid using this
592 for expressions other than variables. */
593
594tree
595gfc_get_class_from_gfc_expr (gfc_expr *e)
596{
597 gfc_expr *class_expr;
598 gfc_se cse;
599 class_expr = gfc_find_and_cut_at_last_class_ref (e);
600 if (class_expr == NULL__null)
601 return NULL_TREE(tree) __null;
602 gfc_init_se (&cse, NULL__null);
603 gfc_conv_expr (&cse, class_expr);
604 gfc_free_expr (class_expr);
605 return cse.expr;
606}
607
608
609/* Obtain the last class reference in an expression.
610 Return NULL_TREE if no class reference is found. */
611
612tree
613gfc_get_class_from_expr (tree expr)
614{
615 tree tmp;
616 tree type;
617
618 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)(*((const_cast<tree*> (tree_operand_check ((tmp), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 618, __FUNCTION__)))))
)
619 {
620 if (CONSTANT_CLASS_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_constant)
)
621 return NULL_TREE(tree) __null;
622
623 type = TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 623, __FUNCTION__))->typed.type)
;
624 while (type)
625 {
626 if (GFC_CLASS_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 626, __FUNCTION__))->type_common.lang_flag_4)
)
627 return tmp;
628 if (type != TYPE_CANONICAL (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 628, __FUNCTION__))->type_common.canonical)
)
629 type = TYPE_CANONICAL (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 629, __FUNCTION__))->type_common.canonical)
;
630 else
631 type = NULL_TREE(tree) __null;
632 }
633 if (VAR_P (tmp)(((enum tree_code) (tmp)->base.code) == VAR_DECL) || TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == PARM_DECL)
634 break;
635 }
636
637 if (POINTER_TYPE_P (TREE_TYPE (tmp))(((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 637, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 637, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
638 tmp = build_fold_indirect_ref_loc (input_location, tmp);
639
640 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))((tree_class_check ((((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 640, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 640, __FUNCTION__))->type_common.lang_flag_4)
)
641 return tmp;
642
643 return NULL_TREE(tree) __null;
644}
645
646
647/* Obtain the vptr of the last class reference in an expression.
648 Return NULL_TREE if no class reference is found. */
649
650tree
651gfc_get_vptr_from_expr (tree expr)
652{
653 tree tmp;
654
655 tmp = gfc_get_class_from_expr (expr);
656
657 if (tmp != NULL_TREE(tree) __null)
658 return gfc_class_vptr_get (tmp);
659
660 return NULL_TREE(tree) __null;
661}
662
663
664static void
665class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
666 bool lhs_type)
667{
668 tree tmp, tmp2, type;
669
670 gfc_conv_descriptor_data_set (block, lhs_desc,
671 gfc_conv_descriptor_data_get (rhs_desc));
672 gfc_conv_descriptor_offset_set (block, lhs_desc,
673 gfc_conv_descriptor_offset_get (rhs_desc));
674
675 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
676 gfc_conv_descriptor_dtype (rhs_desc));
677
678 /* Assign the dimension as range-ref. */
679 tmp = gfc_get_descriptor_dimension (lhs_desc);
680 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
681
682 type = lhs_type ? TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 682, __FUNCTION__))->typed.type)
: TREE_TYPE (tmp2)((contains_struct_check ((tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 682, __FUNCTION__))->typed.type)
;
683 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
684 gfc_index_zero_nodegfc_rank_cst[0], NULL_TREE(tree) __null, NULL_TREE(tree) __null);
685 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
686 gfc_index_zero_nodegfc_rank_cst[0], NULL_TREE(tree) __null, NULL_TREE(tree) __null);
687 gfc_add_modify (block, tmp, tmp2);
688}
689
690
691/* Takes a derived type expression and returns the address of a temporary
692 class object of the 'declared' type. If vptr is not NULL, this is
693 used for the temporary class object.
694 optional_alloc_ptr is false when the dummy is neither allocatable
695 nor a pointer; that's only relevant for the optional handling.
696 The optional argument 'derived_array' is used to preserve the parmse
697 expression for deallocation of allocatable components. Assumed rank
698 formal arguments made this necessary. */
699void
700gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
701 gfc_typespec class_ts, tree vptr, bool optional,
702 bool optional_alloc_ptr,
703 tree *derived_array)
704{
705 gfc_symbol *vtab;
706 tree cond_optional = NULL_TREE(tree) __null;
707 gfc_ss *ss;
708 tree ctree;
709 tree var;
710 tree tmp;
711 int dim;
712
713 /* The derived type needs to be converted to a temporary
714 CLASS object. */
715 tmp = gfc_typenode_for_spec (&class_ts);
716 var = gfc_create_var (tmp, "class");
717
718 /* Set the vptr. */
719 ctree = gfc_class_vptr_get (var);
720
721 if (vptr != NULL_TREE(tree) __null)
722 {
723 /* Use the dynamic vptr. */
724 tmp = vptr;
725 }
726 else
727 {
728 /* In this case the vtab corresponds to the derived type and the
729 vptr must point to it. */
730 vtab = gfc_find_derived_vtab (e->ts.u.derived);
731 gcc_assert (vtab)((void)(!(vtab) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 731, __FUNCTION__), 0 : 0))
;
732 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, gfc_get_symbol_decl (vtab));
733 }
734 gfc_add_modify (&parmse->pre, ctree,
735 fold_convert (TREE_TYPE (ctree), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 735, __FUNCTION__))->typed.type), tmp)
);
736
737 /* Now set the data field. */
738 ctree = gfc_class_data_get (var);
739
740 if (optional)
741 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
742
743 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr))(((enum tree_code) (((contains_struct_check ((parmse->expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 743, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((parmse->expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 743, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
744 {
745 /* If there is a ready made pointer to a derived type, use it
746 rather than evaluating the expression again. */
747 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 747, __FUNCTION__))->typed.type), parmse->expr)
;
748 gfc_add_modify (&parmse->pre, ctree, tmp);
749 }
750 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
751 {
752 /* For an array reference in an elemental procedure call we need
753 to retain the ss to provide the scalarized array reference. */
754 gfc_conv_expr_reference (parmse, e);
755 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 755, __FUNCTION__))->typed.type), parmse->expr)
;
756 if (optional)
757 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 757, __FUNCTION__))->typed.type)
,
758 cond_optional, tmp,
759 fold_convert (TREE_TYPE (tmp), null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 759, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
760 gfc_add_modify (&parmse->pre, ctree, tmp);
761 }
762 else
763 {
764 ss = gfc_walk_expr (e);
765 if (ss == gfc_ss_terminator)
766 {
767 parmse->ss = NULL__null;
768 gfc_conv_expr_reference (parmse, e);
769
770 /* Scalar to an assumed-rank array. */
771 if (class_ts.u.derived->components->as)
772 {
773 tree type;
774 type = get_scalar_to_descriptor_type (parmse->expr,
775 gfc_expr_attr (e));
776 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
777 gfc_get_dtype (type));
778 if (optional)
779 parmse->expr = build3_loc (input_location, COND_EXPR,
780 TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 780, __FUNCTION__))->typed.type)
,
781 cond_optional, parmse->expr,
782 fold_convert (TREE_TYPE (parmse->expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 782, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
783 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 782, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
784 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
785 }
786 else
787 {
788 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 788, __FUNCTION__))->typed.type), parmse->expr)
;
789 if (optional)
790 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 790, __FUNCTION__))->typed.type)
,
791 cond_optional, tmp,
792 fold_convert (TREE_TYPE (tmp),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 792, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
793 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 792, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
794 gfc_add_modify (&parmse->pre, ctree, tmp);
795 }
796 }
797 else
798 {
799 stmtblock_t block;
800 gfc_init_block (&block);
801 gfc_ref *ref;
802
803 parmse->ss = ss;
804 parmse->use_offset = 1;
805 gfc_conv_expr_descriptor (parmse, e);
806
807 /* Detect any array references with vector subscripts. */
808 for (ref = e->ref; ref; ref = ref->next)
809 if (ref->type == REF_ARRAY
810 && ref->u.ar.type != AR_ELEMENT
811 && ref->u.ar.type != AR_FULL)
812 {
813 for (dim = 0; dim < ref->u.ar.dimen; dim++)
814 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
815 break;
816 if (dim < ref->u.ar.dimen)
817 break;
818 }
819
820 /* Array references with vector subscripts and non-variable expressions
821 need be converted to a one-based descriptor. */
822 if (ref || e->expr_type != EXPR_VARIABLE)
823 {
824 for (dim = 0; dim < e->rank; ++dim)
825 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
826 gfc_index_one_nodegfc_rank_cst[1]);
827 }
828
829 if (e->rank != class_ts.u.derived->components->as->rank)
830 {
831 gcc_assert (class_ts.u.derived->components->as->type((void)(!(class_ts.u.derived->components->as->type ==
AS_ASSUMED_RANK) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 832, __FUNCTION__), 0 : 0))
832 == AS_ASSUMED_RANK)((void)(!(class_ts.u.derived->components->as->type ==
AS_ASSUMED_RANK) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 832, __FUNCTION__), 0 : 0))
;
833 if (derived_array
834 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))((tree_class_check ((((contains_struct_check ((parmse->expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 834, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 834, __FUNCTION__))->type_common.lang_flag_1)
)
835 {
836 *derived_array = gfc_create_var (TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 836, __FUNCTION__))->typed.type)
,
837 "array");
838 gfc_add_modify (&block, *derived_array , parmse->expr);
839 }
840 class_array_data_assign (&block, ctree, parmse->expr, false);
841 }
842 else
843 {
844 if (gfc_expr_attr (e).codimension)
845 parmse->expr = fold_build1_loc (input_location,
846 VIEW_CONVERT_EXPR,
847 TREE_TYPE (ctree)((contains_struct_check ((ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 847, __FUNCTION__))->typed.type)
,
848 parmse->expr);
849 gfc_add_modify (&block, ctree, parmse->expr);
850 }
851
852 if (optional)
853 {
854 tmp = gfc_finish_block (&block);
855
856 gfc_init_block (&block);
857 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
858 if (derived_array && *derived_array != NULL_TREE(tree) __null)
859 gfc_conv_descriptor_data_set (&block, *derived_array,
860 null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
861
862 tmp = build3_v (COND_EXPR, cond_optional, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond_optional, tmp, gfc_finish_block (&block))
863 gfc_finish_block (&block))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond_optional, tmp, gfc_finish_block (&block))
;
864 gfc_add_expr_to_block (&parmse->pre, tmp);
865 }
866 else
867 gfc_add_block_to_block (&parmse->pre, &block);
868 }
869 }
870
871 if (class_ts.u.derived->components->ts.type == BT_DERIVED
872 && class_ts.u.derived->components->ts.u.derived
873 ->attr.unlimited_polymorphic)
874 {
875 /* Take care about initializing the _len component correctly. */
876 ctree = gfc_class_len_get (var);
877 if (UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
)
878 {
879 gfc_expr *len;
880 gfc_se se;
881
882 len = gfc_find_and_cut_at_last_class_ref (e);
883 gfc_add_len_component (len)gfc_add_component_ref(len,"_len");
884 gfc_init_se (&se, NULL__null);
885 gfc_conv_expr (&se, len);
886 if (optional)
887 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr)((contains_struct_check ((se.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 887, __FUNCTION__))->typed.type)
,
888 cond_optional, se.expr,
889 fold_convert (TREE_TYPE (se.expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(se.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 889, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ZERO
])
890 integer_zero_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(se.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 889, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ZERO
])
);
891 else
892 tmp = se.expr;
893 gfc_free_expr (len);
894 }
895 else
896 tmp = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
897 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 897, __FUNCTION__))->typed.type), tmp)
898 tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 897, __FUNCTION__))->typed.type), tmp)
);
899 }
900 /* Pass the address of the class object. */
901 parmse->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
902
903 if (optional && optional_alloc_ptr)
904 parmse->expr = build3_loc (input_location, COND_EXPR,
905 TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 905, __FUNCTION__))->typed.type)
,
906 cond_optional, parmse->expr,
907 fold_convert (TREE_TYPE (parmse->expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 907, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
908 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 907, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
909}
910
911
912/* Create a new class container, which is required as scalar coarrays
913 have an array descriptor while normal scalars haven't. Optionally,
914 NULL pointer checks are added if the argument is OPTIONAL. */
915
916static void
917class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
918 gfc_typespec class_ts, bool optional)
919{
920 tree var, ctree, tmp;
921 stmtblock_t block;
922 gfc_ref *ref;
923 gfc_ref *class_ref;
924
925 gfc_init_block (&block);
926
927 class_ref = NULL__null;
928 for (ref = e->ref; ref; ref = ref->next)
929 {
930 if (ref->type == REF_COMPONENT
931 && ref->u.c.component->ts.type == BT_CLASS)
932 class_ref = ref;
933 }
934
935 if (class_ref == NULL__null
936 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
937 tmp = e->symtree->n.sym->backend_decl;
938 else
939 {
940 /* Remove everything after the last class reference, convert the
941 expression and then recover its tailend once more. */
942 gfc_se tmpse;
943 ref = class_ref->next;
944 class_ref->next = NULL__null;
945 gfc_init_se (&tmpse, NULL__null);
946 gfc_conv_expr (&tmpse, e);
947 class_ref->next = ref;
948 tmp = tmpse.expr;
949 }
950
951 var = gfc_typenode_for_spec (&class_ts);
952 var = gfc_create_var (var, "class");
953
954 ctree = gfc_class_vptr_get (var);
955 gfc_add_modify (&block, ctree,
956 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 956, __FUNCTION__))->typed.type), gfc_class_vptr_get (tmp
))
);
957
958 ctree = gfc_class_data_get (var);
959 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
960 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 960, __FUNCTION__))->typed.type), tmp)
);
961
962 /* Pass the address of the class object. */
963 parmse->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
964
965 if (optional)
966 {
967 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
968 tree tmp2;
969
970 tmp = gfc_finish_block (&block);
971
972 gfc_init_block (&block);
973 tmp2 = gfc_class_data_get (var);
974 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 974, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
975 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 974, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
976 tmp2 = gfc_finish_block (&block);
977
978 tmp = build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
979 cond, tmp, tmp2);
980 gfc_add_expr_to_block (&parmse->pre, tmp);
981 }
982 else
983 gfc_add_block_to_block (&parmse->pre, &block);
984}
985
986
987/* Takes an intrinsic type expression and returns the address of a temporary
988 class object of the 'declared' type. */
989void
990gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
991 gfc_typespec class_ts)
992{
993 gfc_symbol *vtab;
994 gfc_ss *ss;
995 tree ctree;
996 tree var;
997 tree tmp;
998 int dim;
999
1000 /* The intrinsic type needs to be converted to a temporary
1001 CLASS object. */
1002 tmp = gfc_typenode_for_spec (&class_ts);
1003 var = gfc_create_var (tmp, "class");
1004
1005 /* Set the vptr. */
1006 ctree = gfc_class_vptr_get (var);
1007
1008 vtab = gfc_find_vtab (&e->ts);
1009 gcc_assert (vtab)((void)(!(vtab) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1009, __FUNCTION__), 0 : 0))
;
1010 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, gfc_get_symbol_decl (vtab));
1011 gfc_add_modify (&parmse->pre, ctree,
1012 fold_convert (TREE_TYPE (ctree), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1012, __FUNCTION__))->typed.type), tmp)
);
1013
1014 /* Now set the data field. */
1015 ctree = gfc_class_data_get (var);
1016 if (parmse->ss && parmse->ss->info->useflags)
1017 {
1018 /* For an array reference in an elemental procedure call we need
1019 to retain the ss to provide the scalarized array reference. */
1020 gfc_conv_expr_reference (parmse, e);
1021 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1021, __FUNCTION__))->typed.type), parmse->expr)
;
1022 gfc_add_modify (&parmse->pre, ctree, tmp);
1023 }
1024 else
1025 {
1026 ss = gfc_walk_expr (e);
1027 if (ss == gfc_ss_terminator)
1028 {
1029 parmse->ss = NULL__null;
1030 gfc_conv_expr_reference (parmse, e);
1031 if (class_ts.u.derived->components->as
1032 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1033 {
1034 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1035 gfc_expr_attr (e));
1036 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1037 TREE_TYPE (ctree)((contains_struct_check ((ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1037, __FUNCTION__))->typed.type)
, tmp);
1038 }
1039 else
1040 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1040, __FUNCTION__))->typed.type), parmse->expr)
;
1041 gfc_add_modify (&parmse->pre, ctree, tmp);
1042 }
1043 else
1044 {
1045 parmse->ss = ss;
1046 parmse->use_offset = 1;
1047 gfc_conv_expr_descriptor (parmse, e);
1048
1049 /* Array references with vector subscripts and non-variable expressions
1050 need be converted to a one-based descriptor. */
1051 if (e->expr_type != EXPR_VARIABLE)
1052 {
1053 for (dim = 0; dim < e->rank; ++dim)
1054 gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1055 dim, gfc_index_one_nodegfc_rank_cst[1]);
1056 }
1057
1058 if (class_ts.u.derived->components->as->rank != e->rank)
1059 {
1060 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1061 TREE_TYPE (ctree)((contains_struct_check ((ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1061, __FUNCTION__))->typed.type)
, parmse->expr);
1062 gfc_add_modify (&parmse->pre, ctree, tmp);
1063 }
1064 else
1065 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1066 }
1067 }
1068
1069 gcc_assert (class_ts.type == BT_CLASS)((void)(!(class_ts.type == BT_CLASS) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1069, __FUNCTION__), 0 : 0))
;
1070 if (class_ts.u.derived->components->ts.type == BT_DERIVED
1071 && class_ts.u.derived->components->ts.u.derived
1072 ->attr.unlimited_polymorphic)
1073 {
1074 ctree = gfc_class_len_get (var);
1075 /* When the actual arg is a char array, then set the _len component of the
1076 unlimited polymorphic entity to the length of the string. */
1077 if (e->ts.type == BT_CHARACTER)
1078 {
1079 /* Start with parmse->string_length because this seems to be set to a
1080 correct value more often. */
1081 if (parmse->string_length)
1082 tmp = parmse->string_length;
1083 /* When the string_length is not yet set, then try the backend_decl of
1084 the cl. */
1085 else if (e->ts.u.cl->backend_decl)
1086 tmp = e->ts.u.cl->backend_decl;
1087 /* If both of the above approaches fail, then try to generate an
1088 expression from the input, which is only feasible currently, when the
1089 expression can be evaluated to a constant one. */
1090 else
1091 {
1092 /* Try to simplify the expression. */
1093 gfc_simplify_expr (e, 0);
1094 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1095 {
1096 /* Amazingly all data is present to compute the length of a
1097 constant string, but the expression is not yet there. */
1098 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1099 gfc_charlen_int_kind,
1100 &e->where);
1101 mpz_set_ui__gmpz_set_ui (e->ts.u.cl->length->value.integer,
1102 e->value.character.length);
1103 gfc_conv_const_charlen (e->ts.u.cl);
1104 e->ts.u.cl->resolved = 1;
1105 tmp = e->ts.u.cl->backend_decl;
1106 }
1107 else
1108 {
1109 gfc_error ("Cannot compute the length of the char array "
1110 "at %L.", &e->where);
1111 }
1112 }
1113 }
1114 else
1115 tmp = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
1116
1117 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1117, __FUNCTION__))->typed.type), tmp)
);
1118 }
1119 else if (class_ts.type == BT_CLASS
1120 && class_ts.u.derived->components
1121 && class_ts.u.derived->components->ts.u
1122 .derived->attr.unlimited_polymorphic)
1123 {
1124 ctree = gfc_class_len_get (var);
1125 gfc_add_modify (&parmse->pre, ctree,
1126 fold_convert (TREE_TYPE (ctree),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1126, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ZERO
])
1127 integer_zero_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1126, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ZERO
])
);
1128 }
1129 /* Pass the address of the class object. */
1130 parmse->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
1131}
1132
1133
1134/* Takes a scalarized class array expression and returns the
1135 address of a temporary scalar class object of the 'declared'
1136 type.
1137 OOP-TODO: This could be improved by adding code that branched on
1138 the dynamic type being the same as the declared type. In this case
1139 the original class expression can be passed directly.
1140 optional_alloc_ptr is false when the dummy is neither allocatable
1141 nor a pointer; that's relevant for the optional handling.
1142 Set copyback to true if class container's _data and _vtab pointers
1143 might get modified. */
1144
1145void
1146gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1147 bool elemental, bool copyback, bool optional,
1148 bool optional_alloc_ptr)
1149{
1150 tree ctree;
1151 tree var;
1152 tree tmp;
1153 tree vptr;
1154 tree cond = NULL_TREE(tree) __null;
1155 tree slen = NULL_TREE(tree) __null;
1156 gfc_ref *ref;
1157 gfc_ref *class_ref;
1158 stmtblock_t block;
1159 bool full_array = false;
1160
1161 gfc_init_block (&block);
1162
1163 class_ref = NULL__null;
1164 for (ref = e->ref; ref; ref = ref->next)
1165 {
1166 if (ref->type == REF_COMPONENT
1167 && ref->u.c.component->ts.type == BT_CLASS)
1168 class_ref = ref;
1169
1170 if (ref->next == NULL__null)
1171 break;
1172 }
1173
1174 if ((ref == NULL__null || class_ref == ref)
1175 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE(tree) __null)
1176 && (!class_ts.u.derived->components->as
1177 || class_ts.u.derived->components->as->rank != -1))
1178 return;
1179
1180 /* Test for FULL_ARRAY. */
1181 if (e->rank == 0
1182 && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1183 || (class_ts.u.derived->components->as
1184 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1185 full_array = true;
1186 else
1187 gfc_is_class_array_ref (e, &full_array);
1188
1189 /* The derived type needs to be converted to a temporary
1190 CLASS object. */
1191 tmp = gfc_typenode_for_spec (&class_ts);
1192 var = gfc_create_var (tmp, "class");
1193
1194 /* Set the data. */
1195 ctree = gfc_class_data_get (var);
1196 if (class_ts.u.derived->components->as
1197 && e->rank != class_ts.u.derived->components->as->rank)
1198 {
1199 if (e->rank == 0)
1200 {
1201 tree type = get_scalar_to_descriptor_type (parmse->expr,
1202 gfc_expr_attr (e));
1203 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1204 gfc_get_dtype (type));
1205
1206 tmp = gfc_class_data_get (parmse->expr);
1207 if (!POINTER_TYPE_P (TREE_TYPE (tmp))(((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1207, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1207, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
1208 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
1209
1210 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1211 }
1212 else
1213 class_array_data_assign (&block, ctree, parmse->expr, false);
1214 }
1215 else
1216 {
1217 if (TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1217, __FUNCTION__))->typed.type)
!= TREE_TYPE (ctree)((contains_struct_check ((ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1217, __FUNCTION__))->typed.type)
)
1218 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1219 TREE_TYPE (ctree)((contains_struct_check ((ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1219, __FUNCTION__))->typed.type)
, parmse->expr);
1220 gfc_add_modify (&block, ctree, parmse->expr);
1221 }
1222
1223 /* Return the data component, except in the case of scalarized array
1224 references, where nullification of the cannot occur and so there
1225 is no need. */
1226 if (!elemental && full_array && copyback)
1227 {
1228 if (class_ts.u.derived->components->as
1229 && e->rank != class_ts.u.derived->components->as->rank)
1230 {
1231 if (e->rank == 0)
1232 {
1233 tmp = gfc_class_data_get (parmse->expr);
1234 gfc_add_modify (&parmse->post, tmp,
1235 fold_convert (TREE_TYPE (tmp),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1235, __FUNCTION__))->typed.type), gfc_conv_descriptor_data_get
(ctree))
1236 gfc_conv_descriptor_data_get (ctree))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1235, __FUNCTION__))->typed.type), gfc_conv_descriptor_data_get
(ctree))
);
1237 }
1238 else
1239 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1240 }
1241 else
1242 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1243 }
1244
1245 /* Set the vptr. */
1246 ctree = gfc_class_vptr_get (var);
1247
1248 /* The vptr is the second field of the actual argument.
1249 First we have to find the corresponding class reference. */
1250
1251 tmp = NULL_TREE(tree) __null;
1252 if (gfc_is_class_array_function (e)
1253 && parmse->class_vptr != NULL_TREE(tree) __null)
1254 tmp = parmse->class_vptr;
1255 else if (class_ref == NULL__null
1256 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1257 {
1258 tmp = e->symtree->n.sym->backend_decl;
1259
1260 if (TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == FUNCTION_DECL)
1261 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1262
1263 if (DECL_LANG_SPECIFIC (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1263, __FUNCTION__))->decl_common.lang_specific)
&& GFC_DECL_SAVED_DESCRIPTOR (tmp)(((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1263, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
)
1264 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp)(((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1264, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
1265
1266 slen = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1267 }
1268 else
1269 {
1270 /* Remove everything after the last class reference, convert the
1271 expression and then recover its tailend once more. */
1272 gfc_se tmpse;
1273 ref = class_ref->next;
1274 class_ref->next = NULL__null;
1275 gfc_init_se (&tmpse, NULL__null);
1276 gfc_conv_expr (&tmpse, e);
1277 class_ref->next = ref;
1278 tmp = tmpse.expr;
1279 slen = tmpse.string_length;
1280 }
1281
1282 gcc_assert (tmp != NULL_TREE)((void)(!(tmp != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1282, __FUNCTION__), 0 : 0))
;
1283
1284 /* Dereference if needs be. */
1285 if (TREE_CODE (TREE_TYPE (tmp))((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1285, __FUNCTION__))->typed.type))->base.code)
== REFERENCE_TYPE)
1286 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1287
1288 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1289 vptr = gfc_class_vptr_get (tmp);
1290 else
1291 vptr = tmp;
1292
1293 gfc_add_modify (&block, ctree,
1294 fold_convert (TREE_TYPE (ctree), vptr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1294, __FUNCTION__))->typed.type), vptr)
);
1295
1296 /* Return the vptr component, except in the case of scalarized array
1297 references, where the dynamic type cannot change. */
1298 if (!elemental && full_array && copyback)
1299 gfc_add_modify (&parmse->post, vptr,
1300 fold_convert (TREE_TYPE (vptr), ctree)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(vptr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1300, __FUNCTION__))->typed.type), ctree)
);
1301
1302 /* For unlimited polymorphic objects also set the _len component. */
1303 if (class_ts.type == BT_CLASS
1304 && class_ts.u.derived->components
1305 && class_ts.u.derived->components->ts.u
1306 .derived->attr.unlimited_polymorphic)
1307 {
1308 ctree = gfc_class_len_get (var);
1309 if (UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
)
1310 tmp = gfc_class_len_get (tmp);
1311 else if (e->ts.type == BT_CHARACTER)
1312 {
1313 gcc_assert (slen != NULL_TREE)((void)(!(slen != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1313, __FUNCTION__), 0 : 0))
;
1314 tmp = slen;
1315 }
1316 else
1317 tmp = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1318 gfc_add_modify (&parmse->pre, ctree,
1319 fold_convert (TREE_TYPE (ctree), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(ctree), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1319, __FUNCTION__))->typed.type), tmp)
);
1320
1321 /* Return the len component, except in the case of scalarized array
1322 references, where the dynamic type cannot change. */
1323 if (!elemental && full_array && copyback
1324 && (UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
|| VAR_P (tmp)(((enum tree_code) (tmp)->base.code) == VAR_DECL)))
1325 gfc_add_modify (&parmse->post, tmp,
1326 fold_convert (TREE_TYPE (tmp), ctree)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1326, __FUNCTION__))->typed.type), ctree)
);
1327 }
1328
1329 if (optional)
1330 {
1331 tree tmp2;
1332
1333 cond = gfc_conv_expr_present (e->symtree->n.sym);
1334 /* parmse->pre may contain some preparatory instructions for the
1335 temporary array descriptor. Those may only be executed when the
1336 optional argument is set, therefore add parmse->pre's instructions
1337 to block, which is later guarded by an if (optional_arg_given). */
1338 gfc_add_block_to_block (&parmse->pre, &block);
1339 block.head = parmse->pre.head;
1340 parmse->pre.head = NULL_TREE(tree) __null;
1341 tmp = gfc_finish_block (&block);
1342
1343 if (optional_alloc_ptr)
1344 tmp2 = build_empty_stmt (input_location);
1345 else
1346 {
1347 gfc_init_block (&block);
1348
1349 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1350 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1350, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
1351 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1350, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
1352 tmp2 = gfc_finish_block (&block);
1353 }
1354
1355 tmp = build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1356 cond, tmp, tmp2);
1357 gfc_add_expr_to_block (&parmse->pre, tmp);
1358 }
1359 else
1360 gfc_add_block_to_block (&parmse->pre, &block);
1361
1362 /* Pass the address of the class object. */
1363 parmse->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
1364
1365 if (optional && optional_alloc_ptr)
1366 parmse->expr = build3_loc (input_location, COND_EXPR,
1367 TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1367, __FUNCTION__))->typed.type)
,
1368 cond, parmse->expr,
1369 fold_convert (TREE_TYPE (parmse->expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1369, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
1370 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1369, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
1371}
1372
1373
1374/* Given a class array declaration and an index, returns the address
1375 of the referenced element. */
1376
1377static tree
1378gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1379 bool unlimited)
1380{
1381 tree data, size, tmp, ctmp, offset, ptr;
1382
1383 data = data_comp != NULL_TREE(tree) __null ? data_comp :
1384 gfc_class_data_get (class_decl);
1385 size = gfc_class_vtab_size_get (class_decl);
1386
1387 if (unlimited)
1388 {
1389 tmp = fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_class_len_get
(class_decl))
1390 gfc_class_len_get (class_decl))fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_class_len_get
(class_decl))
;
1391 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1392 gfc_array_index_type, size, tmp);
1393 tmp = fold_build2_loc (input_location, GT_EXPR,
1394 logical_type_node, tmp,
1395 build_zero_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1395, __FUNCTION__))->typed.type)
));
1396 size = fold_build3_loc (input_location, COND_EXPR,
1397 gfc_array_index_type, tmp, ctmp, size);
1398 }
1399
1400 offset = fold_build2_loc (input_location, MULT_EXPR,
1401 gfc_array_index_type,
1402 index, size);
1403
1404 data = gfc_conv_descriptor_data_get (data);
1405 ptr = fold_convert (pvoid_type_node, data)fold_convert_loc (((location_t) 0), pvoid_type_node, data);
1406 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1407 return fold_convert (TREE_TYPE (data), ptr)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(data), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1407, __FUNCTION__))->typed.type), ptr)
;
1408}
1409
1410
1411/* Copies one class expression to another, assuming that if either
1412 'to' or 'from' are arrays they are packed. Should 'from' be
1413 NULL_TREE, the initialization expression for 'to' is used, assuming
1414 that the _vptr is set. */
1415
1416tree
1417gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1418{
1419 tree fcn;
1420 tree fcn_type;
1421 tree from_data;
1422 tree from_len;
1423 tree to_data;
1424 tree to_len;
1425 tree to_ref;
1426 tree from_ref;
1427 vec<tree, va_gc> *args;
1428 tree tmp;
1429 tree stdcopy;
1430 tree extcopy;
1431 tree index;
1432 bool is_from_desc = false, is_to_class = false;
1433
1434 args = NULL__null;
1435 /* To prevent warnings on uninitialized variables. */
1436 from_len = to_len = NULL_TREE(tree) __null;
1437
1438 if (from != NULL_TREE(tree) __null)
1439 fcn = gfc_class_vtab_copy_get (from);
1440 else
1441 fcn = gfc_class_vtab_copy_get (to);
1442
1443 fcn_type = TREE_TYPE (TREE_TYPE (fcn))((contains_struct_check ((((contains_struct_check ((fcn), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1443, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1443, __FUNCTION__))->typed.type)
;
1444
1445 if (from != NULL_TREE(tree) __null)
1446 {
1447 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from))((tree_class_check ((((contains_struct_check ((from), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1447, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1447, __FUNCTION__))->type_common.lang_flag_1)
;
1448 if (is_from_desc)
1449 {
1450 from_data = from;
1451 from = GFC_DECL_SAVED_DESCRIPTOR (from)(((contains_struct_check ((from), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1451, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
1452 }
1453 else
1454 {
1455 /* Check that from is a class. When the class is part of a coarray,
1456 then from is a common pointer and is to be used as is. */
1457 tmp = POINTER_TYPE_P (TREE_TYPE (from))(((enum tree_code) (((contains_struct_check ((from), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1457, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((from), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1457, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
1458 ? build_fold_indirect_ref (from)build_fold_indirect_ref_loc (((location_t) 0), from) : from;
1459 from_data =
1460 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))((tree_class_check ((((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1460, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1460, __FUNCTION__))->type_common.lang_flag_4)
1461 || (DECL_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_declaration)
&& GFC_DECL_CLASS (tmp)((contains_struct_check ((tmp), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1461, __FUNCTION__))->decl_common.lang_flag_8)
))
1462 ? gfc_class_data_get (from) : from;
1463 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))((tree_class_check ((((contains_struct_check ((from_data), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1463, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1463, __FUNCTION__))->type_common.lang_flag_1)
;
1464 }
1465 }
1466 else
1467 from_data = gfc_class_vtab_def_init_get (to);
1468
1469 if (unlimited)
1470 {
1471 if (from != NULL_TREE(tree) __null && unlimited)
1472 from_len = gfc_class_len_or_zero_get (from);
1473 else
1474 from_len = build_zero_cst (size_type_nodeglobal_trees[TI_SIZE_TYPE]);
1475 }
1476
1477 if (GFC_CLASS_TYPE_P (TREE_TYPE (to))((tree_class_check ((((contains_struct_check ((to), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1477, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1477, __FUNCTION__))->type_common.lang_flag_4)
)
1478 {
1479 is_to_class = true;
1480 to_data = gfc_class_data_get (to);
1481 if (unlimited)
1482 to_len = gfc_class_len_get (to);
1483 }
1484 else
1485 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1486 to_data = to;
1487
1488 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))((tree_class_check ((((contains_struct_check ((to_data), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1488, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1488, __FUNCTION__))->type_common.lang_flag_1)
)
1489 {
1490 stmtblock_t loopbody;
1491 stmtblock_t body;
1492 stmtblock_t ifbody;
1493 gfc_loopinfo loop;
1494 tree orig_nelems = nelems; /* Needed for bounds check. */
1495
1496 gfc_init_block (&body);
1497 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1498 gfc_array_index_type, nelems,
1499 gfc_index_one_nodegfc_rank_cst[1]);
1500 nelems = gfc_evaluate_now (tmp, &body);
1501 index = gfc_create_var (gfc_array_index_type, "S");
1502
1503 if (is_from_desc)
1504 {
1505 from_ref = gfc_get_class_array_ref (index, from, from_data,
1506 unlimited);
1507 vec_safe_push (args, from_ref);
1508 }
1509 else
1510 vec_safe_push (args, from_data);
1511
1512 if (is_to_class)
1513 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1514 else
1515 {
1516 tmp = gfc_conv_array_data (to);
1517 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1518 to_ref = gfc_build_addr_expr (NULL_TREE(tree) __null,
1519 gfc_build_array_ref (tmp, index, to));
1520 }
1521 vec_safe_push (args, to_ref);
1522
1523 /* Add bounds check. */
1524 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0)) > 0 && is_from_desc)
1525 {
1526 char *msg;
1527 const char *name = "<<unknown>>";
1528 tree from_len;
1529
1530 if (DECL_P (to)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (to)->base.code))] == tcc_declaration)
)
1531 name = (const char *)(DECL_NAME (to)((contains_struct_check ((to), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1531, __FUNCTION__))->decl_minimal.name)
->identifier.id.str);
1532
1533 from_len = gfc_conv_descriptor_size (from_data, 1);
1534 from_len = fold_convert (TREE_TYPE (orig_nelems), from_len)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(orig_nelems), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1534, __FUNCTION__))->typed.type), from_len)
;
1535 tmp = fold_build2_loc (input_location, NE_EXPR,
1536 logical_type_node, from_len, orig_nelems);
1537 msg = xasprintf ("Array bound mismatch for dimension %d "
1538 "of array '%s' (%%ld/%%ld)",
1539 1, name);
1540
1541 gfc_trans_runtime_check (true, false, tmp, &body,
1542 &gfc_current_locus, msg,
1543 fold_convert (long_integer_type_node, orig_nelems)fold_convert_loc (((location_t) 0), integer_types[itk_long], orig_nelems
)
,
1544 fold_convert (long_integer_type_node, from_len)fold_convert_loc (((location_t) 0), integer_types[itk_long], from_len
)
);
1545
1546 free (msg);
1547 }
1548
1549 tmp = build_call_vec (fcn_type, fcn, args);
1550
1551 /* Build the body of the loop. */
1552 gfc_init_block (&loopbody);
1553 gfc_add_expr_to_block (&loopbody, tmp);
1554
1555 /* Build the loop and return. */
1556 gfc_init_loopinfo (&loop);
1557 loop.dimen = 1;
1558 loop.from[0] = gfc_index_zero_nodegfc_rank_cst[0];
1559 loop.loopvar[0] = index;
1560 loop.to[0] = nelems;
1561 gfc_trans_scalarizing_loops (&loop, &loopbody);
1562 gfc_init_block (&ifbody);
1563 gfc_add_block_to_block (&ifbody, &loop.pre);
1564 stdcopy = gfc_finish_block (&ifbody);
1565 /* In initialization mode from_len is a constant zero. */
1566 if (unlimited && !integer_zerop (from_len))
1567 {
1568 vec_safe_push (args, from_len);
1569 vec_safe_push (args, to_len);
1570 tmp = build_call_vec (fcn_type, fcn, args);
1571 /* Build the body of the loop. */
1572 gfc_init_block (&loopbody);
1573 gfc_add_expr_to_block (&loopbody, tmp);
1574
1575 /* Build the loop and return. */
1576 gfc_init_loopinfo (&loop);
1577 loop.dimen = 1;
1578 loop.from[0] = gfc_index_zero_nodegfc_rank_cst[0];
1579 loop.loopvar[0] = index;
1580 loop.to[0] = nelems;
1581 gfc_trans_scalarizing_loops (&loop, &loopbody);
1582 gfc_init_block (&ifbody);
1583 gfc_add_block_to_block (&ifbody, &loop.pre);
1584 extcopy = gfc_finish_block (&ifbody);
1585
1586 tmp = fold_build2_loc (input_location, GT_EXPR,
1587 logical_type_node, from_len,
1588 build_zero_cst (TREE_TYPE (from_len)((contains_struct_check ((from_len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1588, __FUNCTION__))->typed.type)
));
1589 tmp = fold_build3_loc (input_location, COND_EXPR,
1590 void_type_nodeglobal_trees[TI_VOID_TYPE], tmp, extcopy, stdcopy);
1591 gfc_add_expr_to_block (&body, tmp);
1592 tmp = gfc_finish_block (&body);
1593 }
1594 else
1595 {
1596 gfc_add_expr_to_block (&body, stdcopy);
1597 tmp = gfc_finish_block (&body);
1598 }
1599 gfc_cleanup_loop (&loop);
1600 }
1601 else
1602 {
1603 gcc_assert (!is_from_desc)((void)(!(!is_from_desc) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1603, __FUNCTION__), 0 : 0))
;
1604 vec_safe_push (args, from_data);
1605 vec_safe_push (args, to_data);
1606 stdcopy = build_call_vec (fcn_type, fcn, args);
1607
1608 /* In initialization mode from_len is a constant zero. */
1609 if (unlimited && !integer_zerop (from_len))
1610 {
1611 vec_safe_push (args, from_len);
1612 vec_safe_push (args, to_len);
1613 extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1614 tmp = fold_build2_loc (input_location, GT_EXPR,
1615 logical_type_node, from_len,
1616 build_zero_cst (TREE_TYPE (from_len)((contains_struct_check ((from_len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1616, __FUNCTION__))->typed.type)
));
1617 tmp = fold_build3_loc (input_location, COND_EXPR,
1618 void_type_nodeglobal_trees[TI_VOID_TYPE], tmp, extcopy, stdcopy);
1619 }
1620 else
1621 tmp = stdcopy;
1622 }
1623
1624 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1625 if (from == NULL_TREE(tree) __null)
1626 {
1627 tree cond;
1628 cond = fold_build2_loc (input_location, NE_EXPR,
1629 logical_type_node,
1630 from_data, null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
1631 tmp = fold_build3_loc (input_location, COND_EXPR,
1632 void_type_nodeglobal_trees[TI_VOID_TYPE], cond,
1633 tmp, build_empty_stmt (input_location));
1634 }
1635
1636 return tmp;
1637}
1638
1639
1640static tree
1641gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1642{
1643 gfc_actual_arglist *actual;
1644 gfc_expr *ppc;
1645 gfc_code *ppc_code;
1646 tree res;
1647
1648 actual = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
1649 actual->expr = gfc_copy_expr (rhs);
1650 actual->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)))
;
1651 actual->next->expr = gfc_copy_expr (lhs);
1652 ppc = gfc_copy_expr (obj);
1653 gfc_add_vptr_component (ppc)gfc_add_component_ref(ppc,"_vptr");
1654 gfc_add_component_ref (ppc, "_copy");
1655 ppc_code = gfc_get_code (EXEC_CALL);
1656 ppc_code->resolved_sym = ppc->symtree->n.sym;
1657 /* Although '_copy' is set to be elemental in class.cc, it is
1658 not staying that way. Find out why, sometime.... */
1659 ppc_code->resolved_sym->attr.elemental = 1;
1660 ppc_code->ext.actual = actual;
1661 ppc_code->expr1 = ppc;
1662 /* Since '_copy' is elemental, the scalarizer will take care
1663 of arrays in gfc_trans_call. */
1664 res = gfc_trans_call (ppc_code, false, NULL__null, NULL__null, false);
1665 gfc_free_statements (ppc_code);
1666
1667 if (UNLIMITED_POLY(obj)(obj != __null && obj->ts.type == BT_CLASS &&
obj->ts.u.derived->components && obj->ts.u.
derived->components->ts.u.derived && obj->ts
.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
)
)
1668 {
1669 /* Check if rhs is non-NULL. */
1670 gfc_se src;
1671 gfc_init_se (&src, NULL__null);
1672 gfc_conv_expr (&src, rhs);
1673 src.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, src.expr);
1674 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1675 src.expr, fold_convert (TREE_TYPE (src.expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(src.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1675, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
1676 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(src.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1675, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
1677 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res)((contains_struct_check ((res), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1677, __FUNCTION__))->typed.type)
, cond, res,
1678 build_empty_stmt (input_location));
1679 }
1680
1681 return res;
1682}
1683
1684/* Special case for initializing a polymorphic dummy with INTENT(OUT).
1685 A MEMCPY is needed to copy the full data from the default initializer
1686 of the dynamic type. */
1687
1688tree
1689gfc_trans_class_init_assign (gfc_code *code)
1690{
1691 stmtblock_t block;
1692 tree tmp;
1693 gfc_se dst,src,memsz;
1694 gfc_expr *lhs, *rhs, *sz;
1695
1696 gfc_start_block (&block);
1697
1698 lhs = gfc_copy_expr (code->expr1);
1699
1700 rhs = gfc_copy_expr (code->expr1);
1701 gfc_add_vptr_component (rhs)gfc_add_component_ref(rhs,"_vptr");
1702
1703 /* Make sure that the component backend_decls have been built, which
1704 will not have happened if the derived types concerned have not
1705 been referenced. */
1706 gfc_get_derived_type (rhs->ts.u.derived);
1707 gfc_add_def_init_component (rhs)gfc_add_component_ref(rhs,"_def_init");
1708 /* The _def_init is always scalar. */
1709 rhs->rank = 0;
1710
1711 if (code->expr1->ts.type == BT_CLASS
1712 && CLASS_DATA (code->expr1)code->expr1->ts.u.derived->components->attr.dimension)
1713 {
1714 gfc_array_spec *tmparr = gfc_get_array_spec ()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
1715 *tmparr = *CLASS_DATA (code->expr1)code->expr1->ts.u.derived->components->as;
1716 /* Adding the array ref to the class expression results in correct
1717 indexing to the dynamic type. */
1718 gfc_add_full_array_ref (lhs, tmparr);
1719 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1720 }
1721 else
1722 {
1723 /* Scalar initialization needs the _data component. */
1724 gfc_add_data_component (lhs)gfc_add_component_ref(lhs,"_data");
1725 sz = gfc_copy_expr (code->expr1);
1726 gfc_add_vptr_component (sz)gfc_add_component_ref(sz,"_vptr");
1727 gfc_add_size_component (sz)gfc_add_component_ref(sz,"_size");
1728
1729 gfc_init_se (&dst, NULL__null);
1730 gfc_init_se (&src, NULL__null);
1731 gfc_init_se (&memsz, NULL__null);
1732 gfc_conv_expr (&dst, lhs);
1733 gfc_conv_expr (&src, rhs);
1734 gfc_conv_expr (&memsz, sz);
1735 gfc_add_block_to_block (&block, &src.pre);
1736 src.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, src.expr);
1737
1738 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1739
1740 if (UNLIMITED_POLY(code->expr1)(code->expr1 != __null && code->expr1->ts.type
== BT_CLASS && code->expr1->ts.u.derived->components
&& code->expr1->ts.u.derived->components->
ts.u.derived && code->expr1->ts.u.derived->components
->ts.u.derived->attr.unlimited_polymorphic)
)
1741 {
1742 /* Check if _def_init is non-NULL. */
1743 tree cond = fold_build2_loc (input_location, NE_EXPR,
1744 logical_type_node, src.expr,
1745 fold_convert (TREE_TYPE (src.expr),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(src.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1745, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
1746 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(src.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1745, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
1747 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1747, __FUNCTION__))->typed.type)
, cond,
1748 tmp, build_empty_stmt (input_location));
1749 }
1750 }
1751
1752 if (code->expr1->symtree->n.sym->attr.dummy
1753 && (code->expr1->symtree->n.sym->attr.optional
1754 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1755 {
1756 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1757 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1757, __FUNCTION__))->typed.type)
,
1758 present, tmp,
1759 build_empty_stmt (input_location));
1760 }
1761
1762 gfc_add_expr_to_block (&block, tmp);
1763
1764 return gfc_finish_block (&block);
1765}
1766
1767
1768/* Class valued elemental function calls or class array elements arriving
1769 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1770 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1771
1772static bool
1773trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1774{
1775 tree fcn;
1776 tree rse_expr;
1777 tree class_data;
1778 tree tmp;
1779 tree zero;
1780 tree cond;
1781 tree final_cond;
1782 stmtblock_t inner_block;
1783 bool is_descriptor;
1784 bool not_call_expr = TREE_CODE (rse->expr)((enum tree_code) (rse->expr)->base.code) != CALL_EXPR;
1785 bool not_lhs_array_type;
1786
1787 /* Temporaries arising from dependencies in assignment get cast as a
1788 character type of the dynamic size of the rhs. Use the vptr copy
1789 for this case. */
1790 tmp = TREE_TYPE (lse->expr)((contains_struct_check ((lse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1790, __FUNCTION__))->typed.type)
;
1791 not_lhs_array_type = !(tmp && TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == ARRAY_TYPE
1792 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))((tree_check5 ((((tree_check ((tmp), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1792, __FUNCTION__, (ARRAY_TYPE)))->type_non_common.values
)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1792, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
!= NULL_TREE(tree) __null);
1793
1794 /* Use ordinary assignment if the rhs is not a call expression or
1795 the lhs is not a class entity or an array(ie. character) type. */
1796 if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE(tree) __null)
1797 && not_lhs_array_type)
1798 return false;
1799
1800 /* Ordinary assignment can be used if both sides are class expressions
1801 since the dynamic type is preserved by copying the vptr. This
1802 should only occur, where temporaries are involved. */
1803 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))((tree_class_check ((((contains_struct_check ((lse->expr),
(TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1803, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1803, __FUNCTION__))->type_common.lang_flag_4)
1804 && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))((tree_class_check ((((contains_struct_check ((rse->expr),
(TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1804, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1804, __FUNCTION__))->type_common.lang_flag_4)
)
1805 return false;
1806
1807 /* Fix the class expression and the class data of the rhs. */
1808 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))((tree_class_check ((((contains_struct_check ((rse->expr),
(TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1808, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1808, __FUNCTION__))->type_common.lang_flag_4)
1809 || not_call_expr)
1810 {
1811 tmp = gfc_get_class_from_expr (rse->expr);
1812 if (tmp == NULL_TREE(tree) __null)
1813 return false;
1814 rse_expr = gfc_evaluate_now (tmp, block);
1815 }
1816 else
1817 rse_expr = gfc_evaluate_now (rse->expr, block);
1818
1819 class_data = gfc_class_data_get (rse_expr);
1820
1821 /* Check that the rhs data is not null. */
1822 is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data))((tree_class_check ((((contains_struct_check ((class_data), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1822, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1822, __FUNCTION__))->type_common.lang_flag_1)
;
1823 if (is_descriptor)
1824 class_data = gfc_conv_descriptor_data_get (class_data);
1825 class_data = gfc_evaluate_now (class_data, block);
1826
1827 zero = build_int_cst (TREE_TYPE (class_data)((contains_struct_check ((class_data), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1827, __FUNCTION__))->typed.type)
, 0);
1828 cond = fold_build2_loc (input_location, NE_EXPR,
1829 logical_type_node,
1830 class_data, zero);
1831
1832 /* Copy the rhs to the lhs. */
1833 fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1834 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1835 tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL__null, rse->expr), block);
1836 tmp = is_descriptor ? tmp : class_data;
1837 tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1838 gfc_build_addr_expr (NULL__null, lse->expr));
1839 gfc_add_expr_to_block (block, tmp);
1840
1841 /* Only elemental function results need to be finalised and freed. */
1842 if (not_call_expr)
1843 return true;
1844
1845 /* Finalize the class data if needed. */
1846 gfc_init_block (&inner_block);
1847 fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
1848 zero = build_int_cst (TREE_TYPE (fcn)((contains_struct_check ((fcn), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1848, __FUNCTION__))->typed.type)
, 0);
1849 final_cond = fold_build2_loc (input_location, NE_EXPR,
1850 logical_type_node, fcn, zero);
1851 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1852 tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1853 tmp = build3_v (COND_EXPR, final_cond,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], final_cond, tmp, build_empty_stmt (input_location))
1854 tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], final_cond, tmp, build_empty_stmt (input_location))
;
1855 gfc_add_expr_to_block (&inner_block, tmp);
1856
1857 /* Free the class data. */
1858 tmp = gfc_call_free (class_data);
1859 tmp = build3_v (COND_EXPR, cond, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
1860 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
1861 gfc_add_expr_to_block (&inner_block, tmp);
1862
1863 /* Finish the inner block and subject it to the condition on the
1864 class data being non-zero. */
1865 tmp = gfc_finish_block (&inner_block);
1866 tmp = build3_v (COND_EXPR, cond, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
1867 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
1868 gfc_add_expr_to_block (block, tmp);
1869
1870 return true;
1871}
1872
1873/* End of prototype trans-class.c */
1874
1875
1876static void
1877realloc_lhs_warning (bt type, bool array, locus *where)
1878{
1879 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhsglobal_options.x_warn_realloc_lhs)
1880 gfc_warning (OPT_Wrealloc_lhs,
1881 "Code for reallocating the allocatable array at %L will "
1882 "be added", where);
1883 else if (warn_realloc_lhs_allglobal_options.x_warn_realloc_lhs_all)
1884 gfc_warning (OPT_Wrealloc_lhs_all,
1885 "Code for reallocating the allocatable variable at %L "
1886 "will be added", where);
1887}
1888
1889
1890static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1891 gfc_expr *);
1892
1893/* Copy the scalarization loop variables. */
1894
1895static void
1896gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1897{
1898 dest->ss = src->ss;
1899 dest->loop = src->loop;
1900}
1901
1902
1903/* Initialize a simple expression holder.
1904
1905 Care must be taken when multiple se are created with the same parent.
1906 The child se must be kept in sync. The easiest way is to delay creation
1907 of a child se until after the previous se has been translated. */
1908
1909void
1910gfc_init_se (gfc_se * se, gfc_se * parent)
1911{
1912 memset (se, 0, sizeof (gfc_se));
1913 gfc_init_block (&se->pre);
1914 gfc_init_block (&se->finalblock);
1915 gfc_init_block (&se->post);
1916
1917 se->parent = parent;
1918
1919 if (parent
12.1
'parent' is null
)
13
Taking false branch
1920 gfc_copy_se_loopvars (se, parent);
1921}
1922
1923
1924/* Advances to the next SS in the chain. Use this rather than setting
1925 se->ss = se->ss->next because all the parents needs to be kept in sync.
1926 See gfc_init_se. */
1927
1928void
1929gfc_advance_se_ss_chain (gfc_se * se)
1930{
1931 gfc_se *p;
1932 gfc_ss *ss;
1933
1934 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator)((void)(!(se != __null && se->ss != __null &&
se->ss != gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1934, __FUNCTION__), 0 : 0))
;
1935
1936 p = se;
1937 /* Walk down the parent chain. */
1938 while (p != NULL__null)
1939 {
1940 /* Simple consistency check. */
1941 gcc_assert (p->parent == NULL || p->parent->ss == p->ss((void)(!(p->parent == __null || p->parent->ss == p->
ss || p->parent->ss->nested_ss == p->ss) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1942, __FUNCTION__), 0 : 0))
1942 || p->parent->ss->nested_ss == p->ss)((void)(!(p->parent == __null || p->parent->ss == p->
ss || p->parent->ss->nested_ss == p->ss) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1942, __FUNCTION__), 0 : 0))
;
1943
1944 /* If we were in a nested loop, the next scalarized expression can be
1945 on the parent ss' next pointer. Thus we should not take the next
1946 pointer blindly, but rather go up one nest level as long as next
1947 is the end of chain. */
1948 ss = p->ss;
1949 while (ss->next == gfc_ss_terminator && ss->parent != NULL__null)
1950 ss = ss->parent;
1951
1952 p->ss = ss->next;
1953
1954 p = p->parent;
1955 }
1956}
1957
1958
1959/* Ensures the result of the expression as either a temporary variable
1960 or a constant so that it can be used repeatedly. */
1961
1962void
1963gfc_make_safe_expr (gfc_se * se)
1964{
1965 tree var;
1966
1967 if (CONSTANT_CLASS_P (se->expr)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (se->expr)->base.code))] == tcc_constant)
)
1968 return;
1969
1970 /* We need a temporary for this result. */
1971 var = gfc_create_var (TREE_TYPE (se->expr)((contains_struct_check ((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1971, __FUNCTION__))->typed.type)
, NULL__null);
1972 gfc_add_modify (&se->pre, var, se->expr);
1973 se->expr = var;
1974}
1975
1976
1977/* Return an expression which determines if a dummy parameter is present.
1978 Also used for arguments to procedures with multiple entry points. */
1979
1980tree
1981gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
1982{
1983 tree decl, orig_decl, cond;
1984
1985 gcc_assert (sym->attr.dummy)((void)(!(sym->attr.dummy) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1985, __FUNCTION__), 0 : 0))
;
1986 orig_decl = decl = gfc_get_symbol_decl (sym);
1987
1988 /* Intrinsic scalars with VALUE attribute which are passed by value
1989 use a hidden argument to denote the present status. */
1990 if (sym->attr.value && !sym->attr.dimension
1991 && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type)((sym->ts.type) == BT_DERIVED || (sym->ts.type) == BT_UNION
)
)
1992 {
1993 char name[GFC_MAX_SYMBOL_LEN63 + 2];
1994 tree tree_name;
1995
1996 gcc_assert (TREE_CODE (decl) == PARM_DECL)((void)(!(((enum tree_code) (decl)->base.code) == PARM_DECL
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 1996, __FUNCTION__), 0 : 0))
;
1997 name[0] = '.';
1998 strcpy (&name[1], sym->name);
1999 tree_name = get_identifier (name)(__builtin_constant_p (name) ? get_identifier_with_length ((name
), strlen (name)) : get_identifier (name))
;
2000
2001 /* Walk function argument list to find hidden arg. */
2002 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl))((tree_check ((((contains_struct_check ((decl), (TS_DECL_MINIMAL
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2002, __FUNCTION__))->decl_minimal.context)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2002, __FUNCTION__, (FUNCTION_DECL)))->function_decl.arguments
)
;
2003 for ( ; cond != NULL_TREE(tree) __null; cond = TREE_CHAIN (cond)((contains_struct_check ((cond), (TS_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2003, __FUNCTION__))->common.chain)
)
2004 if (DECL_NAME (cond)((contains_struct_check ((cond), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2004, __FUNCTION__))->decl_minimal.name)
== tree_name
2005 && DECL_ARTIFICIAL (cond)((contains_struct_check ((cond), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2005, __FUNCTION__))->decl_common.artificial_flag)
)
2006 break;
2007
2008 gcc_assert (cond)((void)(!(cond) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2008, __FUNCTION__), 0 : 0))
;
2009 return cond;
2010 }
2011
2012 /* Assumed-shape arrays use a local variable for the array data;
2013 the actual PARAM_DECL is in a saved decl. As the local variable
2014 is NULL, it can be checked instead, unless use_saved_desc is
2015 requested. */
2016
2017 if (use_saved_desc && TREE_CODE (decl)((enum tree_code) (decl)->base.code) != PARM_DECL)
2018 {
2019 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))((void)(!(((tree_class_check ((((contains_struct_check ((decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2019, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2019, __FUNCTION__))->type_common.lang_flag_1) || ((tree_class_check
((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__))->type_common.lang_flag_2)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__), 0 : 0))
2020 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))((void)(!(((tree_class_check ((((contains_struct_check ((decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2019, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2019, __FUNCTION__))->type_common.lang_flag_1) || ((tree_class_check
((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__))->type_common.lang_flag_2)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2020, __FUNCTION__), 0 : 0))
;
2021 decl = GFC_DECL_SAVED_DESCRIPTOR (decl)(((contains_struct_check ((decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2021, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
2022 }
2023
2024 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2025 fold_convert (TREE_TYPE (decl), null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2025, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
2026
2027 /* Fortran 2008 allows to pass null pointers and non-associated pointers
2028 as actual argument to denote absent dummies. For array descriptors,
2029 we thus also need to check the array descriptor. For BT_CLASS, it
2030 can also occur for scalars and F2003 due to type->class wrapping and
2031 class->class wrapping. Note further that BT_CLASS always uses an
2032 array descriptor for arrays, also for explicit-shape/assumed-size.
2033 For assumed-rank arrays, no local variable is generated, hence,
2034 the following also applies with !use_saved_desc. */
2035
2036 if ((use_saved_desc || TREE_CODE (orig_decl)((enum tree_code) (orig_decl)->base.code) == PARM_DECL)
2037 && !sym->attr.allocatable
2038 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2039 || (sym->ts.type == BT_CLASS
2040 && !CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
2041 && !CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer))
2042 && ((gfc_option.allow_std & GFC_STD_F2008(1<<7)) != 0
2043 || sym->ts.type == BT_CLASS))
2044 {
2045 tree tmp;
2046
2047 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2048 || sym->as->type == AS_ASSUMED_RANK
2049 || sym->attr.codimension))
2050 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)sym->ts.u.derived->components->as))
2051 {
2052 tmp = build_fold_indirect_ref_loc (input_location, decl);
2053 if (sym->ts.type == BT_CLASS)
2054 tmp = gfc_class_data_get (tmp);
2055 tmp = gfc_conv_array_data (tmp);
2056 }
2057 else if (sym->ts.type == BT_CLASS)
2058 tmp = gfc_class_data_get (decl);
2059 else
2060 tmp = NULL_TREE(tree) __null;
2061
2062 if (tmp != NULL_TREE(tree) __null)
2063 {
2064 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2065 fold_convert (TREE_TYPE (tmp), null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2065, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
2066 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2067 logical_type_node, cond, tmp);
2068 }
2069 }
2070
2071 return cond;
2072}
2073
2074
2075/* Converts a missing, dummy argument into a null or zero. */
2076
2077void
2078gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2079{
2080 tree present;
2081 tree tmp;
2082
2083 present = gfc_conv_expr_present (arg->symtree->n.sym);
2084
2085 if (kind > 0)
2086 {
2087 /* Create a temporary and convert it to the correct type. */
2088 tmp = gfc_get_int_type (kind);
2089 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,fold_convert_loc (((location_t) 0), tmp, build_fold_indirect_ref_loc
(input_location, se->expr))
2090 se->expr))fold_convert_loc (((location_t) 0), tmp, build_fold_indirect_ref_loc
(input_location, se->expr))
;
2091
2092 /* Test for a NULL value. */
2093 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2093, __FUNCTION__))->typed.type)
, present,
2094 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2094, __FUNCTION__))->typed.type), global_trees[TI_INTEGER_ONE
])
);
2095 tmp = gfc_evaluate_now (tmp, &se->pre);
2096 se->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
2097 }
2098 else
2099 {
2100 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr)((contains_struct_check ((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2100, __FUNCTION__))->typed.type)
,
2101 present, se->expr,
2102 build_zero_cst (TREE_TYPE (se->expr)((contains_struct_check ((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2102, __FUNCTION__))->typed.type)
));
2103 tmp = gfc_evaluate_now (tmp, &se->pre);
2104 se->expr = tmp;
2105 }
2106
2107 if (ts.type == BT_CHARACTER)
2108 {
2109 tmp = build_int_cst (gfc_charlen_type_node, 0);
2110 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
2111 present, se->string_length, tmp);
2112 tmp = gfc_evaluate_now (tmp, &se->pre);
2113 se->string_length = tmp;
2114 }
2115 return;
2116}
2117
2118
2119/* Get the character length of an expression, looking through gfc_refs
2120 if necessary. */
2121
2122tree
2123gfc_get_expr_charlen (gfc_expr *e)
2124{
2125 gfc_ref *r;
2126 tree length;
2127 gfc_se se;
2128
2129 gcc_assert (e->expr_type == EXPR_VARIABLE((void)(!(e->expr_type == EXPR_VARIABLE && e->ts
.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2130, __FUNCTION__), 0 : 0))
2130 && e->ts.type == BT_CHARACTER)((void)(!(e->expr_type == EXPR_VARIABLE && e->ts
.type == BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2130, __FUNCTION__), 0 : 0))
;
2131
2132 length = NULL__null; /* To silence compiler warning. */
2133
2134 if (is_subref_array (e) && e->ts.u.cl->length)
2135 {
2136 gfc_se tmpse;
2137 gfc_init_se (&tmpse, NULL__null);
2138 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2139 e->ts.u.cl->backend_decl = tmpse.expr;
2140 return tmpse.expr;
2141 }
2142
2143 /* First candidate: if the variable is of type CHARACTER, the
2144 expression's length could be the length of the character
2145 variable. */
2146 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2147 length = e->symtree->n.sym->ts.u.cl->backend_decl;
2148
2149 /* Look through the reference chain for component references. */
2150 for (r = e->ref; r; r = r->next)
2151 {
2152 switch (r->type)
2153 {
2154 case REF_COMPONENT:
2155 if (r->u.c.component->ts.type == BT_CHARACTER)
2156 length = r->u.c.component->ts.u.cl->backend_decl;
2157 break;
2158
2159 case REF_ARRAY:
2160 /* Do nothing. */
2161 break;
2162
2163 case REF_SUBSTRING:
2164 gfc_init_se (&se, NULL__null);
2165 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2166 length = se.expr;
2167 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2168 length = fold_build2_loc (input_location, MINUS_EXPR,
2169 gfc_charlen_type_node,
2170 se.expr, length);
2171 length = fold_build2_loc (input_location, PLUS_EXPR,
2172 gfc_charlen_type_node, length,
2173 gfc_index_one_nodegfc_rank_cst[1]);
2174 break;
2175
2176 default:
2177 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2177, __FUNCTION__))
;
2178 break;
2179 }
2180 }
2181
2182 gcc_assert (length != NULL)((void)(!(length != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2182, __FUNCTION__), 0 : 0))
;
2183 return length;
2184}
2185
2186
2187/* Return for an expression the backend decl of the coarray. */
2188
2189tree
2190gfc_get_tree_for_caf_expr (gfc_expr *expr)
2191{
2192 tree caf_decl;
2193 bool found = false;
2194 gfc_ref *ref;
2195
2196 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE)((void)(!(expr && expr->expr_type == EXPR_VARIABLE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2196, __FUNCTION__), 0 : 0))
;
2197
2198 /* Not-implemented diagnostic. */
2199 if (expr->symtree->n.sym->ts.type == BT_CLASS
2200 && UNLIMITED_POLY (expr->symtree->n.sym)(expr->symtree->n.sym != __null && expr->symtree
->n.sym->ts.type == BT_CLASS && expr->symtree
->n.sym->ts.u.derived->components && expr->
symtree->n.sym->ts.u.derived->components->ts.u.derived
&& expr->symtree->n.sym->ts.u.derived->components
->ts.u.derived->attr.unlimited_polymorphic)
2201 && CLASS_DATA (expr->symtree->n.sym)expr->symtree->n.sym->ts.u.derived->components->attr.codimension)
2202 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2203 "%L is not supported", &expr->where);
2204
2205 for (ref = expr->ref; ref; ref = ref->next)
2206 if (ref->type == REF_COMPONENT)
2207 {
2208 if (ref->u.c.component->ts.type == BT_CLASS
2209 && UNLIMITED_POLY (ref->u.c.component)(ref->u.c.component != __null && ref->u.c.component
->ts.type == BT_CLASS && ref->u.c.component->
ts.u.derived->components && ref->u.c.component->
ts.u.derived->components->ts.u.derived && ref->
u.c.component->ts.u.derived->components->ts.u.derived
->attr.unlimited_polymorphic)
2210 && CLASS_DATA (ref->u.c.component)ref->u.c.component->ts.u.derived->components->attr.codimension)
2211 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2212 "component at %L is not supported", &expr->where);
2213 }
2214
2215 /* Make sure the backend_decl is present before accessing it. */
2216 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE(tree) __null
2217 ? gfc_get_symbol_decl (expr->symtree->n.sym)
2218 : expr->symtree->n.sym->backend_decl;
2219
2220 if (expr->symtree->n.sym->ts.type == BT_CLASS)
2221 {
2222 if (expr->ref && expr->ref->type == REF_ARRAY)
2223 {
2224 caf_decl = gfc_class_data_get (caf_decl);
2225 if (CLASS_DATA (expr->symtree->n.sym)expr->symtree->n.sym->ts.u.derived->components->attr.codimension)
2226 return caf_decl;
2227 }
2228 for (ref = expr->ref; ref; ref = ref->next)
2229 {
2230 if (ref->type == REF_COMPONENT
2231 && strcmp (ref->u.c.component->name, "_data") != 0)
2232 {
2233 caf_decl = gfc_class_data_get (caf_decl);
2234 if (CLASS_DATA (expr->symtree->n.sym)expr->symtree->n.sym->ts.u.derived->components->attr.codimension)
2235 return caf_decl;
2236 break;
2237 }
2238 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2239 break;
2240 }
2241 }
2242 if (expr->symtree->n.sym->attr.codimension)
2243 return caf_decl;
2244
2245 /* The following code assumes that the coarray is a component reachable via
2246 only scalar components/variables; the Fortran standard guarantees this. */
2247
2248 for (ref = expr->ref; ref; ref = ref->next)
2249 if (ref->type == REF_COMPONENT)
2250 {
2251 gfc_component *comp = ref->u.c.component;
2252
2253 if (POINTER_TYPE_P (TREE_TYPE (caf_decl))(((enum tree_code) (((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2253, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((caf_decl), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2253, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
2254 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2255 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2256 TREE_TYPE (comp->backend_decl)((contains_struct_check ((comp->backend_decl), (TS_TYPED),
"/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2256, __FUNCTION__))->typed.type)
, caf_decl,
2257 comp->backend_decl, NULL_TREE(tree) __null);
2258 if (comp->ts.type == BT_CLASS)
2259 {
2260 caf_decl = gfc_class_data_get (caf_decl);
2261 if (CLASS_DATA (comp)comp->ts.u.derived->components->attr.codimension)
2262 {
2263 found = true;
2264 break;
2265 }
2266 }
2267 if (comp->attr.codimension)
2268 {
2269 found = true;
2270 break;
2271 }
2272 }
2273 gcc_assert (found && caf_decl)((void)(!(found && caf_decl) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2273, __FUNCTION__), 0 : 0))
;
2274 return caf_decl;
2275}
2276
2277
2278/* Obtain the Coarray token - and optionally also the offset. */
2279
2280void
2281gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2282 tree se_expr, gfc_expr *expr)
2283{
2284 tree tmp;
2285
2286 /* Coarray token. */
2287 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2287, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2287, __FUNCTION__))->type_common.lang_flag_1)
)
2288 {
2289 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))((void)(!((((tree_class_check ((((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ALLOCATABLE || expr->symtree->
n.sym->attr.select_type_temporary) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2291, __FUNCTION__), 0 : 0))
2290 == GFC_ARRAY_ALLOCATABLE((void)(!((((tree_class_check ((((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ALLOCATABLE || expr->symtree->
n.sym->attr.select_type_temporary) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2291, __FUNCTION__), 0 : 0))
2291 || expr->symtree->n.sym->attr.select_type_temporary)((void)(!((((tree_class_check ((((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2289, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind) == GFC_ARRAY_ALLOCATABLE || expr->symtree->
n.sym->attr.select_type_temporary) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2291, __FUNCTION__), 0 : 0))
;
2292 *token = gfc_conv_descriptor_token (caf_decl);
2293 }
2294 else if (DECL_LANG_SPECIFIC (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2294, __FUNCTION__))->decl_common.lang_specific)
2295 && GFC_DECL_TOKEN (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2295, __FUNCTION__))->decl_common.lang_specific)->token
!= NULL_TREE(tree) __null)
2296 *token = GFC_DECL_TOKEN (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2296, __FUNCTION__))->decl_common.lang_specific)->token
;
2297 else
2298 {
2299 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))((void)(!(((tree_class_check ((((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2299, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2299, __FUNCTION__))->type_common.lang_flag_2) &&
(((tree_class_check ((((contains_struct_check ((caf_decl), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_token) != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__), 0 : 0))
2300 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE)((void)(!(((tree_class_check ((((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2299, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2299, __FUNCTION__))->type_common.lang_flag_2) &&
(((tree_class_check ((((contains_struct_check ((caf_decl), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_token) != (tree) __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2300, __FUNCTION__), 0 : 0))
;
2301 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl))(((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2301, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2301, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_token)
;
2302 }
2303
2304 if (offset == NULL__null)
2305 return;
2306
2307 /* Offset between the coarray base address and the address wanted. */
2308 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2308, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2308, __FUNCTION__))->type_common.lang_flag_1)
2309 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))(((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2309, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2309, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind)
== GFC_ARRAY_ALLOCATABLE
2310 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))(((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2310, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2310, __FUNCTION__))->type_with_lang_specific.lang_specific
)->akind)
== GFC_ARRAY_POINTER))
2311 *offset = build_int_cst (gfc_array_index_type, 0);
2312 else if (DECL_LANG_SPECIFIC (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2312, __FUNCTION__))->decl_common.lang_specific)
2313 && GFC_DECL_CAF_OFFSET (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2313, __FUNCTION__))->decl_common.lang_specific)->caf_offset
!= NULL_TREE(tree) __null)
2314 *offset = GFC_DECL_CAF_OFFSET (caf_decl)((contains_struct_check ((caf_decl), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2314, __FUNCTION__))->decl_common.lang_specific)->caf_offset
;
2315 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl))(((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2315, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2315, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_offset)
!= NULL_TREE(tree) __null)
2316 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl))(((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2316, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2316, __FUNCTION__))->type_with_lang_specific.lang_specific
)->caf_offset)
;
2317 else
2318 *offset = build_int_cst (gfc_array_index_type, 0);
2319
2320 if (POINTER_TYPE_P (TREE_TYPE (se_expr))(((enum tree_code) (((contains_struct_check ((se_expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2320, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se_expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2320, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
2321 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr)))((tree_class_check ((((contains_struct_check ((((contains_struct_check
((se_expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2321, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2321, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2321, __FUNCTION__))->type_common.lang_flag_1)
)
2322 {
2323 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2324 tmp = gfc_conv_descriptor_data_get (tmp);
2325 }
2326 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr))((tree_class_check ((((contains_struct_check ((se_expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2326, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2326, __FUNCTION__))->type_common.lang_flag_1)
)
2327 tmp = gfc_conv_descriptor_data_get (se_expr);
2328 else
2329 {
2330 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)))((void)(!((((enum tree_code) (((contains_struct_check ((se_expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2330, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se_expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2330, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2330, __FUNCTION__), 0 : 0))
;
2331 tmp = se_expr;
2332 }
2333
2334 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2335 *offset, fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
);
2336
2337 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2338 && expr->symtree->n.sym->attr.codimension
2339 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2340 {
2341 gfc_expr *base_expr = gfc_copy_expr (expr);
2342 gfc_ref *ref = base_expr->ref;
2343 gfc_se base_se;
2344
2345 // Iterate through the refs until the last one.
2346 while (ref->next)
2347 ref = ref->next;
2348
2349 if (ref->type == REF_ARRAY
2350 && ref->u.ar.type != AR_FULL)
2351 {
2352 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2353 int i;
2354 for (i = 0; i < ranksum; ++i)
2355 {
2356 ref->u.ar.start[i] = NULL__null;
2357 ref->u.ar.end[i] = NULL__null;
2358 }
2359 ref->u.ar.type = AR_FULL;
2360 }
2361 gfc_init_se (&base_se, NULL__null);
2362 if (gfc_caf_attr (base_expr).dimension)
2363 {
2364 gfc_conv_expr_descriptor (&base_se, base_expr);
2365 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2366 }
2367 else
2368 {
2369 gfc_conv_expr (&base_se, base_expr);
2370 tmp = base_se.expr;
2371 }
2372
2373 gfc_free_expr (base_expr);
2374 gfc_add_block_to_block (&se->pre, &base_se.pre);
2375 gfc_add_block_to_block (&se->post, &base_se.post);
2376 }
2377 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))((tree_class_check ((((contains_struct_check ((caf_decl), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2377, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2377, __FUNCTION__))->type_common.lang_flag_1)
)
2378 tmp = gfc_conv_descriptor_data_get (caf_decl);
2379 else
2380 {
2381 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)))((void)(!((((enum tree_code) (((contains_struct_check ((caf_decl
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2381, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((caf_decl), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2381, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2381, __FUNCTION__), 0 : 0))
;
2382 tmp = caf_decl;
2383 }
2384
2385 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2386 fold_convert (gfc_array_index_type, *offset)fold_convert_loc (((location_t) 0), gfc_array_index_type, *offset
)
,
2387 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
);
2388}
2389
2390
2391/* Convert the coindex of a coarray into an image index; the result is
2392 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2393 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2394
2395tree
2396gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2397{
2398 gfc_ref *ref;
2399 tree lbound, ubound, extent, tmp, img_idx;
2400 gfc_se se;
2401 int i;
2402
2403 for (ref = e->ref; ref; ref = ref->next)
2404 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2405 break;
2406 gcc_assert (ref != NULL)((void)(!(ref != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2406, __FUNCTION__), 0 : 0))
;
2407
2408 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2409 {
2410 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2411 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2412 }
2413
2414 img_idx = build_zero_cst (gfc_array_index_type);
2415 extent = build_one_cst (gfc_array_index_type);
2416 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2416, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2416, __FUNCTION__))->type_common.lang_flag_1)
)
2417 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2418 {
2419 gfc_init_se (&se, NULL__null);
2420 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2421 gfc_add_block_to_block (block, &se.pre);
2422 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2423 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2424 TREE_TYPE (lbound)((contains_struct_check ((lbound), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2424, __FUNCTION__))->typed.type)
, se.expr, lbound);
2425 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2425, __FUNCTION__))->typed.type)
,
2426 extent, tmp);
2427 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2428 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2428, __FUNCTION__))->typed.type)
, img_idx, tmp);
2429 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2430 {
2431 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2432 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
2433 extent = fold_build2_loc (input_location, MULT_EXPR,
2434 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2434, __FUNCTION__))->typed.type)
, extent, tmp);
2435 }
2436 }
2437 else
2438 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2439 {
2440 gfc_init_se (&se, NULL__null);
2441 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2442 gfc_add_block_to_block (block, &se.pre);
2443 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i)(((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2443, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2443, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[i])
;
2444 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2445 TREE_TYPE (lbound)((contains_struct_check ((lbound), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2445, __FUNCTION__))->typed.type)
, se.expr, lbound);
2446 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2446, __FUNCTION__))->typed.type)
,
2447 extent, tmp);
2448 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2448, __FUNCTION__))->typed.type)
,
2449 img_idx, tmp);
2450 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2451 {
2452 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i)(((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2452, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2452, __FUNCTION__))->type_with_lang_specific.lang_specific
)->ubound[i])
;
2453 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2454 TREE_TYPE (ubound)((contains_struct_check ((ubound), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2454, __FUNCTION__))->typed.type)
, ubound, lbound);
2455 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2455, __FUNCTION__))->typed.type)
,
2456 tmp, build_one_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2456, __FUNCTION__))->typed.type)
));
2457 extent = fold_build2_loc (input_location, MULT_EXPR,
2458 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2458, __FUNCTION__))->typed.type)
, extent, tmp);
2459 }
2460 }
2461 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx)((contains_struct_check ((img_idx), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2461, __FUNCTION__))->typed.type)
,
2462 img_idx, build_one_cst (TREE_TYPE (img_idx)((contains_struct_check ((img_idx), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2462, __FUNCTION__))->typed.type)
));
2463 return fold_convert (integer_type_node, img_idx)fold_convert_loc (((location_t) 0), integer_types[itk_int], img_idx
)
;
2464}
2465
2466
2467/* For each character array constructor subexpression without a ts.u.cl->length,
2468 replace it by its first element (if there aren't any elements, the length
2469 should already be set to zero). */
2470
2471static void
2472flatten_array_ctors_without_strlen (gfc_expr* e)
2473{
2474 gfc_actual_arglist* arg;
2475 gfc_constructor* c;
2476
2477 if (!e)
2478 return;
2479
2480 switch (e->expr_type)
2481 {
2482
2483 case EXPR_OP:
2484 flatten_array_ctors_without_strlen (e->value.op.op1);
2485 flatten_array_ctors_without_strlen (e->value.op.op2);
2486 break;
2487
2488 case EXPR_COMPCALL:
2489 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2490 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2490, __FUNCTION__))
;
2491
2492 case EXPR_FUNCTION:
2493 for (arg = e->value.function.actual; arg; arg = arg->next)
2494 flatten_array_ctors_without_strlen (arg->expr);
2495 break;
2496
2497 case EXPR_ARRAY:
2498
2499 /* We've found what we're looking for. */
2500 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2501 {
2502 gfc_constructor *c;
2503 gfc_expr* new_expr;
2504
2505 gcc_assert (e->value.constructor)((void)(!(e->value.constructor) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2505, __FUNCTION__), 0 : 0))
;
2506
2507 c = gfc_constructor_first (e->value.constructor);
2508 new_expr = c->expr;
2509 c->expr = NULL__null;
2510
2511 flatten_array_ctors_without_strlen (new_expr);
2512 gfc_replace_expr (e, new_expr);
2513 break;
2514 }
2515
2516 /* Otherwise, fall through to handle constructor elements. */
2517 gcc_fallthrough ();
2518 case EXPR_STRUCTURE:
2519 for (c = gfc_constructor_first (e->value.constructor);
2520 c; c = gfc_constructor_next (c))
2521 flatten_array_ctors_without_strlen (c->expr);
2522 break;
2523
2524 default:
2525 break;
2526
2527 }
2528}
2529
2530
2531/* Generate code to initialize a string length variable. Returns the
2532 value. For array constructors, cl->length might be NULL and in this case,
2533 the first element of the constructor is needed. expr is the original
2534 expression so we can access it but can be NULL if this is not needed. */
2535
2536void
2537gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2538{
2539 gfc_se se;
2540
2541 gfc_init_se (&se, NULL__null);
2542
2543 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl)(((enum tree_code) (cl->backend_decl)->base.code) == VAR_DECL
)
)
2544 return;
2545
2546 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2547 "flatten" array constructors by taking their first element; all elements
2548 should be the same length or a cl->length should be present. */
2549 if (!cl->length)
2550 {
2551 gfc_expr* expr_flat;
2552 if (!expr)
2553 return;
2554 expr_flat = gfc_copy_expr (expr);
2555 flatten_array_ctors_without_strlen (expr_flat);
2556 gfc_resolve_expr (expr_flat);
2557
2558 gfc_conv_expr (&se, expr_flat);
2559 gfc_add_block_to_block (pblock, &se.pre);
2560 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2561
2562 gfc_free_expr (expr_flat);
2563 return;
2564 }
2565
2566 /* Convert cl->length. */
2567
2568 gcc_assert (cl->length)((void)(!(cl->length) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2568, __FUNCTION__), 0 : 0))
;
2569
2570 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2571 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2572 se.expr, build_zero_cst (TREE_TYPE (se.expr)((contains_struct_check ((se.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2572, __FUNCTION__))->typed.type)
));
2573 gfc_add_block_to_block (pblock, &se.pre);
2574
2575 if (cl->backend_decl && VAR_P (cl->backend_decl)(((enum tree_code) (cl->backend_decl)->base.code) == VAR_DECL
)
)
2576 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2577 else
2578 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2579}
2580
2581
2582static void
2583gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2584 const char *name, locus *where)
2585{
2586 tree tmp;
2587 tree type;
2588 tree fault;
2589 gfc_se start;
2590 gfc_se end;
2591 char *msg;
2592 mpz_t length;
2593
2594 type = gfc_get_character_type (kind, ref->u.ss.length);
2595 type = build_pointer_type (type);
2596
2597 gfc_init_se (&start, se);
2598 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2599 gfc_add_block_to_block (&se->pre, &start.pre);
2600
2601 if (integer_onep (start.expr))
2602 gfc_conv_string_parameter (se);
2603 else
2604 {
2605 tmp = start.expr;
2606 STRIP_NOPS (tmp)(tmp) = tree_strip_nop_conversions ((const_cast<union tree_node
*> (((tmp)))))
;
2607 /* Avoid multiple evaluation of substring start. */
2608 if (!CONSTANT_CLASS_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_constant)
&& !DECL_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_declaration)
)
2609 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2610
2611 /* Change the start of the string. */
2612 if ((TREE_CODE (TREE_TYPE (se->expr))((enum tree_code) (((contains_struct_check ((se->expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2612, __FUNCTION__))->typed.type))->base.code)
== ARRAY_TYPE
2613 || TREE_CODE (TREE_TYPE (se->expr))((enum tree_code) (((contains_struct_check ((se->expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2613, __FUNCTION__))->typed.type))->base.code)
== INTEGER_TYPE)
2614 && TYPE_STRING_FLAG (TREE_TYPE (se->expr))((tree_check2 ((((contains_struct_check ((se->expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2614, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2614, __FUNCTION__, (ARRAY_TYPE), (INTEGER_TYPE)))->type_common
.string_flag)
)
2615 tmp = se->expr;
2616 else
2617 tmp = build_fold_indirect_ref_loc (input_location,
2618 se->expr);
2619 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2620 if (TREE_CODE (TREE_TYPE (tmp))((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2620, __FUNCTION__))->typed.type))->base.code)
== ARRAY_TYPE)
2621 {
2622 tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE(tree) __null, true);
2623 se->expr = gfc_build_addr_expr (type, tmp);
2624 }
2625 }
2626
2627 /* Length = end + 1 - start. */
2628 gfc_init_se (&end, se);
2629 if (ref->u.ss.end == NULL__null)
2630 end.expr = se->string_length;
2631 else
2632 {
2633 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2634 gfc_add_block_to_block (&se->pre, &end.pre);
2635 }
2636 tmp = end.expr;
2637 STRIP_NOPS (tmp)(tmp) = tree_strip_nop_conversions ((const_cast<union tree_node
*> (((tmp)))))
;
2638 if (!CONSTANT_CLASS_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_constant)
&& !DECL_P (tmp)(tree_code_type_tmpl <0>::tree_code_type[(int) (((enum tree_code
) (tmp)->base.code))] == tcc_declaration)
)
2639 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2640
2641 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
2642 && (ref->u.ss.start->symtree
2643 && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
2644 {
2645 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2646 logical_type_node, start.expr,
2647 end.expr);
2648
2649 /* Check lower bound. */
2650 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2651 start.expr,
2652 build_one_cst (TREE_TYPE (start.expr)((contains_struct_check ((start.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2652, __FUNCTION__))->typed.type)
));
2653 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2654 logical_type_node, nonempty, fault);
2655 if (name)
2656 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2657 "is less than one", name);
2658 else
2659 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2660 "is less than one");
2661 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2662 fold_convert (long_integer_type_node,fold_convert_loc (((location_t) 0), integer_types[itk_long], start
.expr)
2663 start.expr)fold_convert_loc (((location_t) 0), integer_types[itk_long], start
.expr)
);
2664 free (msg);
2665
2666 /* Check upper bound. */
2667 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2668 end.expr, se->string_length);
2669 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2670 logical_type_node, nonempty, fault);
2671 if (name)
2672 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2673 "exceeds string length (%%ld)", name);
2674 else
2675 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2676 "exceeds string length (%%ld)");
2677 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2678 fold_convert (long_integer_type_node, end.expr)fold_convert_loc (((location_t) 0), integer_types[itk_long], end
.expr)
,
2679 fold_convert (long_integer_type_node,fold_convert_loc (((location_t) 0), integer_types[itk_long], se
->string_length)
2680 se->string_length)fold_convert_loc (((location_t) 0), integer_types[itk_long], se
->string_length)
);
2681 free (msg);
2682 }
2683
2684 /* Try to calculate the length from the start and end expressions. */
2685 if (ref->u.ss.end
2686 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2687 {
2688 HOST_WIDE_INTlong i_len;
2689
2690 i_len = gfc_mpz_get_hwi (length) + 1;
2691 if (i_len < 0)
2692 i_len = 0;
2693
2694 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2695 mpz_clear__gmpz_clear (length); /* Was initialized by gfc_dep_difference. */
2696 }
2697 else
2698 {
2699 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2700 fold_convert (gfc_charlen_type_node, end.expr)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, end
.expr)
,
2701 fold_convert (gfc_charlen_type_node, start.expr)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, start
.expr)
);
2702 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2703 build_int_cst (gfc_charlen_type_node, 1), tmp);
2704 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2705 tmp, build_int_cst (gfc_charlen_type_node, 0));
2706 }
2707
2708 se->string_length = tmp;
2709}
2710
2711
2712/* Convert a derived type component reference. */
2713
2714void
2715gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2716{
2717 gfc_component *c;
2718 tree tmp;
2719 tree decl;
2720 tree field;
2721 tree context;
2722
2723 c = ref->u.c.component;
2724
2725 if (c->backend_decl == NULL_TREE(tree) __null
2726 && ref->u.c.sym != NULL__null)
2727 gfc_get_derived_type (ref->u.c.sym);
2728
2729 field = c->backend_decl;
2730 gcc_assert (field && TREE_CODE (field) == FIELD_DECL)((void)(!(field && ((enum tree_code) (field)->base
.code) == FIELD_DECL) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2730, __FUNCTION__), 0 : 0))
;
2731 decl = se->expr;
2732 context = DECL_FIELD_CONTEXT (field)((tree_check ((field), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2732, __FUNCTION__, (FIELD_DECL)))->decl_minimal.context
)
;
2733
2734 /* Components can correspond to fields of different containing
2735 types, as components are created without context, whereas
2736 a concrete use of a component has the type of decl as context.
2737 So, if the type doesn't match, we search the corresponding
2738 FIELD_DECL in the parent type. To not waste too much time
2739 we cache this result in norestrict_decl.
2740 On the other hand, if the context is a UNION or a MAP (a
2741 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2742
2743 if (context != TREE_TYPE (decl)((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2743, __FUNCTION__))->typed.type)
2744 && !( TREE_CODE (TREE_TYPE (field))((enum tree_code) (((contains_struct_check ((field), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2744, __FUNCTION__))->typed.type))->base.code)
== UNION_TYPE /* Field is union */
2745 || TREE_CODE (context)((enum tree_code) (context)->base.code) == UNION_TYPE)) /* Field is map */
2746 {
2747 tree f2 = c->norestrict_decl;
2748 if (!f2 || DECL_FIELD_CONTEXT (f2)((tree_check ((f2), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2748, __FUNCTION__, (FIELD_DECL)))->decl_minimal.context
)
!= TREE_TYPE (decl)((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2748, __FUNCTION__))->typed.type)
)
2749 for (f2 = TYPE_FIELDS (TREE_TYPE (decl))((tree_check3 ((((contains_struct_check ((decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2749, __FUNCTION__))->typed.type)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2749, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
; f2; f2 = DECL_CHAIN (f2)(((contains_struct_check (((contains_struct_check ((f2), (TS_DECL_MINIMAL
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2749, __FUNCTION__))), (TS_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2749, __FUNCTION__))->common.chain))
)
2750 if (TREE_CODE (f2)((enum tree_code) (f2)->base.code) == FIELD_DECL
2751 && DECL_NAME (f2)((contains_struct_check ((f2), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2751, __FUNCTION__))->decl_minimal.name)
== DECL_NAME (field)((contains_struct_check ((field), (TS_DECL_MINIMAL), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2751, __FUNCTION__))->decl_minimal.name)
)
2752 break;
2753 gcc_assert (f2)((void)(!(f2) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2753, __FUNCTION__), 0 : 0))
;
2754 c->norestrict_decl = f2;
2755 field = f2;
2756 }
2757
2758 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2759 && strcmp ("_data", c->name) == 0)
2760 {
2761 /* Found a ref to the _data component. Store the associated ref to
2762 the vptr in se->class_vptr. */
2763 se->class_vptr = gfc_class_vptr_get (decl);
2764 }
2765 else
2766 se->class_vptr = NULL_TREE(tree) __null;
2767
2768 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2768, __FUNCTION__))->typed.type)
,
2769 decl, field, NULL_TREE(tree) __null);
2770
2771 se->expr = tmp;
2772
2773 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2774 strlen () conditional below. */
2775 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2776 && !c->ts.deferred
2777 && !c->attr.pdt_string)
2778 {
2779 tmp = c->ts.u.cl->backend_decl;
2780 /* Components must always be constant length. */
2781 gcc_assert (tmp && INTEGER_CST_P (tmp))((void)(!(tmp && (((enum tree_code) (tmp)->base.code
) == INTEGER_CST)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2781, __FUNCTION__), 0 : 0))
;
2782 se->string_length = tmp;
2783 }
2784
2785 if (gfc_deferred_strlen (c, &field))
2786 {
2787 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2788 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2788, __FUNCTION__))->typed.type)
,
2789 decl, field, NULL_TREE(tree) __null);
2790 se->string_length = tmp;
2791 }
2792
2793 if (((c->attr.pointer || c->attr.allocatable)
2794 && (!c->attr.dimension && !c->attr.codimension)
2795 && c->ts.type != BT_CHARACTER)
2796 || c->attr.proc_pointer)
2797 se->expr = build_fold_indirect_ref_loc (input_location,
2798 se->expr);
2799}
2800
2801
2802/* This function deals with component references to components of the
2803 parent type for derived type extensions. */
2804void
2805conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2806{
2807 gfc_component *c;
2808 gfc_component *cmp;
2809 gfc_symbol *dt;
2810 gfc_ref parent;
2811
2812 dt = ref->u.c.sym;
2813 c = ref->u.c.component;
2814
2815 /* Return if the component is in this type, i.e. not in the parent type. */
2816 for (cmp = dt->components; cmp; cmp = cmp->next)
2817 if (c == cmp)
2818 return;
2819
2820 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2821 parent.type = REF_COMPONENT;
2822 parent.next = NULL__null;
2823 parent.u.c.sym = dt;
2824 parent.u.c.component = dt->components;
2825
2826 if (dt->backend_decl == NULL__null)
2827 gfc_get_derived_type (dt);
2828
2829 /* Build the reference and call self. */
2830 gfc_conv_component_ref (se, &parent);
2831 parent.u.c.sym = dt->components->ts.u.derived;
2832 parent.u.c.component = c;
2833 conv_parent_component_references (se, &parent);
2834}
2835
2836
2837static void
2838conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2839{
2840 tree res = se->expr;
2841
2842 switch (ref->u.i)
2843 {
2844 case INQUIRY_RE:
2845 res = fold_build1_loc (input_location, REALPART_EXPR,
2846 TREE_TYPE (TREE_TYPE (res))((contains_struct_check ((((contains_struct_check ((res), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2846, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2846, __FUNCTION__))->typed.type)
, res);
2847 break;
2848
2849 case INQUIRY_IM:
2850 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2851 TREE_TYPE (TREE_TYPE (res))((contains_struct_check ((((contains_struct_check ((res), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2851, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2851, __FUNCTION__))->typed.type)
, res);
2852 break;
2853
2854 case INQUIRY_KIND:
2855 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2856 ts->kind);
2857 break;
2858
2859 case INQUIRY_LEN:
2860 res = fold_convert (gfc_typenode_for_spec (&expr->ts),fold_convert_loc (((location_t) 0), gfc_typenode_for_spec (&
expr->ts), se->string_length)
2861 se->string_length)fold_convert_loc (((location_t) 0), gfc_typenode_for_spec (&
expr->ts), se->string_length)
;
2862 break;
2863
2864 default:
2865 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2865, __FUNCTION__))
;
2866 }
2867 se->expr = res;
2868}
2869
2870/* Dereference VAR where needed if it is a pointer, reference, etc.
2871 according to Fortran semantics. */
2872
2873tree
2874gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2875 bool is_classarray)
2876{
2877 if (!POINTER_TYPE_P (TREE_TYPE (var))(((enum tree_code) (((contains_struct_check ((var), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2877, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((var), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2877, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
2878 return var;
2879 if (is_CFI_desc (sym, NULL__null))
2880 return build_fold_indirect_ref_loc (input_location, var);
2881
2882 /* Characters are entirely different from other types, they are treated
2883 separately. */
2884 if (sym->ts.type == BT_CHARACTER)
2885 {
2886 /* Dereference character pointer dummy arguments
2887 or results. */
2888 if ((sym->attr.pointer || sym->attr.allocatable
2889 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2890 && (sym->attr.dummy
2891 || sym->attr.function
2892 || sym->attr.result))
2893 var = build_fold_indirect_ref_loc (input_location, var);
2894 }
2895 else if (!sym->attr.value)
2896 {
2897 /* Dereference temporaries for class array dummy arguments. */
2898 if (sym->attr.dummy && is_classarray
2899 && GFC_ARRAY_TYPE_P (TREE_TYPE (var))((tree_class_check ((((contains_struct_check ((var), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2899, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2899, __FUNCTION__))->type_common.lang_flag_2)
)
2900 {
2901 if (!descriptor_only_p)
2902 var = GFC_DECL_SAVED_DESCRIPTOR (var)(((contains_struct_check ((var), (TS_DECL_COMMON), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2902, __FUNCTION__))->decl_common.lang_specific)->saved_descriptor
)
;
2903
2904 var = build_fold_indirect_ref_loc (input_location, var);
2905 }
2906
2907 /* Dereference non-character scalar dummy arguments. */
2908 if (sym->attr.dummy && !sym->attr.dimension
2909 && !(sym->attr.codimension && sym->attr.allocatable)
2910 && (sym->ts.type != BT_CLASS
2911 || (!CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
2912 && !(CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension
2913 && CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable))))
2914 var = build_fold_indirect_ref_loc (input_location, var);
2915
2916 /* Dereference scalar hidden result. */
2917 if (flag_f2cglobal_options.x_flag_f2c && sym->ts.type == BT_COMPLEX
2918 && (sym->attr.function || sym->attr.result)
2919 && !sym->attr.dimension && !sym->attr.pointer
2920 && !sym->attr.always_explicit)
2921 var = build_fold_indirect_ref_loc (input_location, var);
2922
2923 /* Dereference non-character, non-class pointer variables.
2924 These must be dummies, results, or scalars. */
2925 if (!is_classarray
2926 && (sym->attr.pointer || sym->attr.allocatable
2927 || gfc_is_associate_pointer (sym)
2928 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2929 && (sym->attr.dummy
2930 || sym->attr.function
2931 || sym->attr.result
2932 || (!sym->attr.dimension
2933 && (!sym->attr.codimension || !sym->attr.allocatable))))
2934 var = build_fold_indirect_ref_loc (input_location, var);
2935 /* Now treat the class array pointer variables accordingly. */
2936 else if (sym->ts.type == BT_CLASS
2937 && sym->attr.dummy
2938 && (CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
2939 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension)
2940 && ((CLASS_DATA (sym)sym->ts.u.derived->components->as
2941 && CLASS_DATA (sym)sym->ts.u.derived->components->as->type == AS_ASSUMED_RANK)
2942 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
2943 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer))
2944 var = build_fold_indirect_ref_loc (input_location, var);
2945 /* And the case where a non-dummy, non-result, non-function,
2946 non-allocable and non-pointer classarray is present. This case was
2947 previously covered by the first if, but with introducing the
2948 condition !is_classarray there, that case has to be covered
2949 explicitly. */
2950 else if (sym->ts.type == BT_CLASS
2951 && !sym->attr.dummy
2952 && !sym->attr.function
2953 && !sym->attr.result
2954 && (CLASS_DATA (sym)sym->ts.u.derived->components->attr.dimension
2955 || CLASS_DATA (sym)sym->ts.u.derived->components->attr.codimension)
2956 && (sym->assoc
2957 || !CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable)
2958 && !CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer)
2959 var = build_fold_indirect_ref_loc (input_location, var);
2960 }
2961
2962 return var;
2963}
2964
2965/* Return the contents of a variable. Also handles reference/pointer
2966 variables (all Fortran pointer references are implicit). */
2967
2968static void
2969gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2970{
2971 gfc_ss *ss;
2972 gfc_ref *ref;
2973 gfc_symbol *sym;
2974 tree parent_decl = NULL_TREE(tree) __null;
2975 int parent_flag;
2976 bool return_value;
2977 bool alternate_entry;
2978 bool entry_master;
2979 bool is_classarray;
2980 bool first_time = true;
2981
2982 sym = expr->symtree->n.sym;
2983 is_classarray = IS_CLASS_ARRAY (sym)(sym->ts.type == BT_CLASS && sym->ts.u.derived->
components && sym->ts.u.derived->components->
attr.dimension && !sym->ts.u.derived->components
->attr.class_pointer)
;
2984 ss = se->ss;
2985 if (ss != NULL__null)
2986 {
2987 gfc_ss_info *ss_info = ss->info;
2988
2989 /* Check that something hasn't gone horribly wrong. */
2990 gcc_assert (ss != gfc_ss_terminator)((void)(!(ss != gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2990, __FUNCTION__), 0 : 0))
;
2991 gcc_assert (ss_info->expr == expr)((void)(!(ss_info->expr == expr) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2991, __FUNCTION__), 0 : 0))
;
2992
2993 /* A scalarized term. We already know the descriptor. */
2994 se->expr = ss_info->data.array.descriptor;
2995 se->string_length = ss_info->string_length;
2996 ref = ss_info->data.array.ref;
2997 if (ref)
2998 gcc_assert (ref->type == REF_ARRAY((void)(!(ref->type == REF_ARRAY && ref->u.ar.type
!= AR_ELEMENT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2999, __FUNCTION__), 0 : 0))
2999 && ref->u.ar.type != AR_ELEMENT)((void)(!(ref->type == REF_ARRAY && ref->u.ar.type
!= AR_ELEMENT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 2999, __FUNCTION__), 0 : 0))
;
3000 else
3001 gfc_conv_tmp_array_ref (se);
3002 }
3003 else
3004 {
3005 tree se_expr = NULL_TREE(tree) __null;
3006
3007 se->expr = gfc_get_symbol_decl (sym);
3008
3009 /* Deal with references to a parent results or entries by storing
3010 the current_function_decl and moving to the parent_decl. */
3011 return_value = sym->attr.function && sym->result == sym;
3012 alternate_entry = sym->attr.function && sym->attr.entry
3013 && sym->result == sym;
3014 entry_master = sym->attr.result
3015 && sym->ns->proc_name->attr.entry_master
3016 && !gfc_return_by_reference (sym->ns->proc_name);
3017 if (current_function_decl)
3018 parent_decl = DECL_CONTEXT (current_function_decl)((contains_struct_check ((current_function_decl), (TS_DECL_MINIMAL
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3018, __FUNCTION__))->decl_minimal.context)
;
3019
3020 if ((se->expr == parent_decl && return_value)
3021 || (sym->ns && sym->ns->proc_name
3022 && parent_decl
3023 && sym->ns->proc_name->backend_decl == parent_decl
3024 && (alternate_entry || entry_master)))
3025 parent_flag = 1;
3026 else
3027 parent_flag = 0;
3028
3029 /* Special case for assigning the return value of a function.
3030 Self recursive functions must have an explicit return value. */
3031 if (return_value && (se->expr == current_function_decl || parent_flag))
3032 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3033
3034 /* Similarly for alternate entry points. */
3035 else if (alternate_entry
3036 && (sym->ns->proc_name->backend_decl == current_function_decl
3037 || parent_flag))
3038 {
3039 gfc_entry_list *el = NULL__null;
3040
3041 for (el = sym->ns->entries; el; el = el->next)
3042 if (sym == el->sym)
3043 {
3044 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3045 break;
3046 }
3047 }
3048
3049 else if (entry_master
3050 && (sym->ns->proc_name->backend_decl == current_function_decl
3051 || parent_flag))
3052 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3053
3054 if (se_expr)
3055 se->expr = se_expr;
3056
3057 /* Procedure actual arguments. Look out for temporary variables
3058 with the same attributes as function values. */
3059 else if (!sym->attr.temporary
3060 && sym->attr.flavor == FL_PROCEDURE
3061 && se->expr != current_function_decl)
3062 {
3063 if (!sym->attr.dummy && !sym->attr.proc_pointer)
3064 {
3065 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL)((void)(!(((enum tree_code) (se->expr)->base.code) == FUNCTION_DECL
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3065, __FUNCTION__), 0 : 0))
;
3066 se->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, se->expr);
3067 }
3068 return;
3069 }
3070
3071 /* Dereference the expression, where needed. */
3072 se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3073 is_classarray);
3074
3075 ref = expr->ref;
3076 }
3077
3078 /* For character variables, also get the length. */
3079 if (sym->ts.type == BT_CHARACTER)
3080 {
3081 /* If the character length of an entry isn't set, get the length from
3082 the master function instead. */
3083 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3084 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3085 else
3086 se->string_length = sym->ts.u.cl->backend_decl;
3087 gcc_assert (se->string_length)((void)(!(se->string_length) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3087, __FUNCTION__), 0 : 0))
;
3088 }
3089
3090 gfc_typespec *ts = &sym->ts;
3091 while (ref)
3092 {
3093 switch (ref->type)
3094 {
3095 case REF_ARRAY:
3096 /* Return the descriptor if that's what we want and this is an array
3097 section reference. */
3098 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3099 return;
3100/* TODO: Pointers to single elements of array sections, eg elemental subs. */
3101 /* Return the descriptor for array pointers and allocations. */
3102 if (se->want_pointer
3103 && ref->next == NULL__null && (se->descriptor_only))
3104 return;
3105
3106 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3107 /* Return a pointer to an element. */
3108 break;
3109
3110 case REF_COMPONENT:
3111 ts = &ref->u.c.component->ts;
3112 if (first_time && is_classarray && sym->attr.dummy
3113 && se->descriptor_only
3114 && !CLASS_DATA (sym)sym->ts.u.derived->components->attr.allocatable
3115 && !CLASS_DATA (sym)sym->ts.u.derived->components->attr.class_pointer
3116 && CLASS_DATA (sym)sym->ts.u.derived->components->as
3117 && CLASS_DATA (sym)sym->ts.u.derived->components->as->type != AS_ASSUMED_RANK
3118 && strcmp ("_data", ref->u.c.component->name) == 0)
3119 /* Skip the first ref of a _data component, because for class
3120 arrays that one is already done by introducing a temporary
3121 array descriptor. */
3122 break;
3123
3124 if (ref->u.c.sym->attr.extension)
3125 conv_parent_component_references (se, ref);
3126
3127 gfc_conv_component_ref (se, ref);
3128 if (!ref->next && ref->u.c.sym->attr.codimension
3129 && se->want_pointer && se->descriptor_only)
3130 return;
3131
3132 break;
3133
3134 case REF_SUBSTRING:
3135 gfc_conv_substring (se, ref, expr->ts.kind,
3136 expr->symtree->name, &expr->where);
3137 break;
3138
3139 case REF_INQUIRY:
3140 conv_inquiry (se, ref, expr, ts);
3141 break;
3142
3143 default:
3144 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3144, __FUNCTION__))
;
3145 break;
3146 }
3147 first_time = false;
3148 ref = ref->next;
3149 }
3150 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3151 separately. */
3152 if (se->want_pointer)
3153 {
3154 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3155 gfc_conv_string_parameter (se);
3156 else
3157 se->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, se->expr);
3158 }
3159}
3160
3161
3162/* Unary ops are easy... Or they would be if ! was a valid op. */
3163
3164static void
3165gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3166{
3167 gfc_se operand;
3168 tree type;
3169
3170 gcc_assert (expr->ts.type != BT_CHARACTER)((void)(!(expr->ts.type != BT_CHARACTER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3170, __FUNCTION__), 0 : 0))
;
3171 /* Initialize the operand. */
3172 gfc_init_se (&operand, se);
3173 gfc_conv_expr_val (&operand, expr->value.op.op1);
3174 gfc_add_block_to_block (&se->pre, &operand.pre);
3175
3176 type = gfc_typenode_for_spec (&expr->ts);
3177
3178 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3179 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3180 All other unary operators have an equivalent GIMPLE unary operator. */
3181 if (code == TRUTH_NOT_EXPR)
3182 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3183 build_int_cst (type, 0));
3184 else
3185 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3186
3187}
3188
3189/* Expand power operator to optimal multiplications when a value is raised
3190 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3191 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3192 Programming", 3rd Edition, 1998. */
3193
3194/* This code is mostly duplicated from expand_powi in the backend.
3195 We establish the "optimal power tree" lookup table with the defined size.
3196 The items in the table are the exponents used to calculate the index
3197 exponents. Any integer n less than the value can get an "addition chain",
3198 with the first node being one. */
3199#define POWI_TABLE_SIZE256 256
3200
3201/* The table is from builtins.cc. */
3202static const unsigned char powi_table[POWI_TABLE_SIZE256] =
3203 {
3204 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3205 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3206 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3207 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3208 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3209 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3210 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3211 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3212 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3213 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3214 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3215 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3216 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3217 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3218 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3219 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3220 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3221 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3222 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3223 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3224 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3225 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3226 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3227 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3228 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3229 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3230 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3231 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3232 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3233 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3234 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3235 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3236 };
3237
3238/* If n is larger than lookup table's max index, we use the "window
3239 method". */
3240#define POWI_WINDOW_SIZE3 3
3241
3242/* Recursive function to expand the power operator. The temporary
3243 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3244static tree
3245gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INTlong n, tree * tmpvar)
3246{
3247 tree op0;
3248 tree op1;
3249 tree tmp;
3250 int digit;
3251
3252 if (n < POWI_TABLE_SIZE256)
3253 {
3254 if (tmpvar[n])
3255 return tmpvar[n];
3256
3257 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3258 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3259 }
3260 else if (n & 1)
3261 {
3262 digit = n & ((1 << POWI_WINDOW_SIZE3) - 1);
3263 op0 = gfc_conv_powi (se, n - digit, tmpvar);
3264 op1 = gfc_conv_powi (se, digit, tmpvar);
3265 }
3266 else
3267 {
3268 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3269 op1 = op0;
3270 }
3271
3272 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0)((contains_struct_check ((op0), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3272, __FUNCTION__))->typed.type)
, op0, op1);
3273 tmp = gfc_evaluate_now (tmp, &se->pre);
3274
3275 if (n < POWI_TABLE_SIZE256)
3276 tmpvar[n] = tmp;
3277
3278 return tmp;
3279}
3280
3281
3282/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3283 return 1. Else return 0 and a call to runtime library functions
3284 will have to be built. */
3285static int
3286gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3287{
3288 tree cond;
3289 tree tmp;
3290 tree type;
3291 tree vartmp[POWI_TABLE_SIZE256];
3292 HOST_WIDE_INTlong m;
3293 unsigned HOST_WIDE_INTlong n;
3294 int sgn;
3295 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3296
3297 /* If exponent is too large, we won't expand it anyway, so don't bother
3298 with large integer values. */
3299 if (!wi::fits_shwi_p (wrhs))
3300 return 0;
3301
3302 m = wrhs.to_shwi ();
3303 /* Use the wide_int's routine to reliably get the absolute value on all
3304 platforms. Then convert it to a HOST_WIDE_INT like above. */
3305 n = wi::abs (wrhs).to_shwi ();
3306
3307 type = TREE_TYPE (lhs)((contains_struct_check ((lhs), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3307, __FUNCTION__))->typed.type)
;
3308 sgn = tree_int_cst_sgn (rhs);
3309
3310 if (((FLOAT_TYPE_P (type)((((enum tree_code) (type)->base.code) == REAL_TYPE) || ((
((enum tree_code) (type)->base.code) == COMPLEX_TYPE || ((
(enum tree_code) (type)->base.code) == VECTOR_TYPE)) &&
(((enum tree_code) (((contains_struct_check ((type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3310, __FUNCTION__))->typed.type))->base.code) == REAL_TYPE
)))
&& !flag_unsafe_math_optimizationsglobal_options.x_flag_unsafe_math_optimizations)
3311 || optimize_sizeglobal_options.x_optimize_size) && (m > 2 || m < -1))
3312 return 0;
3313
3314 /* rhs == 0 */
3315 if (sgn == 0)
3316 {
3317 se->expr = gfc_build_const (type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]);
3318 return 1;
3319 }
3320
3321 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3322 if ((sgn == -1) && (TREE_CODE (type)((enum tree_code) (type)->base.code) == INTEGER_TYPE))
3323 {
3324 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3325 lhs, build_int_cst (TREE_TYPE (lhs)((contains_struct_check ((lhs), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3325, __FUNCTION__))->typed.type)
, -1));
3326 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3327 lhs, build_int_cst (TREE_TYPE (lhs)((contains_struct_check ((lhs), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3327, __FUNCTION__))->typed.type)
, 1));
3328
3329 /* If rhs is even,
3330 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3331 if ((n & 1) == 0)
3332 {
3333 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3334 logical_type_node, tmp, cond);
3335 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3336 tmp, build_int_cst (type, 1),
3337 build_int_cst (type, 0));
3338 return 1;
3339 }
3340 /* If rhs is odd,
3341 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3342 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3343 build_int_cst (type, -1),
3344 build_int_cst (type, 0));
3345 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3346 cond, build_int_cst (type, 1), tmp);
3347 return 1;
3348 }
3349
3350 memset (vartmp, 0, sizeof (vartmp));
3351 vartmp[1] = lhs;
3352 if (sgn == -1)
3353 {
3354 tmp = gfc_build_const (type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]);
3355 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3356 vartmp[1]);
3357 }
3358
3359 se->expr = gfc_conv_powi (se, n, vartmp);
3360
3361 return 1;
3362}
3363
3364
3365/* Power op (**). Constant integer exponent has special handling. */
3366
3367static void
3368gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3369{
3370 tree gfc_int4_type_node;
3371 int kind;
3372 int ikind;
3373 int res_ikind_1, res_ikind_2;
3374 gfc_se lse;
3375 gfc_se rse;
3376 tree fndecl = NULL__null;
3377
3378 gfc_init_se (&lse, se);
3379 gfc_conv_expr_val (&lse, expr->value.op.op1);
3380 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3381 gfc_add_block_to_block (&se->pre, &lse.pre);
3382
3383 gfc_init_se (&rse, se);
3384 gfc_conv_expr_val (&rse, expr->value.op.op2);
3385 gfc_add_block_to_block (&se->pre, &rse.pre);
3386
3387 if (expr->value.op.op2->ts.type == BT_INTEGER
3388 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3389 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3390 return;
3391
3392 if (INTEGER_CST_P (lse.expr)(((enum tree_code) (lse.expr)->base.code) == INTEGER_CST)
3393 && TREE_CODE (TREE_TYPE (rse.expr))((enum tree_code) (((contains_struct_check ((rse.expr), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3393, __FUNCTION__))->typed.type))->base.code)
== INTEGER_TYPE)
3394 {
3395 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3396 HOST_WIDE_INTlong v, w;
3397 int kind, ikind, bit_size;
3398
3399 v = wlhs.to_shwi ();
3400 w = abs (v);
3401
3402 kind = expr->value.op.op1->ts.kind;
3403 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3404 bit_size = gfc_integer_kinds[ikind].bit_size;
3405
3406 if (v == 1)
3407 {
3408 /* 1**something is always 1. */
3409 se->expr = build_int_cst (TREE_TYPE (lse.expr)((contains_struct_check ((lse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3409, __FUNCTION__))->typed.type)
, 1);
3410 return;
3411 }
3412 else if (v == -1)
3413 {
3414 /* (-1)**n is 1 - ((n & 1) << 1) */
3415 tree type;
3416 tree tmp;
3417
3418 type = TREE_TYPE (lse.expr)((contains_struct_check ((lse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3418, __FUNCTION__))->typed.type)
;
3419 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3420 rse.expr, build_int_cst (type, 1));
3421 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3422 tmp, build_int_cst (type, 1));
3423 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3424 build_int_cst (type, 1), tmp);
3425 se->expr = tmp;
3426 return;
3427 }
3428 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3429 {
3430 /* Here v is +/- 2**e. The further simplification uses
3431 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3432 1<<(4*n), etc., but we have to make sure to return zero
3433 if the number of bits is too large. */
3434 tree lshift;
3435 tree type;
3436 tree shift;
3437 tree ge;
3438 tree cond;
3439 tree num_bits;
3440 tree cond2;
3441 tree tmp1;
3442
3443 type = TREE_TYPE (lse.expr)((contains_struct_check ((lse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3443, __FUNCTION__))->typed.type)
;
3444
3445 if (w == 2)
3446 shift = rse.expr;
3447 else if (w == 4)
3448 shift = fold_build2_loc (input_location, PLUS_EXPR,
3449 TREE_TYPE (rse.expr)((contains_struct_check ((rse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3449, __FUNCTION__))->typed.type)
,
3450 rse.expr, rse.expr);
3451 else
3452 {
3453 /* use popcount for fast log2(w) */
3454 int e = wi::popcount (w-1);
3455 shift = fold_build2_loc (input_location, MULT_EXPR,
3456 TREE_TYPE (rse.expr)((contains_struct_check ((rse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3456, __FUNCTION__))->typed.type)
,
3457 build_int_cst (TREE_TYPE (rse.expr)((contains_struct_check ((rse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3457, __FUNCTION__))->typed.type)
, e),
3458 rse.expr);
3459 }
3460
3461 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3462 build_int_cst (type, 1), shift);
3463 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3464 rse.expr, build_int_cst (type, 0));
3465 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3466 build_int_cst (type, 0));
3467 num_bits = build_int_cst (TREE_TYPE (rse.expr)((contains_struct_check ((rse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3467, __FUNCTION__))->typed.type)
, TYPE_PRECISION (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3467, __FUNCTION__))->type_common.precision)
);
3468 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3469 rse.expr, num_bits);
3470 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3471 build_int_cst (type, 0), cond);
3472 if (v > 0)
3473 {
3474 se->expr = tmp1;
3475 }
3476 else
3477 {
3478 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3479 tree tmp2;
3480 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3481 rse.expr, build_int_cst (type, 1));
3482 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3483 tmp2, build_int_cst (type, 1));
3484 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3485 build_int_cst (type, 1), tmp2);
3486 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3487 tmp1, tmp2);
3488 }
3489 return;
3490 }
3491 }
3492
3493 gfc_int4_type_node = gfc_get_int_type (4);
3494
3495 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3496 library routine. But in the end, we have to convert the result back
3497 if this case applies -- with res_ikind_K, we keep track whether operand K
3498 falls into this case. */
3499 res_ikind_1 = -1;
3500 res_ikind_2 = -1;
3501
3502 kind = expr->value.op.op1->ts.kind;
3503 switch (expr->value.op.op2->ts.type)
3504 {
3505 case BT_INTEGER:
3506 ikind = expr->value.op.op2->ts.kind;
3507 switch (ikind)
3508 {
3509 case 1:
3510 case 2:
3511 rse.expr = convert (gfc_int4_type_node, rse.expr);
3512 res_ikind_2 = ikind;
3513 /* Fall through. */
3514
3515 case 4:
3516 ikind = 0;
3517 break;
3518
3519 case 8:
3520 ikind = 1;
3521 break;
3522
3523 case 16:
3524 ikind = 2;
3525 break;
3526
3527 default:
3528 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3528, __FUNCTION__))
;
3529 }
3530 switch (kind)
3531 {
3532 case 1:
3533 case 2:
3534 if (expr->value.op.op1->ts.type == BT_INTEGER)
3535 {
3536 lse.expr = convert (gfc_int4_type_node, lse.expr);
3537 res_ikind_1 = kind;
3538 }
3539 else
3540 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3540, __FUNCTION__))
;
3541 /* Fall through. */
3542
3543 case 4:
3544 kind = 0;
3545 break;
3546
3547 case 8:
3548 kind = 1;
3549 break;
3550
3551 case 10:
3552 kind = 2;
3553 break;
3554
3555 case 16:
3556 kind = 3;
3557 break;
3558
3559 default:
3560 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3560, __FUNCTION__))
;
3561 }
3562
3563 switch (expr->value.op.op1->ts.type)
3564 {
3565 case BT_INTEGER:
3566 if (kind == 3) /* Case 16 was not handled properly above. */
3567 kind = 2;
3568 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3569 break;
3570
3571 case BT_REAL:
3572 /* Use builtins for real ** int4. */
3573 if (ikind == 0)
3574 {
3575 switch (kind)
3576 {
3577 case 0:
3578 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3579 break;
3580
3581 case 1:
3582 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3583 break;
3584
3585 case 2:
3586 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3587 break;
3588
3589 case 3:
3590 /* Use the __builtin_powil() only if real(kind=16) is
3591 actually the C long double type. */
3592 if (!gfc_real16_is_float128)
3593 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3594 break;
3595
3596 default:
3597 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3597, __FUNCTION__))
;
3598 }
3599 }
3600
3601 /* If we don't have a good builtin for this, go for the
3602 library function. */
3603 if (!fndecl)
3604 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3605 break;
3606
3607 case BT_COMPLEX:
3608 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3609 break;
3610
3611 default:
3612 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3612, __FUNCTION__))
;
3613 }
3614 break;
3615
3616 case BT_REAL:
3617 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3618 break;
3619
3620 case BT_COMPLEX:
3621 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3622 break;
3623
3624 default:
3625 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3625, __FUNCTION__))
;
3626 break;
3627 }
3628
3629 se->expr = build_call_expr_loc (input_location,
3630 fndecl, 2, lse.expr, rse.expr);
3631
3632 /* Convert the result back if it is of wrong integer kind. */
3633 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3634 {
3635 /* We want the maximum of both operand kinds as result. */
3636 if (res_ikind_1 < res_ikind_2)
3637 res_ikind_1 = res_ikind_2;
3638 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3639 }
3640}
3641
3642
3643/* Generate code to allocate a string temporary. */
3644
3645tree
3646gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3647{
3648 tree var;
3649 tree tmp;
3650
3651 if (gfc_can_put_var_on_stack (len))
3652 {
3653 /* Create a temporary variable to hold the result. */
3654 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3655 TREE_TYPE (len)((contains_struct_check ((len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3655, __FUNCTION__))->typed.type)
, len,
3656 build_int_cst (TREE_TYPE (len)((contains_struct_check ((len), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3656, __FUNCTION__))->typed.type)
, 1));
3657 tmp = build_range_type (gfc_charlen_type_node, size_zero_nodeglobal_trees[TI_SIZE_ZERO], tmp);
3658
3659 if (TREE_CODE (TREE_TYPE (type))((enum tree_code) (((contains_struct_check ((type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3659, __FUNCTION__))->typed.type))->base.code)
== ARRAY_TYPE)
3660 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type))((contains_struct_check ((((contains_struct_check ((type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3660, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3660, __FUNCTION__))->typed.type)
, tmp);
3661 else
3662 tmp = build_array_type (TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3662, __FUNCTION__))->typed.type)
, tmp);
3663
3664 var = gfc_create_var (tmp, "str");
3665 var = gfc_build_addr_expr (type, var);
3666 }
3667 else
3668 {
3669 /* Allocate a temporary to hold the result. */
3670 var = gfc_create_var (type, "pstr");
3671 gcc_assert (POINTER_TYPE_P (type))((void)(!((((enum tree_code) (type)->base.code) == POINTER_TYPE
|| ((enum tree_code) (type)->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3671, __FUNCTION__), 0 : 0))
;
3672 tmp = TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3672, __FUNCTION__))->typed.type)
;
3673 if (TREE_CODE (tmp)((enum tree_code) (tmp)->base.code) == ARRAY_TYPE)
3674 tmp = TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3674, __FUNCTION__))->typed.type)
;
3675 tmp = TYPE_SIZE_UNIT (tmp)((tree_class_check ((tmp), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3675, __FUNCTION__))->type_common.size_unit)
;
3676 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_nodeglobal_trees[TI_SIZE_TYPE],
3677 fold_convert (size_type_node, len)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], len)
,
3678 fold_convert (size_type_node, tmp)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], tmp)
);
3679 tmp = gfc_call_malloc (&se->pre, type, tmp);
3680 gfc_add_modify (&se->pre, var, tmp);
3681
3682 /* Free the temporary afterwards. */
3683 tmp = gfc_call_free (var);
3684 gfc_add_expr_to_block (&se->post, tmp);
3685 }
3686
3687 return var;
3688}
3689
3690
3691/* Handle a string concatenation operation. A temporary will be allocated to
3692 hold the result. */
3693
3694static void
3695gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3696{
3697 gfc_se lse, rse;
3698 tree len, type, var, tmp, fndecl;
3699
3700 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER((void)(!(expr->value.op.op1->ts.type == BT_CHARACTER &&
expr->value.op.op2->ts.type == BT_CHARACTER) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3701, __FUNCTION__), 0 : 0))
3701 && expr->value.op.op2->ts.type == BT_CHARACTER)((void)(!(expr->value.op.op1->ts.type == BT_CHARACTER &&
expr->value.op.op2->ts.type == BT_CHARACTER) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3701, __FUNCTION__), 0 : 0))
;
3702 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind)((void)(!(expr->value.op.op1->ts.kind == expr->value
.op.op2->ts.kind) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3702, __FUNCTION__), 0 : 0))
;
3703
3704 gfc_init_se (&lse, se);
3705 gfc_conv_expr (&lse, expr->value.op.op1);
3706 gfc_conv_string_parameter (&lse);
3707 gfc_init_se (&rse, se);
3708 gfc_conv_expr (&rse, expr->value.op.op2);
3709 gfc_conv_string_parameter (&rse);
3710
3711 gfc_add_block_to_block (&se->pre, &lse.pre);
3712 gfc_add_block_to_block (&se->pre, &rse.pre);
3713
3714 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3715 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type))((tree_check5 ((((tree_check ((type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3715, __FUNCTION__, (ARRAY_TYPE)))->type_non_common.values
)), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3715, __FUNCTION__, (INTEGER_TYPE), (ENUMERAL_TYPE), (BOOLEAN_TYPE
), (REAL_TYPE), (FIXED_POINT_TYPE)))->type_non_common.maxval
)
;
3716 if (len == NULL_TREE(tree) __null)
3717 {
3718 len = fold_build2_loc (input_location, PLUS_EXPR,
3719 gfc_charlen_type_node,
3720 fold_convert (gfc_charlen_type_node,fold_convert_loc (((location_t) 0), gfc_charlen_type_node, lse
.string_length)
3721 lse.string_length)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, lse
.string_length)
,
3722 fold_convert (gfc_charlen_type_node,fold_convert_loc (((location_t) 0), gfc_charlen_type_node, rse
.string_length)
3723 rse.string_length)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, rse
.string_length)
);
3724 }
3725
3726 type = build_pointer_type (type);
3727
3728 var = gfc_conv_string_tmp (se, type, len);
3729
3730 /* Do the actual concatenation. */
3731 if (expr->ts.kind == 1)
3732 fndecl = gfor_fndecl_concat_string;
3733 else if (expr->ts.kind == 4)
3734 fndecl = gfor_fndecl_concat_string_char4;
3735 else
3736 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3736, __FUNCTION__))
;
3737
3738 tmp = build_call_expr_loc (input_location,
3739 fndecl, 6, len, var, lse.string_length, lse.expr,
3740 rse.string_length, rse.expr);
3741 gfc_add_expr_to_block (&se->pre, tmp);
3742
3743 /* Add the cleanup for the operands. */
3744 gfc_add_block_to_block (&se->pre, &rse.post);
3745 gfc_add_block_to_block (&se->pre, &lse.post);
3746
3747 se->expr = var;
3748 se->string_length = len;
3749}
3750
3751/* Translates an op expression. Common (binary) cases are handled by this
3752 function, others are passed on. Recursion is used in either case.
3753 We use the fact that (op1.ts == op2.ts) (except for the power
3754 operator **).
3755 Operators need no special handling for scalarized expressions as long as
3756 they call gfc_conv_simple_val to get their operands.
3757 Character strings get special handling. */
3758
3759static void
3760gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3761{
3762 enum tree_code code;
3763 gfc_se lse;
3764 gfc_se rse;
3765 tree tmp, type;
3766 int lop;
3767 int checkstring;
3768
3769 checkstring = 0;
3770 lop = 0;
3771 switch (expr->value.op.op)
3772 {
3773 case INTRINSIC_PARENTHESES:
3774 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3775 && flag_protect_parensglobal_options.x_flag_protect_parens)
3776 {
3777 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3778 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)))((void)(!(((((enum tree_code) (((contains_struct_check ((se->
expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__))->typed.type))->base.code) == REAL_TYPE
) || ((((enum tree_code) (((contains_struct_check ((se->expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__))->typed.type))->base.code) == COMPLEX_TYPE
|| (((enum tree_code) (((contains_struct_check ((se->expr
), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__))->typed.type))->base.code) == VECTOR_TYPE
)) && (((enum tree_code) (((contains_struct_check (((
(contains_struct_check ((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__))->typed.type))->base.code) == REAL_TYPE
)))) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3778, __FUNCTION__), 0 : 0))
;
3779 return;
3780 }
3781
3782 /* Fallthrough. */
3783 case INTRINSIC_UPLUS:
3784 gfc_conv_expr (se, expr->value.op.op1);
3785 return;
3786
3787 case INTRINSIC_UMINUS:
3788 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3789 return;
3790
3791 case INTRINSIC_NOT:
3792 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3793 return;
3794
3795 case INTRINSIC_PLUS:
3796 code = PLUS_EXPR;
3797 break;
3798
3799 case INTRINSIC_MINUS:
3800 code = MINUS_EXPR;
3801 break;
3802
3803 case INTRINSIC_TIMES:
3804 code = MULT_EXPR;
3805 break;
3806
3807 case INTRINSIC_DIVIDE:
3808 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3809 an integer, we must round towards zero, so we use a
3810 TRUNC_DIV_EXPR. */
3811 if (expr->ts.type == BT_INTEGER)
3812 code = TRUNC_DIV_EXPR;
3813 else
3814 code = RDIV_EXPR;
3815 break;
3816
3817 case INTRINSIC_POWER:
3818 gfc_conv_power_op (se, expr);
3819 return;
3820
3821 case INTRINSIC_CONCAT:
3822 gfc_conv_concat_op (se, expr);
3823 return;
3824
3825 case INTRINSIC_AND:
3826 code = flag_frontend_optimizeglobal_options.x_flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3827 lop = 1;
3828 break;
3829
3830 case INTRINSIC_OR:
3831 code = flag_frontend_optimizeglobal_options.x_flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3832 lop = 1;
3833 break;
3834
3835 /* EQV and NEQV only work on logicals, but since we represent them
3836 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3837 case INTRINSIC_EQ:
3838 case INTRINSIC_EQ_OS:
3839 case INTRINSIC_EQV:
3840 code = EQ_EXPR;
3841 checkstring = 1;
3842 lop = 1;
3843 break;
3844
3845 case INTRINSIC_NE:
3846 case INTRINSIC_NE_OS:
3847 case INTRINSIC_NEQV:
3848 code = NE_EXPR;
3849 checkstring = 1;
3850 lop = 1;
3851 break;
3852
3853 case INTRINSIC_GT:
3854 case INTRINSIC_GT_OS:
3855 code = GT_EXPR;
3856 checkstring = 1;
3857 lop = 1;
3858 break;
3859
3860 case INTRINSIC_GE:
3861 case INTRINSIC_GE_OS:
3862 code = GE_EXPR;
3863 checkstring = 1;
3864 lop = 1;
3865 break;
3866
3867 case INTRINSIC_LT:
3868 case INTRINSIC_LT_OS:
3869 code = LT_EXPR;
3870 checkstring = 1;
3871 lop = 1;
3872 break;
3873
3874 case INTRINSIC_LE:
3875 case INTRINSIC_LE_OS:
3876 code = LE_EXPR;
3877 checkstring = 1;
3878 lop = 1;
3879 break;
3880
3881 case INTRINSIC_USER:
3882 case INTRINSIC_ASSIGN:
3883 /* These should be converted into function calls by the frontend. */
3884 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3884, __FUNCTION__))
;
3885
3886 default:
3887 fatal_error (input_location, "Unknown intrinsic op");
3888 return;
3889 }
3890
3891 /* The only exception to this is **, which is handled separately anyway. */
3892 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type)((void)(!(expr->value.op.op1->ts.type == expr->value
.op.op2->ts.type) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3892, __FUNCTION__), 0 : 0))
;
3893
3894 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3895 checkstring = 0;
3896
3897 /* lhs */
3898 gfc_init_se (&lse, se);
3899 gfc_conv_expr (&lse, expr->value.op.op1);
3900 gfc_add_block_to_block (&se->pre, &lse.pre);
3901
3902 /* rhs */
3903 gfc_init_se (&rse, se);
3904 gfc_conv_expr (&rse, expr->value.op.op2);
3905 gfc_add_block_to_block (&se->pre, &rse.pre);
3906
3907 if (checkstring)
3908 {
3909 gfc_conv_string_parameter (&lse);
3910 gfc_conv_string_parameter (&rse);
3911
3912 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3913 rse.string_length, rse.expr,
3914 expr->value.op.op1->ts.kind,
3915 code);
3916 rse.expr = build_int_cst (TREE_TYPE (lse.expr)((contains_struct_check ((lse.expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3916, __FUNCTION__))->typed.type)
, 0);
3917 gfc_add_block_to_block (&lse.post, &rse.post);
3918 }
3919
3920 type = gfc_typenode_for_spec (&expr->ts);
3921
3922 if (lop)
3923 {
3924 /* The result of logical ops is always logical_type_node. */
3925 tmp = fold_build2_loc (input_location, code, logical_type_node,
3926 lse.expr, rse.expr);
3927 se->expr = convert (type, tmp);
3928 }
3929 else
3930 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3931
3932 /* Add the post blocks. */
3933 gfc_add_block_to_block (&se->post, &rse.post);
3934 gfc_add_block_to_block (&se->post, &lse.post);
3935}
3936
3937/* If a string's length is one, we convert it to a single character. */
3938
3939tree
3940gfc_string_to_single_character (tree len, tree str, int kind)
3941{
3942
3943 if (len == NULL__null
3944 || !tree_fits_uhwi_p (len)
3945 || !POINTER_TYPE_P (TREE_TYPE (str))(((enum tree_code) (((contains_struct_check ((str), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3945, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((str), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3945, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
3946 return NULL_TREE(tree) __null;
3947
3948 if (TREE_INT_CST_LOW (len)((unsigned long) (*tree_int_cst_elt_check ((len), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3948, __FUNCTION__)))
== 1)
3949 {
3950 str = fold_convert (gfc_get_pchar_type (kind), str)fold_convert_loc (((location_t) 0), gfc_get_pchar_type (kind)
, str)
;
3951 return build_fold_indirect_ref_loc (input_location, str);
3952 }
3953
3954 if (kind == 1
3955 && TREE_CODE (str)((enum tree_code) (str)->base.code) == ADDR_EXPR
3956 && TREE_CODE (TREE_OPERAND (str, 0))((enum tree_code) ((*((const_cast<tree*> (tree_operand_check
((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3956, __FUNCTION__))))))->base.code)
== ARRAY_REF
3957 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0))((enum tree_code) ((*((const_cast<tree*> (tree_operand_check
(((*((const_cast<tree*> (tree_operand_check ((str), (0
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3957, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3957, __FUNCTION__))))))->base.code)
== STRING_CST
3958 && array_ref_low_bound (TREE_OPERAND (str, 0)(*((const_cast<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3958, __FUNCTION__)))))
)
3959 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)(*((const_cast<tree*> (tree_operand_check (((*((const_cast
<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3959, __FUNCTION__)))))), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3959, __FUNCTION__)))))
3960 && TREE_INT_CST_LOW (len)((unsigned long) (*tree_int_cst_elt_check ((len), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3960, __FUNCTION__)))
> 1
3961 && TREE_INT_CST_LOW (len)((unsigned long) (*tree_int_cst_elt_check ((len), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3961, __FUNCTION__)))
3962 == (unsigned HOST_WIDE_INTlong)
3963 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))((tree_check (((*((const_cast<tree*> (tree_operand_check
(((*((const_cast<tree*> (tree_operand_check ((str), (0
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3963, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3963, __FUNCTION__)))))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3963, __FUNCTION__, (STRING_CST)))->string.length)
)
3964 {
3965 tree ret = fold_convert (gfc_get_pchar_type (kind), str)fold_convert_loc (((location_t) 0), gfc_get_pchar_type (kind)
, str)
;
3966 ret = build_fold_indirect_ref_loc (input_location, ret);
3967 if (TREE_CODE (ret)((enum tree_code) (ret)->base.code) == INTEGER_CST)
3968 {
3969 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0)(*((const_cast<tree*> (tree_operand_check (((*((const_cast
<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3969, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3969, __FUNCTION__)))))
;
3970 int i, length = TREE_STRING_LENGTH (string_cst)((tree_check ((string_cst), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3970, __FUNCTION__, (STRING_CST)))->string.length)
;
3971 const char *ptr = TREE_STRING_POINTER (string_cst)((const char *)((tree_check ((string_cst), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3971, __FUNCTION__, (STRING_CST)))->string.str))
;
3972
3973 for (i = 1; i < length; i++)
3974 if (ptr[i] != ' ')
3975 return NULL_TREE(tree) __null;
3976
3977 return ret;
3978 }
3979 }
3980
3981 return NULL_TREE(tree) __null;
3982}
3983
3984
3985static void
3986conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3987{
3988 gcc_assert (expr)((void)(!(expr) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3988, __FUNCTION__), 0 : 0))
;
3989
3990 /* We used to modify the tree here. Now it is done earlier in
3991 the front-end, so we only check it here to avoid regressions. */
3992 if (sym->backend_decl)
3993 {
3994 gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE)((void)(!(((enum tree_code) (((contains_struct_check ((sym->
backend_decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3994, __FUNCTION__))->typed.type))->base.code) == INTEGER_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3994, __FUNCTION__), 0 : 0))
;
3995 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1)((void)(!(((tree_class_check ((((contains_struct_check ((sym->
backend_decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3995, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3995, __FUNCTION__))->base.u.bits.unsigned_flag) == 1) ?
fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3995, __FUNCTION__), 0 : 0))
;
3996 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE)((void)(!(((tree_class_check ((((contains_struct_check ((sym->
backend_decl), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3996, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3996, __FUNCTION__))->type_common.precision) == (8)) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3996, __FUNCTION__), 0 : 0))
;
3997 gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0)((void)(!(((tree_check3 ((sym->backend_decl), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3997, __FUNCTION__, (VAR_DECL), (PARM_DECL), (RESULT_DECL))
)->decl_common.decl_by_reference_flag) == 0) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 3997, __FUNCTION__), 0 : 0))
;
3998 }
3999
4000 /* If we have a constant character expression, make it into an
4001 integer of type C char. */
4002 if ((*expr)->expr_type == EXPR_CONSTANT)
4003 {
4004 gfc_typespec ts;
4005 gfc_clear_ts (&ts);
4006
4007 *expr = gfc_get_int_expr (gfc_default_character_kind, NULL__null,
4008 (*expr)->value.character.string[0]);
4009 }
4010 else if (se != NULL__null && (*expr)->expr_type == EXPR_VARIABLE)
4011 {
4012 if ((*expr)->ref == NULL__null)
4013 {
4014 se->expr = gfc_string_to_single_character
4015 (build_int_cst (integer_type_nodeinteger_types[itk_int], 1),
4016 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4017 gfc_get_symbol_decl
4018 ((*expr)->symtree->n.sym)),
4019 (*expr)->ts.kind);
4020 }
4021 else
4022 {
4023 gfc_conv_variable (se, *expr);
4024 se->expr = gfc_string_to_single_character
4025 (build_int_cst (integer_type_nodeinteger_types[itk_int], 1),
4026 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4027 se->expr),
4028 (*expr)->ts.kind);
4029 }
4030 }
4031}
4032
4033/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4034 if STR is a string literal, otherwise return -1. */
4035
4036static int
4037gfc_optimize_len_trim (tree len, tree str, int kind)
4038{
4039 if (kind == 1
4040 && TREE_CODE (str)((enum tree_code) (str)->base.code) == ADDR_EXPR
4041 && TREE_CODE (TREE_OPERAND (str, 0))((enum tree_code) ((*((const_cast<tree*> (tree_operand_check
((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4041, __FUNCTION__))))))->base.code)
== ARRAY_REF
4042 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0))((enum tree_code) ((*((const_cast<tree*> (tree_operand_check
(((*((const_cast<tree*> (tree_operand_check ((str), (0
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4042, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4042, __FUNCTION__))))))->base.code)
== STRING_CST
4043 && array_ref_low_bound (TREE_OPERAND (str, 0)(*((const_cast<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4043, __FUNCTION__)))))
)
4044 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)(*((const_cast<tree*> (tree_operand_check (((*((const_cast
<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4044, __FUNCTION__)))))), (1), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4044, __FUNCTION__)))))
4045 && tree_fits_uhwi_p (len)
4046 && tree_to_uhwi (len) >= 1
4047 && tree_to_uhwi (len)
4048 == (unsigned HOST_WIDE_INTlong)
4049 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))((tree_check (((*((const_cast<tree*> (tree_operand_check
(((*((const_cast<tree*> (tree_operand_check ((str), (0
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4049, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4049, __FUNCTION__)))))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4049, __FUNCTION__, (STRING_CST)))->string.length)
)
4050 {
4051 tree folded = fold_convert (gfc_get_pchar_type (kind), str)fold_convert_loc (((location_t) 0), gfc_get_pchar_type (kind)
, str)
;
4052 folded = build_fold_indirect_ref_loc (input_location, folded);
4053 if (TREE_CODE (folded)((enum tree_code) (folded)->base.code) == INTEGER_CST)
4054 {
4055 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0)(*((const_cast<tree*> (tree_operand_check (((*((const_cast
<tree*> (tree_operand_check ((str), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4055, __FUNCTION__)))))), (0), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4055, __FUNCTION__)))))
;
4056 int length = TREE_STRING_LENGTH (string_cst)((tree_check ((string_cst), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4056, __FUNCTION__, (STRING_CST)))->string.length)
;
4057 const char *ptr = TREE_STRING_POINTER (string_cst)((const char *)((tree_check ((string_cst), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4057, __FUNCTION__, (STRING_CST)))->string.str))
;
4058
4059 for (; length > 0; length--)
4060 if (ptr[length - 1] != ' ')
4061 break;
4062
4063 return length;
4064 }
4065 }
4066 return -1;
4067}
4068
4069/* Helper to build a call to memcmp. */
4070
4071static tree
4072build_memcmp_call (tree s1, tree s2, tree n)
4073{
4074 tree tmp;
4075
4076 if (!POINTER_TYPE_P (TREE_TYPE (s1))(((enum tree_code) (((contains_struct_check ((s1), (TS_TYPED)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4076, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((s1), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4076, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
4077 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4078 else
4079 s1 = fold_convert (pvoid_type_node, s1)fold_convert_loc (((location_t) 0), pvoid_type_node, s1);
4080
4081 if (!POINTER_TYPE_P (TREE_TYPE (s2))(((enum tree_code) (((contains_struct_check ((s2), (TS_TYPED)
, "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4081, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((s2), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4081, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
4082 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4083 else
4084 s2 = fold_convert (pvoid_type_node, s2)fold_convert_loc (((location_t) 0), pvoid_type_node, s2);
4085
4086 n = fold_convert (size_type_node, n)fold_convert_loc (((location_t) 0), global_trees[TI_SIZE_TYPE
], n)
;
4087
4088 tmp = build_call_expr_loc (input_location,
4089 builtin_decl_explicit (BUILT_IN_MEMCMP),
4090 3, s1, s2, n);
4091
4092 return fold_convert (integer_type_node, tmp)fold_convert_loc (((location_t) 0), integer_types[itk_int], tmp
)
;
4093}
4094
4095/* Compare two strings. If they are all single characters, the result is the
4096 subtraction of them. Otherwise, we build a library call. */
4097
4098tree
4099gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4100 enum tree_code code)
4101{
4102 tree sc1;
4103 tree sc2;
4104 tree fndecl;
4105
4106 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)))((void)(!((((enum tree_code) (((contains_struct_check ((str1)
, (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4106, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((str1), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4106, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4106, __FUNCTION__), 0 : 0))
;
4107 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)))((void)(!((((enum tree_code) (((contains_struct_check ((str2)
, (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4107, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((str2), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4107, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4107, __FUNCTION__), 0 : 0))
;
4108
4109 sc1 = gfc_string_to_single_character (len1, str1, kind);
4110 sc2 = gfc_string_to_single_character (len2, str2, kind);
4111
4112 if (sc1 != NULL_TREE(tree) __null && sc2 != NULL_TREE(tree) __null)
4113 {
4114 /* Deal with single character specially. */
4115 sc1 = fold_convert (integer_type_node, sc1)fold_convert_loc (((location_t) 0), integer_types[itk_int], sc1
)
;
4116 sc2 = fold_convert (integer_type_node, sc2)fold_convert_loc (((location_t) 0), integer_types[itk_int], sc2
)
;
4117 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_nodeinteger_types[itk_int],
4118 sc1, sc2);
4119 }
4120
4121 if ((code == EQ_EXPR || code == NE_EXPR)
4122 && optimizeglobal_options.x_optimize
4123 && INTEGER_CST_P (len1)(((enum tree_code) (len1)->base.code) == INTEGER_CST) && INTEGER_CST_P (len2)(((enum tree_code) (len2)->base.code) == INTEGER_CST))
4124 {
4125 /* If one string is a string literal with LEN_TRIM longer
4126 than the length of the second string, the strings
4127 compare unequal. */
4128 int len = gfc_optimize_len_trim (len1, str1, kind);
4129 if (len > 0 && compare_tree_int (len2, len) < 0)
4130 return integer_one_nodeglobal_trees[TI_INTEGER_ONE];
4131 len = gfc_optimize_len_trim (len2, str2, kind);
4132 if (len > 0 && compare_tree_int (len1, len) < 0)
4133 return integer_one_nodeglobal_trees[TI_INTEGER_ONE];
4134 }
4135
4136 /* We can compare via memcpy if the strings are known to be equal
4137 in length and they are
4138 - kind=1
4139 - kind=4 and the comparison is for (in)equality. */
4140
4141 if (INTEGER_CST_P (len1)(((enum tree_code) (len1)->base.code) == INTEGER_CST) && INTEGER_CST_P (len2)(((enum tree_code) (len2)->base.code) == INTEGER_CST)
4142 && tree_int_cst_equal (len1, len2)
4143 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4144 {
4145 tree tmp;
4146 tree chartype;
4147
4148 chartype = gfc_get_char_type (kind);
4149 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1)((contains_struct_check ((len1), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4149, __FUNCTION__))->typed.type)
,
4150 fold_convert (TREE_TYPE(len1),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(len1), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4150, __FUNCTION__))->typed.type), ((tree_class_check ((
chartype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4151, __FUNCTION__))->type_common.size_unit))
4151 TYPE_SIZE_UNIT(chartype))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(len1), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4150, __FUNCTION__))->typed.type), ((tree_class_check ((
chartype), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4151, __FUNCTION__))->type_common.size_unit))
,
4152 len1);
4153 return build_memcmp_call (str1, str2, tmp);
4154 }
4155
4156 /* Build a call for the comparison. */
4157 if (kind == 1)
4158 fndecl = gfor_fndecl_compare_string;
4159 else if (kind == 4)
4160 fndecl = gfor_fndecl_compare_string_char4;
4161 else
4162 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4162, __FUNCTION__))
;
4163
4164 return build_call_expr_loc (input_location, fndecl, 4,
4165 len1, str1, len2, str2);
4166}
4167
4168
4169/* Return the backend_decl for a procedure pointer component. */
4170
4171static tree
4172get_proc_ptr_comp (gfc_expr *e)
4173{
4174 gfc_se comp_se;
4175 gfc_expr *e2;
4176 expr_t old_type;
4177
4178 gfc_init_se (&comp_se, NULL__null);
4179 e2 = gfc_copy_expr (e);
4180 /* We have to restore the expr type later so that gfc_free_expr frees
4181 the exact same thing that was allocated.
4182 TODO: This is ugly. */
4183 old_type = e2->expr_type;
4184 e2->expr_type = EXPR_VARIABLE;
4185 gfc_conv_expr (&comp_se, e2);
4186 e2->expr_type = old_type;
4187 gfc_free_expr (e2);
4188 return build_fold_addr_expr_loc (input_location, comp_se.expr);
4189}
4190
4191
4192/* Convert a typebound function reference from a class object. */
4193static void
4194conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4195{
4196 gfc_ref *ref;
4197 tree var;
4198
4199 if (!VAR_P (base_object)(((enum tree_code) (base_object)->base.code) == VAR_DECL))
4200 {
4201 var = gfc_create_var (TREE_TYPE (base_object)((contains_struct_check ((base_object), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4201, __FUNCTION__))->typed.type)
, NULL__null);
4202 gfc_add_modify (&se->pre, var, base_object);
4203 }
4204 se->expr = gfc_class_vptr_get (base_object);
4205 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4206 ref = expr->ref;
4207 while (ref && ref->next)
4208 ref = ref->next;
4209 gcc_assert (ref && ref->type == REF_COMPONENT)((void)(!(ref && ref->type == REF_COMPONENT) ? fancy_abort
("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4209, __FUNCTION__), 0 : 0))
;
4210 if (ref->u.c.sym->attr.extension)
4211 conv_parent_component_references (se, ref);
4212 gfc_conv_component_ref (se, ref);
4213 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4214}
4215
4216
4217static void
4218conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4219 gfc_actual_arglist *actual_args)
4220{
4221 tree tmp;
4222
4223 if (gfc_is_proc_ptr_comp (expr))
4224 tmp = get_proc_ptr_comp (expr);
4225 else if (sym->attr.dummy)
4226 {
4227 tmp = gfc_get_symbol_decl (sym);
4228 if (sym->attr.proc_pointer)
4229 tmp = build_fold_indirect_ref_loc (input_location,
4230 tmp);
4231 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE((void)(!(((enum tree_code) (((contains_struct_check ((tmp), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4231, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
&& ((enum tree_code) (((contains_struct_check ((((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__))->typed.type))->base.code) == FUNCTION_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__), 0 : 0))
4232 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE)((void)(!(((enum tree_code) (((contains_struct_check ((tmp), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4231, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
&& ((enum tree_code) (((contains_struct_check ((((contains_struct_check
((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__))->typed.type))->base.code) == FUNCTION_TYPE
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4232, __FUNCTION__), 0 : 0))
;
4233 }
4234 else
4235 {
4236 if (!sym->backend_decl)
4237 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4238
4239 TREE_USED (sym->backend_decl)((sym->backend_decl)->base.used_flag) = 1;
4240
4241 tmp = sym->backend_decl;
4242
4243 if (sym->attr.cray_pointee)
4244 {
4245 /* TODO - make the cray pointee a pointer to a procedure,
4246 assign the pointer to it and use it for the call. This
4247 will do for now! */
4248 tmp = convert (build_pointer_type (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4248, __FUNCTION__))->typed.type)
),
4249 gfc_get_symbol_decl (sym->cp_pointer));
4250 tmp = gfc_evaluate_now (tmp, &se->pre);
4251 }
4252
4253 if (!POINTER_TYPE_P (TREE_TYPE (tmp))(((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4253, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((tmp), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4253, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
4254 {
4255 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL)((void)(!(((enum tree_code) (tmp)->base.code) == FUNCTION_DECL
) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4255, __FUNCTION__), 0 : 0))
;
4256 tmp = gfc_build_addr_expr (NULL_TREE(tree) __null, tmp);
4257 }
4258 }
4259 se->expr = tmp;
4260}
4261
4262
4263/* Initialize MAPPING. */
4264
4265void
4266gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4267{
4268 mapping->syms = NULL__null;
4269 mapping->charlens = NULL__null;
4270}
4271
4272
4273/* Free all memory held by MAPPING (but not MAPPING itself). */
4274
4275void
4276gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4277{
4278 gfc_interface_sym_mapping *sym;
4279 gfc_interface_sym_mapping *nextsym;
4280 gfc_charlen *cl;
4281 gfc_charlen *nextcl;
4282
4283 for (sym = mapping->syms; sym; sym = nextsym)
4284 {
4285 nextsym = sym->next;
4286 sym->new_sym->n.sym->formal = NULL__null;
4287 gfc_free_symbol (sym->new_sym->n.sym);
4288 gfc_free_expr (sym->expr);
4289 free (sym->new_sym);
4290 free (sym);
4291 }
4292 for (cl = mapping->charlens; cl; cl = nextcl)
4293 {
4294 nextcl = cl->next;
4295 gfc_free_expr (cl->length);
4296 free (cl);
4297 }
4298}
4299
4300
4301/* Return a copy of gfc_charlen CL. Add the returned structure to
4302 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4303
4304static gfc_charlen *
4305gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4306 gfc_charlen * cl)
4307{
4308 gfc_charlen *new_charlen;
4309
4310 new_charlen = gfc_get_charlen ()((gfc_charlen *) xcalloc (1, sizeof (gfc_charlen)));
4311 new_charlen->next = mapping->charlens;
4312 new_charlen->length = gfc_copy_expr (cl->length);
4313
4314 mapping->charlens = new_charlen;
4315 return new_charlen;
4316}
4317
4318
4319/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4320 array variable that can be used as the actual argument for dummy
4321 argument SYM. Add any initialization code to BLOCK. PACKED is as
4322 for gfc_get_nodesc_array_type and DATA points to the first element
4323 in the passed array. */
4324
4325static tree
4326gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4327 gfc_packed packed, tree data)
4328{
4329 tree type;
4330 tree var;
4331
4332 type = gfc_typenode_for_spec (&sym->ts);
4333 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4334 !sym->attr.target && !sym->attr.pointer
4335 && !sym->attr.proc_pointer);
4336
4337 var = gfc_create_var (type, "ifm");
4338 gfc_add_modify (block, var, fold_convert (type, data)fold_convert_loc (((location_t) 0), type, data));
4339
4340 return var;
4341}
4342
4343
4344/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4345 and offset of descriptorless array type TYPE given that it has the same
4346 size as DESC. Add any set-up code to BLOCK. */
4347
4348static void
4349gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4350{
4351 int n;
4352 tree dim;
4353 tree offset;
4354 tree tmp;
4355
4356 offset = gfc_index_zero_nodegfc_rank_cst[0];
4357 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4357, __FUNCTION__))->type_with_lang_specific.lang_specific
)->rank)
; n++)
4358 {
4359 dim = gfc_rank_cst[n];
4360 GFC_TYPE_ARRAY_STRIDE (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4360, __FUNCTION__))->type_with_lang_specific.lang_specific
)->stride[n])
= gfc_conv_array_stride (desc, n);
4361 if (GFC_TYPE_ARRAY_LBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4361, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[n])
== NULL_TREE(tree) __null)
4362 {
4363 GFC_TYPE_ARRAY_LBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4363, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[n])
4364 = gfc_conv_descriptor_lbound_get (desc, dim);
4365 GFC_TYPE_ARRAY_UBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4365, __FUNCTION__))->type_with_lang_specific.lang_specific
)->ubound[n])
4366 = gfc_conv_descriptor_ubound_get (desc, dim);
4367 }
4368 else if (GFC_TYPE_ARRAY_UBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4368, __FUNCTION__))->type_with_lang_specific.lang_specific
)->ubound[n])
== NULL_TREE(tree) __null)
4369 {
4370 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4371 gfc_array_index_type,
4372 gfc_conv_descriptor_ubound_get (desc, dim),
4373 gfc_conv_descriptor_lbound_get (desc, dim));
4374 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4375 gfc_array_index_type,
4376 GFC_TYPE_ARRAY_LBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4376, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[n])
, tmp);
4377 tmp = gfc_evaluate_now (tmp, block);
4378 GFC_TYPE_ARRAY_UBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4378, __FUNCTION__))->type_with_lang_specific.lang_specific
)->ubound[n])
= tmp;
4379 }
4380 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4381 GFC_TYPE_ARRAY_LBOUND (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4381, __FUNCTION__))->type_with_lang_specific.lang_specific
)->lbound[n])
,
4382 GFC_TYPE_ARRAY_STRIDE (type, n)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4382, __FUNCTION__))->type_with_lang_specific.lang_specific
)->stride[n])
);
4383 offset = fold_build2_loc (input_location, MINUS_EXPR,
4384 gfc_array_index_type, offset, tmp);
4385 }
4386 offset = gfc_evaluate_now (offset, block);
4387 GFC_TYPE_ARRAY_OFFSET (type)(((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4387, __FUNCTION__))->type_with_lang_specific.lang_specific
)->offset)
= offset;
4388}
4389
4390
4391/* Extend MAPPING so that it maps dummy argument SYM to the value stored
4392 in SE. The caller may still use se->expr and se->string_length after
4393 calling this function. */
4394
4395void
4396gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4397 gfc_symbol * sym, gfc_se * se,
4398 gfc_expr *expr)
4399{
4400 gfc_interface_sym_mapping *sm;
4401 tree desc;
4402 tree tmp;
4403 tree value;
4404 gfc_symbol *new_sym;
4405 gfc_symtree *root;
4406 gfc_symtree *new_symtree;
4407
4408 /* Create a new symbol to represent the actual argument. */
4409 new_sym = gfc_new_symbol (sym->name, NULL__null);
4410 new_sym->ts = sym->ts;
4411 new_sym->as = gfc_copy_array_spec (sym->as);
4412 new_sym->attr.referenced = 1;
4413 new_sym->attr.dimension = sym->attr.dimension;
4414 new_sym->attr.contiguous = sym->attr.contiguous;
4415 new_sym->attr.codimension = sym->attr.codimension;
4416 new_sym->attr.pointer = sym->attr.pointer;
4417 new_sym->attr.allocatable = sym->attr.allocatable;
4418 new_sym->attr.flavor = sym->attr.flavor;
4419 new_sym->attr.function = sym->attr.function;
4420
4421 /* Ensure that the interface is available and that
4422 descriptors are passed for array actual arguments. */
4423 if (sym->attr.flavor == FL_PROCEDURE)
4424 {
4425 new_sym->formal = expr->symtree->n.sym->formal;
4426 new_sym->attr.always_explicit
4427 = expr->symtree->n.sym->attr.always_explicit;
4428 }
4429
4430 /* Create a fake symtree for it. */
4431 root = NULL__null;
4432 new_symtree = gfc_new_symtree (&root, sym->name);
4433 new_symtree->n.sym = new_sym;
4434 gcc_assert (new_symtree == root)((void)(!(new_symtree == root) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4434, __FUNCTION__), 0 : 0))
;
4435
4436 /* Create a dummy->actual mapping. */
4437 sm = XCNEW (gfc_interface_sym_mapping)((gfc_interface_sym_mapping *) xcalloc (1, sizeof (gfc_interface_sym_mapping
)))
;
4438 sm->next = mapping->syms;
4439 sm->old = sym;
4440 sm->new_sym = new_symtree;
4441 sm->expr = gfc_copy_expr (expr);
4442 mapping->syms = sm;
4443
4444 /* Stabilize the argument's value. */
4445 if (!sym->attr.function && se)
4446 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4447
4448 if (sym->ts.type == BT_CHARACTER)
4449 {
4450 /* Create a copy of the dummy argument's length. */
4451 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4452 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4453
4454 /* If the length is specified as "*", record the length that
4455 the caller is passing. We should use the callee's length
4456 in all other cases. */
4457 if (!new_sym->ts.u.cl->length && se)
4458 {
4459 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4460 new_sym->ts.u.cl->backend_decl = se->string_length;
4461 }
4462 }
4463
4464 if (!se)
4465 return;
4466
4467 /* Use the passed value as-is if the argument is a function. */
4468 if (sym->attr.flavor == FL_PROCEDURE)
4469 value = se->expr;
4470
4471 /* If the argument is a pass-by-value scalar, use the value as is. */
4472 else if (!sym->attr.dimension && sym->attr.value)
4473 value = se->expr;
4474
4475 /* If the argument is either a string or a pointer to a string,
4476 convert it to a boundless character type. */
4477 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4478 {
4479 tmp = gfc_get_character_type_len (sym->ts.kind, NULL__null);
4480 tmp = build_pointer_type (tmp);
4481 if (sym->attr.pointer)
4482 value = build_fold_indirect_ref_loc (input_location,
4483 se->expr);
4484 else
4485 value = se->expr;
4486 value = fold_convert (tmp, value)fold_convert_loc (((location_t) 0), tmp, value);
4487 }
4488
4489 /* If the argument is a scalar, a pointer to an array or an allocatable,
4490 dereference it. */
4491 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4492 value = build_fold_indirect_ref_loc (input_location,
4493 se->expr);
4494
4495 /* For character(*), use the actual argument's descriptor. */
4496 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4497 value = build_fold_indirect_ref_loc (input_location,
4498 se->expr);
4499
4500 /* If the argument is an array descriptor, use it to determine
4501 information about the actual argument's shape. */
4502 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))(((enum tree_code) (((contains_struct_check ((se->expr), (
TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4502, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((se->expr)
, (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4502, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
4503 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))((tree_class_check ((((contains_struct_check ((((contains_struct_check
((se->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4503, __FUNCTION__))->typed.type)), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4503, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4503, __FUNCTION__))->type_common.lang_flag_1)
)
4504 {
4505 /* Get the actual argument's descriptor. */
4506 desc = build_fold_indirect_ref_loc (input_location,
4507 se->expr);
4508
4509 /* Create the replacement variable. */
4510 tmp = gfc_conv_descriptor_data_get (desc);
4511 value = gfc_get_interface_mapping_array (&se->pre, sym,
4512 PACKED_NO, tmp);
4513
4514 /* Use DESC to work out the upper bounds, strides and offset. */
4515 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value)((contains_struct_check ((value), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4515, __FUNCTION__))->typed.type)
, desc);
4516 }
4517 else
4518 /* Otherwise we have a packed array. */
4519 value = gfc_get_interface_mapping_array (&se->pre, sym,
4520 PACKED_FULL, se->expr);
4521
4522 new_sym->backend_decl = value;
4523}
4524
4525
4526/* Called once all dummy argument mappings have been added to MAPPING,
4527 but before the mapping is used to evaluate expressions. Pre-evaluate
4528 the length of each argument, adding any initialization code to PRE and
4529 any finalization code to POST. */
4530
4531static void
4532gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4533 stmtblock_t * pre, stmtblock_t * post)
4534{
4535 gfc_interface_sym_mapping *sym;
4536 gfc_expr *expr;
4537 gfc_se se;
4538
4539 for (sym = mapping->syms; sym; sym = sym->next)
4540 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4541 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4542 {
4543 expr = sym->new_sym->n.sym->ts.u.cl->length;
4544 gfc_apply_interface_mapping_to_expr (mapping, expr);
4545 gfc_init_se (&se, NULL__null);
4546 gfc_conv_expr (&se, expr);
4547 se.expr = fold_convert (gfc_charlen_type_node, se.expr)fold_convert_loc (((location_t) 0), gfc_charlen_type_node, se
.expr)
;
4548 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4549 gfc_add_block_to_block (pre, &se.pre);
4550 gfc_add_block_to_block (post, &se.post);
4551
4552 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4553 }
4554}
4555
4556
4557/* Like gfc_apply_interface_mapping_to_expr, but applied to
4558 constructor C. */
4559
4560static void
4561gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4562 gfc_constructor_base base)
4563{
4564 gfc_constructor *c;
4565 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4566 {
4567 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4568 if (c->iterator)
4569 {
4570 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4571 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4572 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4573 }
4574 }
4575}
4576
4577
4578/* Like gfc_apply_interface_mapping_to_expr, but applied to
4579 reference REF. */
4580
4581static void
4582gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4583 gfc_ref * ref)
4584{
4585 int n;
4586
4587 for (; ref; ref = ref->next)
4588 switch (ref->type)
4589 {
4590 case REF_ARRAY:
4591 for (n = 0; n < ref->u.ar.dimen; n++)
4592 {
4593 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4594 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4595 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4596 }
4597 break;
4598
4599 case REF_COMPONENT:
4600 case REF_INQUIRY:
4601 break;
4602
4603 case REF_SUBSTRING:
4604 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4605 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4606 break;
4607 }
4608}
4609
4610
4611/* Convert intrinsic function calls into result expressions. */
4612
4613static bool
4614gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4615{
4616 gfc_symbol *sym;
4617 gfc_expr *new_expr;
4618 gfc_expr *arg1;
4619 gfc_expr *arg2;
4620 int d, dup;
4621
4622 arg1 = expr->value.function.actual->expr;
4623 if (expr->value.function.actual->next)
4624 arg2 = expr->value.function.actual->next->expr;
4625 else
4626 arg2 = NULL__null;
4627
4628 sym = arg1->symtree->n.sym;
4629
4630 if (sym->attr.dummy)
4631 return false;
4632
4633 new_expr = NULL__null;
4634
4635 switch (expr->value.function.isym->id)
4636 {
4637 case GFC_ISYM_LEN:
4638 /* TODO figure out why this condition is necessary. */
4639 if (sym->attr.function
4640 && (arg1->ts.u.cl->length == NULL__null
4641 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4642 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4643 return false;
4644
4645 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4646 break;
4647
4648 case GFC_ISYM_LEN_TRIM:
4649 new_expr = gfc_copy_expr (arg1);
4650 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4651
4652 if (!new_expr)
4653 return false;
4654
4655 gfc_replace_expr (arg1, new_expr);
4656 return true;
4657
4658 case GFC_ISYM_SIZE:
4659 if (!sym->as || sym->as->rank == 0)
4660 return false;
4661
4662 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4663 {
4664 dup = mpz_get_si__gmpz_get_si (arg2->value.integer);
4665 d = dup - 1;
4666 }
4667 else
4668 {
4669 dup = sym->as->rank;
4670 d = 0;
4671 }
4672
4673 for (; d < dup; d++)
4674 {
4675 gfc_expr *tmp;
4676
4677 if (!sym->as->upper[d] || !sym->as->lower[d])
4678 {
4679 gfc_free_expr (new_expr);
4680 return false;
4681 }
4682
4683 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4684 gfc_get_int_expr (gfc_default_integer_kind,
4685 NULL__null, 1));
4686 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4687 if (new_expr)
4688 new_expr = gfc_multiply (new_expr, tmp);
4689 else
4690 new_expr = tmp;
4691 }
4692 break;
4693
4694 case GFC_ISYM_LBOUND:
4695 case GFC_ISYM_UBOUND:
4696 /* TODO These implementations of lbound and ubound do not limit if
4697 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4698
4699 if (!sym->as || sym->as->rank == 0)
4700 return false;
4701
4702 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4703 d = mpz_get_si__gmpz_get_si (arg2->value.integer) - 1;
4704 else
4705 return false;
4706
4707 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4708 {
4709 if (sym->as->lower[d])
4710 new_expr = gfc_copy_expr (sym->as->lower[d]);
4711 }
4712 else
4713 {
4714 if (sym->as->upper[d])
4715 new_expr = gfc_copy_expr (sym->as->upper[d]);
4716 }
4717 break;
4718
4719 default:
4720 break;
4721 }
4722
4723 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4724 if (!new_expr)
4725 return false;
4726
4727 gfc_replace_expr (expr, new_expr);
4728 return true;
4729}
4730
4731
4732static void
4733gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4734 gfc_interface_mapping * mapping)
4735{
4736 gfc_formal_arglist *f;
4737 gfc_actual_arglist *actual;
4738
4739 actual = expr->value.function.actual;
4740 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4741
4742 for (; f && actual; f = f->next, actual = actual->next)
4743 {
4744 if (!actual->expr)
4745 continue;
4746
4747 gfc_add_interface_mapping (mapping, f->sym, NULL__null, actual->expr);
4748 }
4749
4750 if (map_expr->symtree->n.sym->attr.dimension)
4751 {
4752 int d;
4753 gfc_array_spec *as;
4754
4755 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4756
4757 for (d = 0; d < as->rank; d++)
4758 {
4759 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4760 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4761 }
4762
4763 expr->value.function.esym->as = as;
4764 }
4765
4766 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4767 {
4768 expr->value.function.esym->ts.u.cl->length
4769 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4770
4771 gfc_apply_interface_mapping_to_expr (mapping,
4772 expr->value.function.esym->ts.u.cl->length);
4773 }
4774}
4775
4776
4777/* EXPR is a copy of an expression that appeared in the interface
4778 associated with MAPPING. Walk it recursively looking for references to
4779 dummy arguments that MAPPING maps to actual arguments. Replace each such
4780 reference with a reference to the associated actual argument. */
4781
4782static void
4783gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4784 gfc_expr * expr)
4785{
4786 gfc_interface_sym_mapping *sym;
4787 gfc_actual_arglist *actual;
4788
4789 if (!expr)
4790 return;
4791
4792 /* Copying an expression does not copy its length, so do that here. */
4793 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4794 {
4795 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4796 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4797 }
4798
4799 /* Apply the mapping to any references. */
4800 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4801
4802 /* ...and to the expression's symbol, if it has one. */
4803 /* TODO Find out why the condition on expr->symtree had to be moved into
4804 the loop rather than being outside it, as originally. */
4805 for (sym = mapping->syms; sym; sym = sym->next)
4806 if (expr->symtree && sym->old == expr->symtree->n.sym)
4807 {
4808 if (sym->new_sym->n.sym->backend_decl)
4809 expr->symtree = sym->new_sym;
4810 else if (sym->expr)
4811 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4812 }
4813
4814 /* ...and to subexpressions in expr->value. */
4815 switch (expr->expr_type)
4816 {
4817 case EXPR_VARIABLE:
4818 case EXPR_CONSTANT:
4819 case EXPR_NULL:
4820 case EXPR_SUBSTRING:
4821 break;
4822
4823 case EXPR_OP:
4824 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4825 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4826 break;
4827
4828 case EXPR_FUNCTION:
4829 for (actual = expr->value.function.actual; actual; actual = actual->next)
4830 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4831
4832 if (expr->value.function.esym == NULL__null
4833 && expr->value.function.isym != NULL__null
4834 && expr->value.function.actual
4835 && expr->value.function.actual->expr
4836 && expr->value.function.actual->expr->symtree
4837 && gfc_map_intrinsic_function (expr, mapping))
4838 break;
4839
4840 for (sym = mapping->syms; sym; sym = sym->next)
4841 if (sym->old == expr->value.function.esym)
4842 {
4843 expr->value.function.esym = sym->new_sym->n.sym;
4844 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4845 expr->value.function.esym->result = sym->new_sym->n.sym;
4846 }
4847 break;
4848
4849 case EXPR_ARRAY:
4850 case EXPR_STRUCTURE:
4851 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4852 break;
4853
4854 case EXPR_COMPCALL:
4855 case EXPR_PPC:
4856 case EXPR_UNKNOWN:
4857 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4857, __FUNCTION__))
;
4858 break;
4859 }
4860
4861 return;
4862}
4863
4864
4865/* Evaluate interface expression EXPR using MAPPING. Store the result
4866 in SE. */
4867
4868void
4869gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4870 gfc_se * se, gfc_expr * expr)
4871{
4872 expr = gfc_copy_expr (expr);
4873 gfc_apply_interface_mapping_to_expr (mapping, expr);
4874 gfc_conv_expr (se, expr);
4875 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4876 gfc_free_expr (expr);
4877}
4878
4879
4880/* Returns a reference to a temporary array into which a component of
4881 an actual argument derived type array is copied and then returned
4882 after the function call. */
4883void
4884gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4885 sym_intent intent, bool formal_ptr,
4886 const gfc_symbol *fsym, const char *proc_name,
4887 gfc_symbol *sym, bool check_contiguous)
4888{
4889 gfc_se lse;
4890 gfc_se rse;
4891 gfc_ss *lss;
4892 gfc_ss *rss;
4893 gfc_loopinfo loop;
4894 gfc_loopinfo loop2;
4895 gfc_array_info *info;
4896 tree offset;
4897 tree tmp_index;
4898 tree tmp;
4899 tree base_type;
4900 tree size;
4901 stmtblock_t body;
4902 int n;
4903 int dimen;
4904 gfc_se work_se;
4905 gfc_se *parmse;
4906 bool pass_optional;
4907
4908 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4909
4910 if (pass_optional || check_contiguous)
4911 {
4912 gfc_init_se (&work_se, NULL__null);
4913 parmse = &work_se;
4914 }
4915 else
4916 parmse = se;
4917
4918 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS(1<<1))
4919 {
4920 /* We will create a temporary array, so let us warn. */
4921 char * msg;
4922
4923 if (fsym && proc_name)
4924 msg = xasprintf ("An array temporary was created for argument "
4925 "'%s' of procedure '%s'", fsym->name, proc_name);
4926 else
4927 msg = xasprintf ("An array temporary was created");
4928
4929 tmp = build_int_cst (logical_type_node, 1);
4930 gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4931 &expr->where, msg);
4932 free (msg);
4933 }
4934
4935 gfc_init_se (&lse, NULL__null);
4936 gfc_init_se (&rse, NULL__null);
4937
4938 /* Walk the argument expression. */
4939 rss = gfc_walk_expr (expr);
4940
4941 gcc_assert (rss != gfc_ss_terminator)((void)(!(rss != gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4941, __FUNCTION__), 0 : 0))
;
4942
4943 /* Initialize the scalarizer. */
4944 gfc_init_loopinfo (&loop);
4945 gfc_add_ss_to_loop (&loop, rss);
4946
4947 /* Calculate the bounds of the scalarization. */
4948 gfc_conv_ss_startstride (&loop);
4949
4950 /* Build an ss for the temporary. */
4951 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4952 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4953
4954 base_type = gfc_typenode_for_spec (&expr->ts);
4955 if (GFC_ARRAY_TYPE_P (base_type)((tree_class_check ((base_type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4955, __FUNCTION__))->type_common.lang_flag_2)
4956 || GFC_DESCRIPTOR_TYPE_P (base_type)((tree_class_check ((base_type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 4956, __FUNCTION__))->type_common.lang_flag_1)
)
4957 base_type = gfc_get_element_type (base_type);
4958
4959 if (expr->ts.type == BT_CLASS)
4960 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)expr->ts.u.derived->components->ts);
4961
4962 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4963 ? expr->ts.u.cl->backend_decl
4964 : NULL__null),
4965 loop.dimen);
4966
4967 parmse->string_length = loop.temp_ss->info->string_length;
4968
4969 /* Associate the SS with the loop. */
4970 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4971
4972 /* Setup the scalarizing loops. */
4973 gfc_conv_loop_setup (&loop, &expr->where);
4974
4975 /* Pass the temporary descriptor back to the caller. */
4976 info = &loop.temp_ss->info->data.array;
4977 parmse->expr = info->descriptor;
4978
4979 /* Setup the gfc_se structures. */
4980 gfc_copy_loopinfo_to_se (&lse, &loop);
4981 gfc_copy_loopinfo_to_se (&rse, &loop);
4982
4983 rse.ss = rss;
4984 lse.ss = loop.temp_ss;
4985 gfc_mark_ss_chain_used (rss, 1);
4986 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4987
4988 /* Start the scalarized loop body. */
4989 gfc_start_scalarized_body (&loop, &body);
4990
4991 /* Translate the expression. */
4992 gfc_conv_expr (&rse, expr);
4993
4994 /* Reset the offset for the function call since the loop
4995 is zero based on the data pointer. Note that the temp
4996 comes first in the loop chain since it is added second. */
4997 if (gfc_is_class_array_function (expr))
4998 {
4999 tmp = loop.ss->loop_chain->info->data.array.descriptor;
5000 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
5001 gfc_index_zero_nodegfc_rank_cst[0]);
5002 }
5003
5004 gfc_conv_tmp_array_ref (&lse);
5005
5006 if (intent != INTENT_OUT)
5007 {
5008 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5009 gfc_add_expr_to_block (&body, tmp);
5010 gcc_assert (rse.ss == gfc_ss_terminator)((void)(!(rse.ss == gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5010, __FUNCTION__), 0 : 0))
;
5011 gfc_trans_scalarizing_loops (&loop, &body);
5012 }
5013 else
5014 {
5015 /* Make sure that the temporary declaration survives by merging
5016 all the loop declarations into the current context. */
5017 for (n = 0; n < loop.dimen; n++)
5018 {
5019 gfc_merge_block_scope (&body);
5020 body = loop.code[loop.order[n]];
5021 }
5022 gfc_merge_block_scope (&body);
5023 }
5024
5025 /* Add the post block after the second loop, so that any
5026 freeing of allocated memory is done at the right time. */
5027 gfc_add_block_to_block (&parmse->pre, &loop.pre);
5028
5029 /**********Copy the temporary back again.*********/
5030
5031 gfc_init_se (&lse, NULL__null);
5032 gfc_init_se (&rse, NULL__null);
5033
5034 /* Walk the argument expression. */
5035 lss = gfc_walk_expr (expr);
5036 rse.ss = loop.temp_ss;
5037 lse.ss = lss;
5038
5039 /* Initialize the scalarizer. */
5040 gfc_init_loopinfo (&loop2);
5041 gfc_add_ss_to_loop (&loop2, lss);
5042
5043 dimen = rse.ss->dimen;
5044
5045 /* Skip the write-out loop for this case. */
5046 if (gfc_is_class_array_function (expr))
5047 goto class_array_fcn;
5048
5049 /* Calculate the bounds of the scalarization. */
5050 gfc_conv_ss_startstride (&loop2);
5051
5052 /* Setup the scalarizing loops. */
5053 gfc_conv_loop_setup (&loop2, &expr->where);
5054
5055 gfc_copy_loopinfo_to_se (&lse, &loop2);
5056 gfc_copy_loopinfo_to_se (&rse, &loop2);
5057
5058 gfc_mark_ss_chain_used (lss, 1);
5059 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5060
5061 /* Declare the variable to hold the temporary offset and start the
5062 scalarized loop body. */
5063 offset = gfc_create_var (gfc_array_index_type, NULL__null);
5064 gfc_start_scalarized_body (&loop2, &body);
5065
5066 /* Build the offsets for the temporary from the loop variables. The
5067 temporary array has lbounds of zero and strides of one in all
5068 dimensions, so this is very simple. The offset is only computed
5069 outside the innermost loop, so the overall transfer could be
5070 optimized further. */
5071 info = &rse.ss->info->data.array;
5072
5073 tmp_index = gfc_index_zero_nodegfc_rank_cst[0];
5074 for (n = dimen - 1; n > 0; n--)
5075 {
5076 tree tmp_str;
5077 tmp = rse.loop->loopvar[n];
5078 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5079 tmp, rse.loop->from[n]);
5080 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5081 tmp, tmp_index);
5082
5083 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5084 gfc_array_index_type,
5085 rse.loop->to[n-1], rse.loop->from[n-1]);
5086 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5087 gfc_array_index_type,
5088 tmp_str, gfc_index_one_nodegfc_rank_cst[1]);
5089
5090 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5091 gfc_array_index_type, tmp, tmp_str);
5092 }
5093
5094 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5095 gfc_array_index_type,
5096 tmp_index, rse.loop->from[0]);
5097 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5098
5099 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5100 gfc_array_index_type,
5101 rse.loop->loopvar[0], offset);
5102
5103 /* Now use the offset for the reference. */
5104 tmp = build_fold_indirect_ref_loc (input_location,
5105 info->data);
5106 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL__null);
5107
5108 if (expr->ts.type == BT_CHARACTER)
5109 rse.string_length = expr->ts.u.cl->backend_decl;
5110
5111 gfc_conv_expr (&lse, expr);
5112
5113 gcc_assert (lse.ss == gfc_ss_terminator)((void)(!(lse.ss == gfc_ss_terminator) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5113, __FUNCTION__), 0 : 0))
;
5114
5115 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5116 gfc_add_expr_to_block (&body, tmp);
5117
5118 /* Generate the copying loops. */
5119 gfc_trans_scalarizing_loops (&loop2, &body);
5120
5121 /* Wrap the whole thing up by adding the second loop to the post-block
5122 and following it by the post-block of the first loop. In this way,
5123 if the temporary needs freeing, it is done after use! */
5124 if (intent != INTENT_IN)
5125 {
5126 gfc_add_block_to_block (&parmse->post, &loop2.pre);
5127 gfc_add_block_to_block (&parmse->post, &loop2.post);
5128 }
5129
5130class_array_fcn:
5131
5132 gfc_add_block_to_block (&parmse->post, &loop.post);
5133
5134 gfc_cleanup_loop (&loop);
5135 gfc_cleanup_loop (&loop2);
5136
5137 /* Pass the string length to the argument expression. */
5138 if (expr->ts.type == BT_CHARACTER)
5139 parmse->string_length = expr->ts.u.cl->backend_decl;
5140
5141 /* Determine the offset for pointer formal arguments and set the
5142 lbounds to one. */
5143 if (formal_ptr)
5144 {
5145 size = gfc_index_one_nodegfc_rank_cst[1];
5146 offset = gfc_index_zero_nodegfc_rank_cst[0];
5147 for (n = 0; n < dimen; n++)
5148 {
5149 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5150 gfc_rank_cst[n]);
5151 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5152 gfc_array_index_type, tmp,
5153 gfc_index_one_nodegfc_rank_cst[1]);
5154 gfc_conv_descriptor_ubound_set (&parmse->pre,
5155 parmse->expr,
5156 gfc_rank_cst[n],
5157 tmp);
5158 gfc_conv_descriptor_lbound_set (&parmse->pre,
5159 parmse->expr,
5160 gfc_rank_cst[n],
5161 gfc_index_one_nodegfc_rank_cst[1]);
5162 size = gfc_evaluate_now (size, &parmse->pre);
5163 offset = fold_build2_loc (input_location, MINUS_EXPR,
5164 gfc_array_index_type,
5165 offset, size);
5166 offset = gfc_evaluate_now (offset, &parmse->pre);
5167 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5168 gfc_array_index_type,
5169 rse.loop->to[n], rse.loop->from[n]);
5170 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5171 gfc_array_index_type,
5172 tmp, gfc_index_one_nodegfc_rank_cst[1]);
5173 size = fold_build2_loc (input_location, MULT_EXPR,
5174 gfc_array_index_type, size, tmp);
5175 }
5176
5177 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5178 offset);
5179 }
5180
5181 /* We want either the address for the data or the address of the descriptor,
5182 depending on the mode of passing array arguments. */
5183 if (g77)
5184 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5185 else
5186 parmse->expr = gfc_build_addr_expr (NULL_TREE(tree) __null, parmse->expr);
5187
5188 /* Basically make this into
5189
5190 if (present)
5191 {
5192 if (contiguous)
5193 {
5194 pointer = a;
5195 }
5196 else
5197 {
5198 parmse->pre();
5199 pointer = parmse->expr;
5200 }
5201 }
5202 else
5203 pointer = NULL;
5204
5205 foo (pointer);
5206 if (present && !contiguous)
5207 se->post();
5208
5209 */
5210
5211 if (pass_optional || check_contiguous)
5212 {
5213 tree type;
5214 stmtblock_t else_block;
5215 tree pre_stmts, post_stmts;
5216 tree pointer;
5217 tree else_stmt;
5218 tree present_var = NULL_TREE(tree) __null;
5219 tree cont_var = NULL_TREE(tree) __null;
5220 tree post_cond;
5221
5222 type = TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5222, __FUNCTION__))->typed.type)
;
5223 if (POINTER_TYPE_P (type)(((enum tree_code) (type)->base.code) == POINTER_TYPE || (
(enum tree_code) (type)->base.code) == REFERENCE_TYPE)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))((tree_class_check ((((contains_struct_check ((type), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5223, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5223, __FUNCTION__))->type_common.lang_flag_1)
)
5224 type = TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5224, __FUNCTION__))->typed.type)
;
5225 pointer = gfc_create_var (type, "arg_ptr");
5226
5227 if (check_contiguous)
5228 {
5229 gfc_se cont_se, array_se;
5230 stmtblock_t if_block, else_block;
5231 tree if_stmt, else_stmt;
5232 mpz_t size;
5233 bool size_set;
5234
5235 cont_var = gfc_create_var (boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE], "contiguous");
5236
5237 /* If the size is known to be one at compile-time, set
5238 cont_var to true unconditionally. This may look
5239 inelegant, but we're only doing this during
5240 optimization, so the statements will be optimized away,
5241 and this saves complexity here. */
5242
5243 size_set = gfc_array_size (expr, &size);
5244 if (size_set && mpz_cmp_ui (size, 1)(__builtin_constant_p (1) && (1) == 0 ? ((size)->_mp_size
< 0 ? -1 : (size)->_mp_size > 0) : __gmpz_cmp_ui (size
,1))
== 0)
5245 {
5246 gfc_add_modify (&se->pre, cont_var,
5247 build_one_cst (boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE]));
5248 }
5249 else
5250 {
5251 /* cont_var = is_contiguous (expr); . */
5252 gfc_init_se (&cont_se, parmse);
5253 gfc_conv_is_contiguous_expr (&cont_se, expr);
5254 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5255 gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5256 gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5257 }
5258
5259 if (size_set)
5260 mpz_clear__gmpz_clear (size);
5261
5262 /* arrayse->expr = descriptor of a. */
5263 gfc_init_se (&array_se, se);
5264 gfc_conv_expr_descriptor (&array_se, expr);
5265 gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5266 gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5267
5268 /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5269 gfc_init_block (&if_block);
5270 if (GFC_DESCRIPTOR_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5270, __FUNCTION__))->type_common.lang_flag_1)
)
5271 gfc_add_modify (&if_block, pointer, array_se.expr);
5272 else
5273 {
5274 tmp = gfc_conv_array_data (array_se.expr);
5275 tmp = fold_convert (type, tmp)fold_convert_loc (((location_t) 0), type, tmp);
5276 gfc_add_modify (&if_block, pointer, tmp);
5277 }
5278 if_stmt = gfc_finish_block (&if_block);
5279
5280 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5281 gfc_init_block (&else_block);
5282 gfc_add_block_to_block (&else_block, &parmse->pre);
5283 tmp = (GFC_DESCRIPTOR_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5283, __FUNCTION__))->type_common.lang_flag_1)
5284 ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5285 : parmse->expr);
5286 gfc_add_modify (&else_block, pointer, tmp);
5287 else_stmt = gfc_finish_block (&else_block);
5288
5289 /* And put the above into an if statement. */
5290 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
5291 gfc_likely (cont_var,
5292 PRED_FORTRAN_CONTIGUOUS),
5293 if_stmt, else_stmt);
5294 }
5295 else
5296 {
5297 /* pointer = pramse->expr; . */
5298 gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5299 pre_stmts = gfc_finish_block (&parmse->pre);
5300 }
5301
5302 if (pass_optional)
5303 {
5304 present_var = gfc_create_var (boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE], "present");
5305
5306 /* present_var = present(sym); . */
5307 tmp = gfc_conv_expr_present (sym);
5308 tmp = fold_convert (boolean_type_node, tmp)fold_convert_loc (((location_t) 0), global_trees[TI_BOOLEAN_TYPE
], tmp)
;
5309 gfc_add_modify (&se->pre, present_var, tmp);
5310
5311 /* else_stmt = { pointer = NULL; } . */
5312 gfc_init_block (&else_block);
5313 if (GFC_DESCRIPTOR_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5313, __FUNCTION__))->type_common.lang_flag_1)
)
5314 gfc_conv_descriptor_data_set (&else_block, pointer,
5315 null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
5316 else
5317 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5318 else_stmt = gfc_finish_block (&else_block);
5319
5320 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
5321 gfc_likely (present_var,
5322 PRED_FORTRAN_ABSENT_DUMMY),
5323 pre_stmts, else_stmt);
5324 gfc_add_expr_to_block (&se->pre, tmp);
5325 }
5326 else
5327 gfc_add_expr_to_block (&se->pre, pre_stmts);
5328
5329 post_stmts = gfc_finish_block (&parmse->post);
5330
5331 /* Put together the post stuff, plus the optional
5332 deallocation. */
5333 if (check_contiguous)
5334 {
5335 /* !cont_var. */
5336 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE],
5337 cont_var,
5338 build_zero_cst (boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE]));
5339 tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5340
5341 if (pass_optional)
5342 {
5343 tree present_likely = gfc_likely (present_var,
5344 PRED_FORTRAN_ABSENT_DUMMY);
5345 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5346 boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE], present_likely,
5347 tmp);
5348 }
5349 else
5350 post_cond = tmp;
5351 }
5352 else
5353 {
5354 gcc_assert (pass_optional)((void)(!(pass_optional) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5354, __FUNCTION__), 0 : 0))
;
5355 post_cond = present_var;
5356 }
5357
5358 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], post_cond,
5359 post_stmts, build_empty_stmt (input_location));
5360 gfc_add_expr_to_block (&se->post, tmp);
5361 if (GFC_DESCRIPTOR_TYPE_P (type)((tree_class_check ((type), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5361, __FUNCTION__))->type_common.lang_flag_1)
)
5362 {
5363 type = TREE_TYPE (parmse->expr)((contains_struct_check ((parmse->expr), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5363, __FUNCTION__))->typed.type)
;
5364 if (POINTER_TYPE_P (type)(((enum tree_code) (type)->base.code) == POINTER_TYPE || (
(enum tree_code) (type)->base.code) == REFERENCE_TYPE)
)
5365 {
5366 pointer = gfc_build_addr_expr (type, pointer);
5367 if (pass_optional)
5368 {
5369 tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5370 pointer = fold_build3_loc (input_location, COND_EXPR, type,
5371 tmp, pointer,
5372 fold_convert (type,fold_convert_loc (((location_t) 0), type, global_trees[TI_NULL_POINTER
])
5373 null_pointer_node)fold_convert_loc (((location_t) 0), type, global_trees[TI_NULL_POINTER
])
);
5374 }
5375 }
5376 else
5377 gcc_assert (!pass_optional)((void)(!(!pass_optional) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5377, __FUNCTION__), 0 : 0))
;
5378 }
5379 se->expr = pointer;
5380 }
5381
5382 return;
5383}
5384
5385
5386/* Generate the code for argument list functions. */
5387
5388static void
5389conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5390{
5391 /* Pass by value for g77 %VAL(arg), pass the address
5392 indirectly for %LOC, else by reference. Thus %REF
5393 is a "do-nothing" and %LOC is the same as an F95
5394 pointer. */
5395 if (strcmp (name, "%VAL") == 0)
5396 gfc_conv_expr (se, expr);
5397 else if (strcmp (name, "%LOC") == 0)
5398 {
5399 gfc_conv_expr_reference (se, expr);
5400 se->expr = gfc_build_addr_expr (NULL__null, se->expr);
5401 }
5402 else if (strcmp (name, "%REF") == 0)
5403 gfc_conv_expr_reference (se, expr);
5404 else
5405 gfc_error ("Unknown argument list function at %L", &expr->where);
5406}
5407
5408
5409/* This function tells whether the middle-end representation of the expression
5410 E given as input may point to data otherwise accessible through a variable
5411 (sub-)reference.
5412 It is assumed that the only expressions that may alias are variables,
5413 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5414 may alias.
5415 This function is used to decide whether freeing an expression's allocatable
5416 components is safe or should be avoided.
5417
5418 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5419 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5420 is necessary because for array constructors, aliasing depends on how
5421 the array is used:
5422 - If E is an array constructor used as argument to an elemental procedure,
5423 the array, which is generated through shallow copy by the scalarizer,
5424 is used directly and can alias the expressions it was copied from.
5425 - If E is an array constructor used as argument to a non-elemental
5426 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5427 the array as in the previous case, but then that array is used
5428 to initialize a new descriptor through deep copy. There is no alias
5429 possible in that case.
5430 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5431 above. */
5432
5433static bool
5434expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5435{
5436 gfc_constructor *c;
5437
5438 if (e->expr_type == EXPR_VARIABLE)
5439 return true;
5440 else if (e->expr_type == EXPR_FUNCTION)
5441 {
5442 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5443
5444 if (proc_ifc->result != NULL__null
5445 && ((proc_ifc->result->ts.type == BT_CLASS
5446 && proc_ifc->result->ts.u.derived->attr.is_class
5447 && CLASS_DATA (proc_ifc->result)proc_ifc->result->ts.u.derived->components->attr.class_pointer)
5448 || proc_ifc->result->attr.pointer))
5449 return true;
5450 else
5451 return false;
5452 }
5453 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5454 return false;
5455
5456 for (c = gfc_constructor_first (e->value.constructor);
5457 c; c = gfc_constructor_next (c))
5458 if (c->expr
5459 && expr_may_alias_variables (c->expr, array_may_alias))
5460 return true;
5461
5462 return false;
5463}
5464
5465
5466/* A helper function to set the dtype for unallocated or unassociated
5467 entities. */
5468
5469static void
5470set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5471{
5472 tree tmp;
5473 tree desc;
5474 tree cond;
5475 tree type;
5476 stmtblock_t block;
5477
5478 /* TODO Figure out how to handle optional dummies. */
5479 if (e && e->expr_type == EXPR_VARIABLE
5480 && e->symtree->n.sym->attr.optional)
5481 return;
5482
5483 desc = parmse->expr;
5484 if (desc == NULL_TREE(tree) __null)
5485 return;
5486
5487 if (POINTER_TYPE_P (TREE_TYPE (desc))(((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5487, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5487, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
5488 desc = build_fold_indirect_ref_loc (input_location, desc);
5489 if (GFC_CLASS_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5489, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5489, __FUNCTION__))->type_common.lang_flag_4)
)
5490 desc = gfc_class_data_get (desc);
5491 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))((tree_class_check ((((contains_struct_check ((desc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5491, __FUNCTION__))->typed.type)), (tcc_type), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5491, __FUNCTION__))->type_common.lang_flag_1)
)
5492 return;
5493
5494 gfc_init_block (&block);
5495 tmp = gfc_conv_descriptor_data_get (desc);
5496 cond = fold_build2_loc (input_location, EQ_EXPR,
5497 logical_type_node, tmp,
5498 build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5498, __FUNCTION__))->typed.type)
, 0));
5499 tmp = gfc_conv_descriptor_dtype (desc);
5500 type = gfc_get_element_type (TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5500, __FUNCTION__))->typed.type)
);
5501 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5502 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5502, __FUNCTION__))->typed.type)
, tmp,
5503 gfc_get_dtype_rank_type (e->rank, type));
5504 gfc_add_expr_to_block (&block, tmp);
5505 cond = build3_v (COND_EXPR, cond,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, gfc_finish_block (&block), build_empty_stmt (input_location
))
5506 gfc_finish_block (&block),fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, gfc_finish_block (&block), build_empty_stmt (input_location
))
5507 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, gfc_finish_block (&block), build_empty_stmt (input_location
))
;
5508 gfc_add_expr_to_block (&parmse->pre, cond);
5509}
5510
5511
5512
5513/* Provide an interface between gfortran array descriptors and the F2018:18.4
5514 ISO_Fortran_binding array descriptors. */
5515
5516static void
5517gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5518{
5519 stmtblock_t block, block2;
5520 tree cfi, gfc, tmp, tmp2;
5521 tree present = NULL__null;
5522 tree gfc_strlen = NULL__null;
5523 tree rank;
5524 gfc_se se;
5525
5526 if (fsym->attr.optional
5527 && e->expr_type == EXPR_VARIABLE
5528 && e->symtree->n.sym->attr.optional)
5529 present = gfc_conv_expr_present (e->symtree->n.sym);
5530
5531 gfc_init_block (&block);
5532
5533 /* Convert original argument to a tree. */
5534 gfc_init_se (&se, NULL__null);
5535 if (e->rank == 0)
5536 {
5537 se.want_pointer = 1;
5538 gfc_conv_expr (&se, e);
5539 gfc = se.expr;
5540 /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5541 if (!POINTER_TYPE_P (TREE_TYPE (gfc))(((enum tree_code) (((contains_struct_check ((gfc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5541, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((gfc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5541, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
5542 gfc = gfc_build_addr_expr (NULL__null, gfc);
5543 }
5544 else
5545 {
5546 /* If the actual argument can be noncontiguous, copy-in/out is required,
5547 if the dummy has either the CONTIGUOUS attribute or is an assumed-
5548 length assumed-length/assumed-size CHARACTER array. This only
5549 applies if the actual argument is a "variable"; if it's some
5550 non-lvalue expression, we are going to evaluate it to a
5551 temporary below anyway. */
5552 se.force_no_tmp = 1;
5553 if ((fsym->attr.contiguous
5554 || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
5555 && (fsym->as->type == AS_ASSUMED_SIZE
5556 || fsym->as->type == AS_EXPLICIT)))
5557 && !gfc_is_simply_contiguous (e, false, true)
5558 && gfc_expr_is_variable (e))
5559 {
5560 bool optional = fsym->attr.optional;
5561 fsym->attr.optional = 0;
5562 gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
5563 fsym->attr.pointer, fsym,
5564 fsym->ns->proc_name->name, NULL__null,
5565 /* check_contiguous= */ true);
5566 fsym->attr.optional = optional;
5567 }
5568 else
5569 gfc_conv_expr_descriptor (&se, e);
5570 gfc = se.expr;
5571 /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5572 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5573 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5574 While sm is fine as it uses span*stride and not elem_len. */
5575 if (POINTER_TYPE_P (TREE_TYPE (gfc))(((enum tree_code) (((contains_struct_check ((gfc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5575, __FUNCTION__))->typed.type))->base.code) == POINTER_TYPE
|| ((enum tree_code) (((contains_struct_check ((gfc), (TS_TYPED
), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5575, __FUNCTION__))->typed.type))->base.code) == REFERENCE_TYPE
)
)
5576 gfc = build_fold_indirect_ref_loc (input_location, gfc);
5577 else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
5578 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL__null, true, e);
5579 }
5580 if (e->ts.type == BT_CHARACTER)
5581 {
5582 if (se.string_length)
5583 gfc_strlen = se.string_length;
5584 else if (e->ts.u.cl->backend_decl)
5585 gfc_strlen = e->ts.u.cl->backend_decl;
5586 else
5587 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5587, __FUNCTION__))
;
5588 }
5589 gfc_add_block_to_block (&block, &se.pre);
5590
5591 /* Create array decriptor and set version, rank, attribute, type. */
5592 cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
5593 ? GFC_MAX_DIMENSIONS15 : e->rank,
5594 false), "cfi");
5595 /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5596 if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
5597 {
5598 tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
5599 tmp = build_pointer_type (tmp);
5600 parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
5601 cfi = build_fold_indirect_ref_loc (input_location, cfi);
5602 }
5603 else
5604 parmse->expr = gfc_build_addr_expr (NULL__null, cfi);
5605
5606 tmp = gfc_get_cfi_desc_version (cfi);
5607 gfc_add_modify (&block, tmp,
5608 build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5608, __FUNCTION__))->typed.type)
, CFI_VERSION1));
5609 if (e->rank < 0)
5610 rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc))fold_convert_loc (((location_t) 0), integer_types[itk_signed_char
], gfc_conv_descriptor_rank (gfc))
;
5611 else
5612 rank = build_int_cst (signed_char_type_nodeinteger_types[itk_signed_char], e->rank);
5613 tmp = gfc_get_cfi_desc_rank (cfi);
5614 gfc_add_modify (&block, tmp, rank);
5615 int itype = CFI_type_other-1;
5616 if (e->ts.f90_type == BT_VOID)
5617 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5618 ? CFI_type_cfunptr8 : CFI_type_cptr7);
5619 else
5620 {
5621 if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
5622 e->ts = fsym->ts;
5623 switch (e->ts.type)
5624 {
5625 case BT_INTEGER:
5626 case BT_LOGICAL:
5627 case BT_REAL:
5628 case BT_COMPLEX:
5629 itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind)(e->ts.type + (e->ts.kind << 8));
5630 break;
5631 case BT_CHARACTER:
5632 itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind)(5 + (e->ts.kind << 8));
5633 break;
5634 case BT_DERIVED:
5635 itype = CFI_type_struct6;
5636 break;
5637 case BT_VOID:
5638 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5639 ? CFI_type_cfunptr8 : CFI_type_cptr7);
5640 break;
5641 case BT_ASSUMED:
5642 itype = CFI_type_other-1; // FIXME: Or CFI_type_cptr ?
5643 break;
5644 case BT_CLASS:
5645 if (UNLIMITED_POLY (e)(e != __null && e->ts.type == BT_CLASS && e
->ts.u.derived->components && e->ts.u.derived
->components->ts.u.derived && e->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
)
&& fsym->ts.type == BT_ASSUMED)
5646 {
5647 // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
5648 // type specifier is assumed-type and is an unlimited polymorphic
5649 // entity." The actual argument _data component is passed.
5650 itype = CFI_type_other-1; // FIXME: Or CFI_type_cptr ?
5651 break;
5652 }
5653 else
5654 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5654, __FUNCTION__))
;
5655 case BT_PROCEDURE:
5656 case BT_HOLLERITH:
5657 case BT_UNION:
5658 case BT_BOZ:
5659 case BT_UNKNOWN:
5660 // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5661 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5661, __FUNCTION__))
;
5662 }
5663 }
5664
5665 tmp = gfc_get_cfi_desc_type (cfi);
5666 gfc_add_modify (&block, tmp,
5667 build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5667, __FUNCTION__))->typed.type)
, itype));
5668
5669 int attr = CFI_attribute_other2;
5670 if (fsym->attr.pointer)
5671 attr = CFI_attribute_pointer0;
5672 else if (fsym->attr.allocatable)
5673 attr = CFI_attribute_allocatable1;
5674 tmp = gfc_get_cfi_desc_attribute (cfi);
5675 gfc_add_modify (&block, tmp,
5676 build_int_cst (TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5676, __FUNCTION__))->typed.type)
, attr));
5677
5678 /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
5679 That is very sensible for undefined pointers, but the C code might assume
5680 that the pointer retains the value, in particular, if it was NULL. */
5681 if (e->rank == 0)
5682 {
5683 tmp = gfc_get_cfi_desc_base_addr (cfi);
5684 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5684, __FUNCTION__))->typed.type), gfc)
);
5685 }
5686 else
5687 {
5688 tmp = gfc_get_cfi_desc_base_addr (cfi);
5689 tmp2 = gfc_conv_descriptor_data_get (gfc);
5690 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5690, __FUNCTION__))->typed.type), tmp2)
);
5691 }
5692
5693 /* Set elem_len if known - must be before the next if block.
5694 Note that allocatable implies 'len=:'. */
5695 if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
5696 {
5697 /* Length is known at compile time; use 'block' for it. */
5698 tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
5699 tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5700 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp2), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5700, __FUNCTION__))->typed.type), tmp)
);
5701 }
5702
5703 if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
5704 goto done;
5705
5706 /* When allocatable + intent out, free the cfi descriptor. */
5707 if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
5708 {
5709 tmp = gfc_get_cfi_desc_base_addr (cfi);
5710 tree call = builtin_decl_explicit (BUILT_IN_FREE);
5711 call = build_call_expr_loc (input_location, call, 1, tmp);
5712 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)fold_convert_loc (((location_t) 0), global_trees[TI_VOID_TYPE
], call)
);
5713 gfc_add_modify (&block, tmp,
5714 fold_convert (TREE_TYPE (tmp), null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-expr.cc"
, 5714, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
5715 goto done;
5716 }
5717
5718 /* If not unallocated/unassociated. */
5719 gfc_init_block (&block2);
5720
5721 /* Set elem_len, which may be only known at run time. */
5722 if (e->ts.type == BT_CHARACTER
5723 && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE(tree) __null))
5724 {