Bug Summary

File:build/gcc/fortran/trans-expr.c
Warning:line 11338, column 8
Branch condition evaluates to a garbage value

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