Bug Summary

File:build/gcc/fortran/trans-expr.c
Warning:line 7401, column 24
Called C++ object pointer is null

Annotated Source Code

Press '?' to see keyboard shortcuts

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