Bug Summary

File:build/gcc/fortran/trans-intrinsic.c
Warning:line 4428, column 4
Called C++ object pointer is null

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name trans-intrinsic.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-dR3JJW.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c

/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c

1/* Intrinsic 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-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "memmodel.h"
28#include "tm.h" /* For UNITS_PER_WORD. */
29#include "tree.h"
30#include "gfortran.h"
31#include "trans.h"
32#include "stringpool.h"
33#include "fold-const.h"
34#include "internal-fn.h"
35#include "tree-nested.h"
36#include "stor-layout.h"
37#include "toplev.h" /* For rest_of_decl_compilation. */
38#include "arith.h"
39#include "trans-const.h"
40#include "trans-types.h"
41#include "trans-array.h"
42#include "dependency.h" /* For CAF array alias analysis. */
43#include "attribs.h"
44
45/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
46
47/* This maps Fortran intrinsic math functions to external library or GCC
48 builtin functions. */
49typedef struct GTY(()) gfc_intrinsic_map_t {
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
52 enum gfc_isym_id id;
53
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function float_built_in;
57 enum built_in_function double_built_in;
58 enum built_in_function long_double_built_in;
59 enum built_in_function complex_float_built_in;
60 enum built_in_function complex_double_built_in;
61 enum built_in_function complex_long_double_built_in;
62
63 /* True if the naming pattern is to prepend "c" for complex and
64 append "f" for kind=4. False if the naming pattern is to
65 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 bool libm_name;
67
68 /* True if a complex version of the function exists. */
69 bool complex_available;
70
71 /* True if the function should be marked const. */
72 bool is_constant;
73
74 /* The base library name of this function. */
75 const char *name;
76
77 /* Cache decls created for the various operand types. */
78 tree real4_decl;
79 tree real8_decl;
80 tree real10_decl;
81 tree real16_decl;
82 tree complex4_decl;
83 tree complex8_decl;
84 tree complex10_decl;
85 tree complex16_decl;
86}
87gfc_intrinsic_map_t;
88
89/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
90 defines complex variants of all of the entries in mathbuiltins.def
91 except for atan2. */
92#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
93 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
94 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
95 true, false, true, NAME, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, \
96 NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null},
97
98#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
99 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
100 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
101 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE(tree) __null, NULL_TREE(tree) __null, \
102 NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null},
103
104#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
105 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 false, HAVE_COMPLEX, true, NAME, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, \
108 NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null }
109
110#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
111 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
112 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
113 true, false, CONST, NAME, NULL_TREE(tree) __null, NULL_TREE(tree) __null, \
114 NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null, NULL_TREE(tree) __null},
115
116static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
117{
118 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
119 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
120 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
121#include "mathbuiltins.def"
122
123 /* Functions in libgfortran. */
124 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
125 LIB_FUNCTION (SIND, "sind", false),
126 LIB_FUNCTION (COSD, "cosd", false),
127 LIB_FUNCTION (TAND, "tand", false),
128
129 /* End the list. */
130 LIB_FUNCTION (NONE, NULL__null, false)
131
132};
133#undef OTHER_BUILTIN
134#undef LIB_FUNCTION
135#undef DEFINE_MATH_BUILTIN
136#undef DEFINE_MATH_BUILTIN_C
137
138
139enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
140
141
142/* Find the correct variant of a given builtin from its argument. */
143static tree
144builtin_decl_for_precision (enum built_in_function base_built_in,
145 int precision)
146{
147 enum built_in_function i = END_BUILTINS;
148
149 gfc_intrinsic_map_t *m;
150 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
151 ;
152
153 if (precision == TYPE_PRECISION (float_type_node)((tree_class_check ((global_trees[TI_FLOAT_TYPE]), (tcc_type)
, "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 153, __FUNCTION__))->type_common.precision)
)
154 i = m->float_built_in;
155 else if (precision == TYPE_PRECISION (double_type_node)((tree_class_check ((global_trees[TI_DOUBLE_TYPE]), (tcc_type
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 155, __FUNCTION__))->type_common.precision)
)
156 i = m->double_built_in;
157 else if (precision == TYPE_PRECISION (long_double_type_node)((tree_class_check ((global_trees[TI_LONG_DOUBLE_TYPE]), (tcc_type
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 157, __FUNCTION__))->type_common.precision)
)
158 i = m->long_double_built_in;
159 else if (precision == TYPE_PRECISION (gfc_float128_type_node)((tree_class_check ((gfc_float128_type_node), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 159, __FUNCTION__))->type_common.precision)
)
160 {
161 /* Special treatment, because it is not exactly a built-in, but
162 a library function. */
163 return m->real16_decl;
164 }
165
166 return (i == END_BUILTINS ? NULL_TREE(tree) __null : builtin_decl_explicit (i));
167}
168
169
170tree
171gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
172 int kind)
173{
174 int i = gfc_validate_kind (BT_REAL, kind, false);
175
176 if (gfc_real_kinds[i].c_float128)
177 {
178 /* For __float128, the story is a bit different, because we return
179 a decl to a library function rather than a built-in. */
180 gfc_intrinsic_map_t *m;
181 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
182 ;
183
184 return m->real16_decl;
185 }
186
187 return builtin_decl_for_precision (double_built_in,
188 gfc_real_kinds[i].mode_precision);
189}
190
191
192/* Evaluate the arguments to an intrinsic function. The value
193 of NARGS may be less than the actual number of arguments in EXPR
194 to allow optional "KIND" arguments that are not included in the
195 generated code to be ignored. */
196
197static void
198gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
199 tree *argarray, int nargs)
200{
201 gfc_actual_arglist *actual;
202 gfc_expr *e;
203 gfc_intrinsic_arg *formal;
204 gfc_se argse;
205 int curr_arg;
206
207 formal = expr->value.function.isym->formal;
208 actual = expr->value.function.actual;
209
210 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
211 actual = actual->next,
212 formal = formal ? formal->next : NULL__null)
213 {
214 gcc_assert (actual)((void)(!(actual) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 214, __FUNCTION__), 0 : 0))
;
215 e = actual->expr;
216 /* Skip omitted optional arguments. */
217 if (!e)
218 {
219 --curr_arg;
220 continue;
221 }
222
223 /* Evaluate the parameter. This will substitute scalarized
224 references automatically. */
225 gfc_init_se (&argse, se);
226
227 if (e->ts.type == BT_CHARACTER)
228 {
229 gfc_conv_expr (&argse, e);
230 gfc_conv_string_parameter (&argse);
231 argarray[curr_arg++] = argse.string_length;
232 gcc_assert (curr_arg < nargs)((void)(!(curr_arg < nargs) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 232, __FUNCTION__), 0 : 0))
;
233 }
234 else
235 gfc_conv_expr_val (&argse, e);
236
237 /* If an optional argument is itself an optional dummy argument,
238 check its presence and substitute a null if absent. */
239 if (e->expr_type == EXPR_VARIABLE
240 && e->symtree->n.sym->attr.optional
241 && formal
242 && formal->optional)
243 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
244
245 gfc_add_block_to_block (&se->pre, &argse.pre);
246 gfc_add_block_to_block (&se->post, &argse.post);
247 argarray[curr_arg] = argse.expr;
248 }
249}
250
251/* Count the number of actual arguments to the intrinsic function EXPR
252 including any "hidden" string length arguments. */
253
254static unsigned int
255gfc_intrinsic_argument_list_length (gfc_expr *expr)
256{
257 int n = 0;
258 gfc_actual_arglist *actual;
259
260 for (actual = expr->value.function.actual; actual; actual = actual->next)
261 {
262 if (!actual->expr)
263 continue;
264
265 if (actual->expr->ts.type == BT_CHARACTER)
266 n += 2;
267 else
268 n++;
269 }
270
271 return n;
272}
273
274
275/* Conversions between different types are output by the frontend as
276 intrinsic functions. We implement these directly with inline code. */
277
278static void
279gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
280{
281 tree type;
282 tree *args;
283 int nargs;
284
285 nargs = gfc_intrinsic_argument_list_length (expr);
286 args = XALLOCAVEC (tree, nargs)((tree *) __builtin_alloca(sizeof (tree) * (nargs)));
287
288 /* Evaluate all the arguments passed. Whilst we're only interested in the
289 first one here, there are other parts of the front-end that assume this
290 and will trigger an ICE if it's not the case. */
291 type = gfc_typenode_for_spec (&expr->ts);
292 gcc_assert (expr->value.function.actual->expr)((void)(!(expr->value.function.actual->expr) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 292, __FUNCTION__), 0 : 0))
;
293 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
294
295 /* Conversion between character kinds involves a call to a library
296 function. */
297 if (expr->ts.type == BT_CHARACTER)
298 {
299 tree fndecl, var, addr, tmp;
300
301 if (expr->ts.kind == 1
302 && expr->value.function.actual->expr->ts.kind == 4)
303 fndecl = gfor_fndecl_convert_char4_to_char1;
304 else if (expr->ts.kind == 4
305 && expr->value.function.actual->expr->ts.kind == 1)
306 fndecl = gfor_fndecl_convert_char1_to_char4;
307 else
308 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 308, __FUNCTION__))
;
309
310 /* Create the variable storing the converted value. */
311 type = gfc_get_pchar_type (expr->ts.kind);
312 var = gfc_create_var (type, "str");
313 addr = gfc_build_addr_expr (build_pointer_type (type), var);
314
315 /* Call the library function that will perform the conversion. */
316 gcc_assert (nargs >= 2)((void)(!(nargs >= 2) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 316, __FUNCTION__), 0 : 0))
;
317 tmp = build_call_expr_loc (input_location,
318 fndecl, 3, addr, args[0], args[1]);
319 gfc_add_expr_to_block (&se->pre, tmp);
320
321 /* Free the temporary afterwards. */
322 tmp = gfc_call_free (var);
323 gfc_add_expr_to_block (&se->post, tmp);
324
325 se->expr = var;
326 se->string_length = args[0];
327
328 return;
329 }
330
331 /* Conversion from complex to non-complex involves taking the real
332 component of the value. */
333 if (TREE_CODE (TREE_TYPE (args[0]))((enum tree_code) (((contains_struct_check ((args[0]), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 333, __FUNCTION__))->typed.type))->base.code)
== COMPLEX_TYPE
334 && expr->ts.type != BT_COMPLEX)
335 {
336 tree artype;
337
338 artype = TREE_TYPE (TREE_TYPE (args[0]))((contains_struct_check ((((contains_struct_check ((args[0]),
(TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 338, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 338, __FUNCTION__))->typed.type)
;
339 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
340 args[0]);
341 }
342
343 se->expr = convert (type, args[0]);
344}
345
346/* This is needed because the gcc backend only implements
347 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
348 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
349 Similarly for CEILING. */
350
351static tree
352build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
353{
354 tree tmp;
355 tree cond;
356 tree argtype;
357 tree intval;
358
359 argtype = TREE_TYPE (arg)((contains_struct_check ((arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 359, __FUNCTION__))->typed.type)
;
360 arg = gfc_evaluate_now (arg, pblock);
361
362 intval = convert (type, arg);
363 intval = gfc_evaluate_now (intval, pblock);
364
365 tmp = convert (argtype, intval);
366 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
367 logical_type_node, tmp, arg);
368
369 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
370 intval, build_int_cst (type, 1));
371 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
372 return tmp;
373}
374
375
376/* Round to nearest integer, away from zero. */
377
378static tree
379build_round_expr (tree arg, tree restype)
380{
381 tree argtype;
382 tree fn;
383 int argprec, resprec;
384
385 argtype = TREE_TYPE (arg)((contains_struct_check ((arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 385, __FUNCTION__))->typed.type)
;
386 argprec = TYPE_PRECISION (argtype)((tree_class_check ((argtype), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 386, __FUNCTION__))->type_common.precision)
;
387 resprec = TYPE_PRECISION (restype)((tree_class_check ((restype), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 387, __FUNCTION__))->type_common.precision)
;
388
389 /* Depending on the type of the result, choose the int intrinsic
390 (iround, available only as a builtin, therefore cannot use it for
391 __float128), long int intrinsic (lround family) or long long
392 intrinsic (llround). We might also need to convert the result
393 afterwards. */
394 if (resprec <= INT_TYPE_SIZE32 && argprec <= LONG_DOUBLE_TYPE_SIZE(((global_options.x_target_flags & (1U << 17)) != 0
) ? 64 : (((global_options.x_target_flags & (1U << 16
)) != 0) ? 128 : 80))
)
395 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
396 else if (resprec <= LONG_TYPE_SIZE(((global_options.x_ix86_isa_flags & (1UL << 58)) !=
0) ? 32 : ((8) * (((global_options.x_ix86_isa_flags & (1UL
<< 1)) != 0) ? 8 : 4)))
)
397 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
398 else if (resprec <= LONG_LONG_TYPE_SIZE64)
399 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
400 else if (resprec >= argprec && resprec == 128)
401 {
402 /* Search for a real kind suitable as temporary for conversion. */
403 int kind = -1;
404 for (int i = 0; kind < 0 && gfc_real_kinds[i].kind != 0; i++)
405 if (gfc_real_kinds[i].mode_precision >= resprec)
406 kind = gfc_real_kinds[i].kind;
407 if (kind < 0)
408 gfc_internal_error ("Could not find real kind with at least %d bits",
409 resprec);
410 arg = fold_convert (gfc_float128_type_node, arg)fold_convert_loc (((location_t) 0), gfc_float128_type_node, arg
)
;
411 fn = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
412 }
413 else
414 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 414, __FUNCTION__))
;
415
416 return convert (restype, build_call_expr_loc (input_location,
417 fn, 1, arg));
418}
419
420
421/* Convert a real to an integer using a specific rounding mode.
422 Ideally we would just build the corresponding GENERIC node,
423 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
424
425static tree
426build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
427 enum rounding_mode op)
428{
429 switch (op)
430 {
431 case RND_FLOOR:
432 return build_fixbound_expr (pblock, arg, type, 0);
433
434 case RND_CEIL:
435 return build_fixbound_expr (pblock, arg, type, 1);
436
437 case RND_ROUND:
438 return build_round_expr (arg, type);
439
440 case RND_TRUNC:
441 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
442
443 default:
444 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 444, __FUNCTION__))
;
445 }
446}
447
448
449/* Round a real value using the specified rounding mode.
450 We use a temporary integer of that same kind size as the result.
451 Values larger than those that can be represented by this kind are
452 unchanged, as they will not be accurate enough to represent the
453 rounding.
454 huge = HUGE (KIND (a))
455 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
456 */
457
458static void
459gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460{
461 tree type;
462 tree itype;
463 tree arg[2];
464 tree tmp;
465 tree cond;
466 tree decl;
467 mpfr_t huge;
468 int n, nargs;
469 int kind;
470
471 kind = expr->ts.kind;
472 nargs = gfc_intrinsic_argument_list_length (expr);
473
474 decl = NULL_TREE(tree) __null;
475 /* We have builtin functions for some cases. */
476 switch (op)
477 {
478 case RND_ROUND:
479 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
480 break;
481
482 case RND_TRUNC:
483 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
484 break;
485
486 default:
487 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 487, __FUNCTION__))
;
488 }
489
490 /* Evaluate the argument. */
491 gcc_assert (expr->value.function.actual->expr)((void)(!(expr->value.function.actual->expr) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 491, __FUNCTION__), 0 : 0))
;
492 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
493
494 /* Use a builtin function if one exists. */
495 if (decl != NULL_TREE(tree) __null)
496 {
497 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
498 return;
499 }
500
501 /* This code is probably redundant, but we'll keep it lying around just
502 in case. */
503 type = gfc_typenode_for_spec (&expr->ts);
504 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
505
506 /* Test if the value is too large to handle sensibly. */
507 gfc_set_model_kind (kind);
508 mpfr_init (huge);
509 n = gfc_validate_kind (BT_INTEGER, kind, false);
510 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODEMPFR_RNDN);
511 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
512 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
513 tmp);
514
515 mpfr_neg (huge, huge, GFC_RND_MODEMPFR_RNDN);
516 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
517 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
518 tmp);
519 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
520 cond, tmp);
521 itype = gfc_get_int_type (kind);
522
523 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
524 tmp = convert (type, tmp);
525 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
526 arg[0]);
527 mpfr_clear (huge);
528}
529
530
531/* Convert to an integer using the specified rounding mode. */
532
533static void
534gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
535{
536 tree type;
537 tree *args;
538 int nargs;
539
540 nargs = gfc_intrinsic_argument_list_length (expr);
541 args = XALLOCAVEC (tree, nargs)((tree *) __builtin_alloca(sizeof (tree) * (nargs)));
542
543 /* Evaluate the argument, we process all arguments even though we only
544 use the first one for code generation purposes. */
545 type = gfc_typenode_for_spec (&expr->ts);
546 gcc_assert (expr->value.function.actual->expr)((void)(!(expr->value.function.actual->expr) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 546, __FUNCTION__), 0 : 0))
;
547 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
548
549 if (TREE_CODE (TREE_TYPE (args[0]))((enum tree_code) (((contains_struct_check ((args[0]), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 549, __FUNCTION__))->typed.type))->base.code)
== INTEGER_TYPE)
550 {
551 /* Conversion to a different integer kind. */
552 se->expr = convert (type, args[0]);
553 }
554 else
555 {
556 /* Conversion from complex to non-complex involves taking the real
557 component of the value. */
558 if (TREE_CODE (TREE_TYPE (args[0]))((enum tree_code) (((contains_struct_check ((args[0]), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 558, __FUNCTION__))->typed.type))->base.code)
== COMPLEX_TYPE
559 && expr->ts.type != BT_COMPLEX)
560 {
561 tree artype;
562
563 artype = TREE_TYPE (TREE_TYPE (args[0]))((contains_struct_check ((((contains_struct_check ((args[0]),
(TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 563, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 563, __FUNCTION__))->typed.type)
;
564 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
565 args[0]);
566 }
567
568 se->expr = build_fix_expr (&se->pre, args[0], type, op);
569 }
570}
571
572
573/* Get the imaginary component of a value. */
574
575static void
576gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
577{
578 tree arg;
579
580 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
581 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
582 TREE_TYPE (TREE_TYPE (arg))((contains_struct_check ((((contains_struct_check ((arg), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 582, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 582, __FUNCTION__))->typed.type)
, arg);
583}
584
585
586/* Get the complex conjugate of a value. */
587
588static void
589gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
590{
591 tree arg;
592
593 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
594 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg)((contains_struct_check ((arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 594, __FUNCTION__))->typed.type)
, arg);
595}
596
597
598
599static tree
600define_quad_builtin (const char *name, tree type, bool is_const)
601{
602 tree fndecl;
603 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name)(__builtin_constant_p (name) ? get_identifier_with_length ((name
), strlen (name)) : get_identifier (name))
,
604 type);
605
606 /* Mark the decl as external. */
607 DECL_EXTERNAL (fndecl)((contains_struct_check ((fndecl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 607, __FUNCTION__))->decl_common.decl_flag_1)
= 1;
608 TREE_PUBLIC (fndecl)((fndecl)->base.public_flag) = 1;
609
610 /* Mark it __attribute__((const)). */
611 TREE_READONLY (fndecl)((non_type_check ((fndecl), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 611, __FUNCTION__))->base.readonly_flag)
= is_const;
612
613 rest_of_decl_compilation (fndecl, 1, 0);
614
615 return fndecl;
616}
617
618/* Add SIMD attribute for FNDECL built-in if the built-in
619 name is in VECTORIZED_BUILTINS. */
620
621static void
622add_simd_flag_for_built_in (tree fndecl)
623{
624 if (gfc_vectorized_builtins == NULL__null
625 || fndecl == NULL_TREE(tree) __null)
626 return;
627
628 const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl))((const char *) (tree_check ((((contains_struct_check ((fndecl
), (TS_DECL_MINIMAL), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 628, __FUNCTION__))->decl_minimal.name)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 628, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)
;
629 int *clauses = gfc_vectorized_builtins->get (name);
630 if (clauses)
631 {
632 for (unsigned i = 0; i < 3; i++)
633 if (*clauses & (1 << i))
634 {
635 gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
636 tree omp_clause = NULL_TREE(tree) __null;
637 if (simd_type == SIMD_NONE)
638 ; /* No SIMD clause. */
639 else
640 {
641 omp_clause_code code
642 = (simd_type == SIMD_INBRANCH
643 ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
644 omp_clause = build_omp_clause (UNKNOWN_LOCATION((location_t) 0), code);
645 omp_clause = build_tree_list (NULL_TREE(tree) __null, omp_clause);
646 }
647
648 DECL_ATTRIBUTES (fndecl)((contains_struct_check ((fndecl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 648, __FUNCTION__))->decl_common.attributes)
649 = tree_cons (get_identifier ("omp declare simd")(__builtin_constant_p ("omp declare simd") ? get_identifier_with_length
(("omp declare simd"), strlen ("omp declare simd")) : get_identifier
("omp declare simd"))
, omp_clause,
650 DECL_ATTRIBUTES (fndecl)((contains_struct_check ((fndecl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 650, __FUNCTION__))->decl_common.attributes)
);
651 }
652 }
653}
654
655 /* Set SIMD attribute to all built-in functions that are mentioned
656 in gfc_vectorized_builtins vector. */
657
658void
659gfc_adjust_builtins (void)
660{
661 gfc_intrinsic_map_t *m;
662 for (m = gfc_intrinsic_map;
663 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
664 {
665 add_simd_flag_for_built_in (m->real4_decl);
666 add_simd_flag_for_built_in (m->complex4_decl);
667 add_simd_flag_for_built_in (m->real8_decl);
668 add_simd_flag_for_built_in (m->complex8_decl);
669 add_simd_flag_for_built_in (m->real10_decl);
670 add_simd_flag_for_built_in (m->complex10_decl);
671 add_simd_flag_for_built_in (m->real16_decl);
672 add_simd_flag_for_built_in (m->complex16_decl);
673 add_simd_flag_for_built_in (m->real16_decl);
674 add_simd_flag_for_built_in (m->complex16_decl);
675 }
676
677 /* Release all strings. */
678 if (gfc_vectorized_builtins != NULL__null)
679 {
680 for (hash_map<nofree_string_hash, int>::iterator it
681 = gfc_vectorized_builtins->begin ();
682 it != gfc_vectorized_builtins->end (); ++it)
683 free (CONST_CAST (char *, (*it).first)(const_cast<char *> (((*it).first))));
684
685 delete gfc_vectorized_builtins;
686 gfc_vectorized_builtins = NULL__null;
687 }
688}
689
690/* Initialize function decls for library functions. The external functions
691 are created as required. Builtin functions are added here. */
692
693void
694gfc_build_intrinsic_lib_fndecls (void)
695{
696 gfc_intrinsic_map_t *m;
697 tree quad_decls[END_BUILTINS + 1];
698
699 if (gfc_real16_is_float128)
700 {
701 /* If we have soft-float types, we create the decls for their
702 C99-like library functions. For now, we only handle __float128
703 q-suffixed functions. */
704
705 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
706 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
707
708 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
709
710 type = gfc_float128_type_node;
711 complex_type = gfc_complex_float128_type_node;
712 /* type (*) (type) */
713 func_1 = build_function_type_list (type, type, NULL_TREE(tree) __null);
714 /* int (*) (type) */
715 func_iround = build_function_type_list (integer_type_nodeinteger_types[itk_int],
716 type, NULL_TREE(tree) __null);
717 /* long (*) (type) */
718 func_lround = build_function_type_list (long_integer_type_nodeinteger_types[itk_long],
719 type, NULL_TREE(tree) __null);
720 /* long long (*) (type) */
721 func_llround = build_function_type_list (long_long_integer_type_nodeinteger_types[itk_long_long],
722 type, NULL_TREE(tree) __null);
723 /* type (*) (type, type) */
724 func_2 = build_function_type_list (type, type, type, NULL_TREE(tree) __null);
725 /* type (*) (type, &int) */
726 func_frexp
727 = build_function_type_list (type,
728 type,
729 build_pointer_type (integer_type_nodeinteger_types[itk_int]),
730 NULL_TREE(tree) __null);
731 /* type (*) (type, int) */
732 func_scalbn = build_function_type_list (type,
733 type, integer_type_nodeinteger_types[itk_int], NULL_TREE(tree) __null);
734 /* type (*) (complex type) */
735 func_cabs = build_function_type_list (type, complex_type, NULL_TREE(tree) __null);
736 /* complex type (*) (complex type, complex type) */
737 func_cpow
738 = build_function_type_list (complex_type,
739 complex_type, complex_type, NULL_TREE(tree) __null);
740
741#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
742#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
743#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
744
745 /* Only these built-ins are actually needed here. These are used directly
746 from the code, when calling builtin_decl_for_precision() or
747 builtin_decl_for_float_type(). The others are all constructed by
748 gfc_get_intrinsic_lib_fndecl(). */
749#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
750 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
751
752#include "mathbuiltins.def"
753
754#undef OTHER_BUILTIN
755#undef LIB_FUNCTION
756#undef DEFINE_MATH_BUILTIN
757#undef DEFINE_MATH_BUILTIN_C
758
759 /* There is one built-in we defined manually, because it gets called
760 with builtin_decl_for_precision() or builtin_decl_for_float_type()
761 even though it is not an OTHER_BUILTIN: it is SQRT. */
762 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
763
764 }
765
766 /* Add GCC builtin functions. */
767 for (m = gfc_intrinsic_map;
768 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
769 {
770 if (m->float_built_in != END_BUILTINS)
771 m->real4_decl = builtin_decl_explicit (m->float_built_in);
772 if (m->complex_float_built_in != END_BUILTINS)
773 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
774 if (m->double_built_in != END_BUILTINS)
775 m->real8_decl = builtin_decl_explicit (m->double_built_in);
776 if (m->complex_double_built_in != END_BUILTINS)
777 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
778
779 /* If real(kind=10) exists, it is always long double. */
780 if (m->long_double_built_in != END_BUILTINS)
781 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
782 if (m->complex_long_double_built_in != END_BUILTINS)
783 m->complex10_decl
784 = builtin_decl_explicit (m->complex_long_double_built_in);
785
786 if (!gfc_real16_is_float128)
787 {
788 if (m->long_double_built_in != END_BUILTINS)
789 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
790 if (m->complex_long_double_built_in != END_BUILTINS)
791 m->complex16_decl
792 = builtin_decl_explicit (m->complex_long_double_built_in);
793 }
794 else if (quad_decls[m->double_built_in] != NULL_TREE(tree) __null)
795 {
796 /* Quad-precision function calls are constructed when first
797 needed by builtin_decl_for_precision(), except for those
798 that will be used directly (define by OTHER_BUILTIN). */
799 m->real16_decl = quad_decls[m->double_built_in];
800 }
801 else if (quad_decls[m->complex_double_built_in] != NULL_TREE(tree) __null)
802 {
803 /* Same thing for the complex ones. */
804 m->complex16_decl = quad_decls[m->double_built_in];
805 }
806 }
807}
808
809
810/* Create a fndecl for a simple intrinsic library function. */
811
812static tree
813gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
814{
815 tree type;
816 vec<tree, va_gc> *argtypes;
817 tree fndecl;
818 gfc_actual_arglist *actual;
819 tree *pdecl;
820 gfc_typespec *ts;
821 char name[GFC_MAX_SYMBOL_LEN63 + 3];
822
823 ts = &expr->ts;
824 if (ts->type == BT_REAL)
825 {
826 switch (ts->kind)
827 {
828 case 4:
829 pdecl = &m->real4_decl;
830 break;
831 case 8:
832 pdecl = &m->real8_decl;
833 break;
834 case 10:
835 pdecl = &m->real10_decl;
836 break;
837 case 16:
838 pdecl = &m->real16_decl;
839 break;
840 default:
841 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 841, __FUNCTION__))
;
842 }
843 }
844 else if (ts->type == BT_COMPLEX)
845 {
846 gcc_assert (m->complex_available)((void)(!(m->complex_available) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 846, __FUNCTION__), 0 : 0))
;
847
848 switch (ts->kind)
849 {
850 case 4:
851 pdecl = &m->complex4_decl;
852 break;
853 case 8:
854 pdecl = &m->complex8_decl;
855 break;
856 case 10:
857 pdecl = &m->complex10_decl;
858 break;
859 case 16:
860 pdecl = &m->complex16_decl;
861 break;
862 default:
863 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 863, __FUNCTION__))
;
864 }
865 }
866 else
867 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 867, __FUNCTION__))
;
868
869 if (*pdecl)
870 return *pdecl;
871
872 if (m->libm_name)
873 {
874 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
875 if (gfc_real_kinds[n].c_float)
876 snprintf (name, sizeof (name), "%s%s%s",
877 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
878 else if (gfc_real_kinds[n].c_double)
879 snprintf (name, sizeof (name), "%s%s",
880 ts->type == BT_COMPLEX ? "c" : "", m->name);
881 else if (gfc_real_kinds[n].c_long_double)
882 snprintf (name, sizeof (name), "%s%s%s",
883 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
884 else if (gfc_real_kinds[n].c_float128)
885 snprintf (name, sizeof (name), "%s%s%s",
886 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
887 else
888 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 888, __FUNCTION__))
;
889 }
890 else
891 {
892 snprintf (name, sizeof (name), PREFIX ("%s_%c%d")"_gfortran_" "%s_%c%d", m->name,
893 ts->type == BT_COMPLEX ? 'c' : 'r',
894 ts->kind);
895 }
896
897 argtypes = NULL__null;
898 for (actual = expr->value.function.actual; actual; actual = actual->next)
899 {
900 type = gfc_typenode_for_spec (&actual->expr->ts);
901 vec_safe_push (argtypes, type);
902 }
903 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes)build_function_type_array (gfc_typenode_for_spec (ts), vec_safe_length
(argtypes), vec_safe_address (argtypes))
;
904 fndecl = build_decl (input_location,
905 FUNCTION_DECL, get_identifier (name)(__builtin_constant_p (name) ? get_identifier_with_length ((name
), strlen (name)) : get_identifier (name))
, type);
906
907 /* Mark the decl as external. */
908 DECL_EXTERNAL (fndecl)((contains_struct_check ((fndecl), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 908, __FUNCTION__))->decl_common.decl_flag_1)
= 1;
909 TREE_PUBLIC (fndecl)((fndecl)->base.public_flag) = 1;
910
911 /* Mark it __attribute__((const)), if possible. */
912 TREE_READONLY (fndecl)((non_type_check ((fndecl), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 912, __FUNCTION__))->base.readonly_flag)
= m->is_constant;
913
914 rest_of_decl_compilation (fndecl, 1, 0);
915
916 (*pdecl) = fndecl;
917 return fndecl;
918}
919
920
921/* Convert an intrinsic function into an external or builtin call. */
922
923static void
924gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
925{
926 gfc_intrinsic_map_t *m;
927 tree fndecl;
928 tree rettype;
929 tree *args;
930 unsigned int num_args;
931 gfc_isym_id id;
932
933 id = expr->value.function.isym->id;
934 /* Find the entry for this function. */
935 for (m = gfc_intrinsic_map;
936 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
937 {
938 if (id == m->id)
939 break;
940 }
941
942 if (m->id == GFC_ISYM_NONE)
943 {
944 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
945 expr->value.function.name, id);
946 }
947
948 /* Get the decl and generate the call. */
949 num_args = gfc_intrinsic_argument_list_length (expr);
950 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
951
952 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
953 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
954 rettype = TREE_TYPE (TREE_TYPE (fndecl))((contains_struct_check ((((contains_struct_check ((fndecl), (
TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 954, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 954, __FUNCTION__))->typed.type)
;
955
956 fndecl = build_addr (fndecl);
957 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
958}
959
960
961/* If bounds-checking is enabled, create code to verify at runtime that the
962 string lengths for both expressions are the same (needed for e.g. MERGE).
963 If bounds-checking is not enabled, does nothing. */
964
965void
966gfc_trans_same_strlen_check (const char* intr_name, locus* where,
967 tree a, tree b, stmtblock_t* target)
968{
969 tree cond;
970 tree name;
971
972 /* If bounds-checking is disabled, do nothing. */
973 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0)))
974 return;
975
976 /* Compare the two string lengths. */
977 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
978
979 /* Output the runtime-check. */
980 name = gfc_build_cstring_const (intr_name);
981 name = gfc_build_addr_expr (pchar_type_node, name);
982 gfc_trans_runtime_check (true, false, cond, target, where,
983 "Unequal character lengths (%ld/%ld) in %s",
984 fold_convert (long_integer_type_node, a)fold_convert_loc (((location_t) 0), integer_types[itk_long], a
)
,
985 fold_convert (long_integer_type_node, b)fold_convert_loc (((location_t) 0), integer_types[itk_long], b
)
, name);
986}
987
988
989/* The EXPONENT(X) intrinsic function is translated into
990 int ret;
991 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
992 so that if X is a NaN or infinity, the result is HUGE(0).
993 */
994
995static void
996gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
997{
998 tree arg, type, res, tmp, frexp, cond, huge;
999 int i;
1000
1001 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1002 expr->value.function.actual->expr->ts.kind);
1003
1004 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1005 arg = gfc_evaluate_now (arg, &se->pre);
1006
1007 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1008 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1009 cond = build_call_expr_loc (input_location,
1010 builtin_decl_explicit (BUILT_IN_ISFINITE),
1011 1, arg);
1012
1013 res = gfc_create_var (integer_type_nodeinteger_types[itk_int], NULL__null);
1014 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1015 gfc_build_addr_expr (NULL_TREE(tree) __null, res));
1016 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_nodeinteger_types[itk_int],
1017 tmp, res);
1018 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_nodeinteger_types[itk_int],
1019 cond, tmp, huge);
1020
1021 type = gfc_typenode_for_spec (&expr->ts);
1022 se->expr = fold_convert (type, se->expr)fold_convert_loc (((location_t) 0), type, se->expr);
1023}
1024
1025
1026/* Fill in the following structure
1027 struct caf_vector_t {
1028 size_t nvec; // size of the vector
1029 union {
1030 struct {
1031 void *vector;
1032 int kind;
1033 } v;
1034 struct {
1035 ptrdiff_t lower_bound;
1036 ptrdiff_t upper_bound;
1037 ptrdiff_t stride;
1038 } triplet;
1039 } u;
1040 } */
1041
1042static void
1043conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
1044 tree lower, tree upper, tree stride,
1045 tree vector, int kind, tree nvec)
1046{
1047 tree field, type, tmp;
1048
1049 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE(tree) __null);
1050 type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1050, __FUNCTION__))->typed.type)
;
1051
1052 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1052, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1053 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-intrinsic.c"
, 1053, __FUNCTION__))->typed.type)
,
1054 desc, field, NULL_TREE(tree) __null);
1055 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1055, __FUNCTION__))->typed.type), nvec)
);
1056
1057 /* Access union. */
1058 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1058, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1059 desc = 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-intrinsic.c"
, 1059, __FUNCTION__))->typed.type)
,
1060 desc, field, NULL_TREE(tree) __null);
1061 type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1061, __FUNCTION__))->typed.type)
;
1062
1063 /* Access the inner struct. */
1064 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1064, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, vector != NULL_TREE(tree) __null ? 0 : 1);
1065 desc = 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-intrinsic.c"
, 1065, __FUNCTION__))->typed.type)
,
1066 desc, field, NULL_TREE(tree) __null);
1067 type = TREE_TYPE (desc)((contains_struct_check ((desc), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1067, __FUNCTION__))->typed.type)
;
1068
1069 if (vector != NULL_TREE(tree) __null)
1070 {
1071 /* Set vector and kind. */
1072 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1072, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1073 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-intrinsic.c"
, 1073, __FUNCTION__))->typed.type)
,
1074 desc, field, NULL_TREE(tree) __null);
1075 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1075, __FUNCTION__))->typed.type), vector)
);
1076 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1076, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1077 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-intrinsic.c"
, 1077, __FUNCTION__))->typed.type)
,
1078 desc, field, NULL_TREE(tree) __null);
1079 gfc_add_modify (block, tmp, build_int_cst (integer_type_nodeinteger_types[itk_int], kind));
1080 }
1081 else
1082 {
1083 /* Set dim.lower/upper/stride. */
1084 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1084, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1085 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-intrinsic.c"
, 1085, __FUNCTION__))->typed.type)
,
1086 desc, field, NULL_TREE(tree) __null);
1087 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1087, __FUNCTION__))->typed.type), lower)
);
1088
1089 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1089, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1090 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-intrinsic.c"
, 1090, __FUNCTION__))->typed.type)
,
1091 desc, field, NULL_TREE(tree) __null);
1092 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1092, __FUNCTION__))->typed.type), upper)
);
1093
1094 field = gfc_advance_chain (TYPE_FIELDS (type)((tree_check3 ((type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1094, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 2);
1095 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-intrinsic.c"
, 1095, __FUNCTION__))->typed.type)
,
1096 desc, field, NULL_TREE(tree) __null);
1097 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1097, __FUNCTION__))->typed.type), stride)
);
1098 }
1099}
1100
1101
1102static tree
1103conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1104{
1105 gfc_se argse;
1106 tree var, lower, upper = NULL_TREE(tree) __null, stride = NULL_TREE(tree) __null, vector, nvec;
1107 tree lbound, ubound, tmp;
1108 int i;
1109
1110 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1111
1112 for (i = 0; i < ar->dimen; i++)
1113 switch (ar->dimen_type[i])
1114 {
1115 case DIMEN_RANGE:
1116 if (ar->end[i])
1117 {
1118 gfc_init_se (&argse, NULL__null);
1119 gfc_conv_expr (&argse, ar->end[i]);
1120 gfc_add_block_to_block (block, &argse.pre);
1121 upper = gfc_evaluate_now (argse.expr, block);
1122 }
1123 else
1124 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1125 if (ar->stride[i])
1126 {
1127 gfc_init_se (&argse, NULL__null);
1128 gfc_conv_expr (&argse, ar->stride[i]);
1129 gfc_add_block_to_block (block, &argse.pre);
1130 stride = gfc_evaluate_now (argse.expr, block);
1131 }
1132 else
1133 stride = gfc_index_one_nodegfc_rank_cst[1];
1134
1135 /* Fall through. */
1136 case DIMEN_ELEMENT:
1137 if (ar->start[i])
1138 {
1139 gfc_init_se (&argse, NULL__null);
1140 gfc_conv_expr (&argse, ar->start[i]);
1141 gfc_add_block_to_block (block, &argse.pre);
1142 lower = gfc_evaluate_now (argse.expr, block);
1143 }
1144 else
1145 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1146 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1147 {
1148 upper = lower;
1149 stride = gfc_index_one_nodegfc_rank_cst[1];
1150 }
1151 vector = NULL_TREE(tree) __null;
1152 nvec = size_zero_nodeglobal_trees[TI_SIZE_ZERO];
1153 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1154 vector, 0, nvec);
1155 break;
1156
1157 case DIMEN_VECTOR:
1158 gfc_init_se (&argse, NULL__null);
1159 argse.descriptor_only = 1;
1160 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1161 gfc_add_block_to_block (block, &argse.pre);
1162 vector = argse.expr;
1163 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1164 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1165 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
1166 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1167 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1168 TREE_TYPE (nvec)((contains_struct_check ((nvec), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1168, __FUNCTION__))->typed.type)
, nvec, tmp);
1169 lower = gfc_index_zero_nodegfc_rank_cst[0];
1170 upper = gfc_index_zero_nodegfc_rank_cst[0];
1171 stride = gfc_index_zero_nodegfc_rank_cst[0];
1172 vector = gfc_conv_descriptor_data_get (vector);
1173 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1174 vector, ar->start[i]->ts.kind, nvec);
1175 break;
1176 default:
1177 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1177, __FUNCTION__))
;
1178 }
1179 return gfc_build_addr_expr (NULL_TREE(tree) __null, var);
1180}
1181
1182
1183static tree
1184compute_component_offset (tree field, tree type)
1185{
1186 tree tmp;
1187 if (DECL_FIELD_BIT_OFFSET (field)((tree_check ((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1187, __FUNCTION__, (FIELD_DECL)))->field_decl.bit_offset
)
!= NULL_TREE(tree) __null
1188 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)((tree_check ((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1188, __FUNCTION__, (FIELD_DECL)))->field_decl.bit_offset
)
))
1189 {
1190 tmp = fold_build2 (TRUNC_DIV_EXPR, type,fold_build2_loc (((location_t) 0), TRUNC_DIV_EXPR, type, ((tree_check
((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1191, __FUNCTION__, (FIELD_DECL)))->field_decl.bit_offset
), global_trees[TI_BITSIZE_UNIT] )
1191 DECL_FIELD_BIT_OFFSET (field),fold_build2_loc (((location_t) 0), TRUNC_DIV_EXPR, type, ((tree_check
((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1191, __FUNCTION__, (FIELD_DECL)))->field_decl.bit_offset
), global_trees[TI_BITSIZE_UNIT] )
1192 bitsize_unit_node)fold_build2_loc (((location_t) 0), TRUNC_DIV_EXPR, type, ((tree_check
((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1191, __FUNCTION__, (FIELD_DECL)))->field_decl.bit_offset
), global_trees[TI_BITSIZE_UNIT] )
;
1193 return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp)fold_build2_loc (((location_t) 0), PLUS_EXPR, type, ((tree_check
((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1193, __FUNCTION__, (FIELD_DECL)))->field_decl.offset), tmp
)
;
1194 }
1195 else
1196 return DECL_FIELD_OFFSET (field)((tree_check ((field), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1196, __FUNCTION__, (FIELD_DECL)))->field_decl.offset)
;
1197}
1198
1199
1200static tree
1201conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1202{
1203 gfc_ref *ref = expr->ref, *last_comp_ref;
1204 tree caf_ref = NULL_TREE(tree) __null, prev_caf_ref = NULL_TREE(tree) __null, reference_type, tmp, tmp2,
1205 field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1206 start, end, stride, vector, nvec;
1207 gfc_se se;
1208 bool ref_static_array = false;
1209 tree last_component_ref_tree = NULL_TREE(tree) __null;
1210 int i, last_type_n;
1211
1212 if (expr->symtree)
1213 {
1214 last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1215 ref_static_array = !expr->symtree->n.sym->attr.allocatable
1216 && !expr->symtree->n.sym->attr.pointer;
1217 }
1218
1219 /* Prevent uninit-warning. */
1220 reference_type = NULL_TREE(tree) __null;
1221
1222 /* Skip refs upto the first coarray-ref. */
1223 last_comp_ref = NULL__null;
1224 while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1225 {
1226 /* Remember the type of components skipped. */
1227 if (ref->type == REF_COMPONENT)
1228 last_comp_ref = ref;
1229 ref = ref->next;
1230 }
1231 /* When a component was skipped, get the type information of the last
1232 component ref, else get the type from the symbol. */
1233 if (last_comp_ref)
1234 {
1235 last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1236 last_type_n = last_comp_ref->u.c.component->ts.type;
1237 }
1238 else
1239 {
1240 last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1241 last_type_n = expr->symtree->n.sym->ts.type;
1242 }
1243
1244 while (ref)
1245 {
1246 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1247 && ref->u.ar.dimen == 0)
1248 {
1249 /* Skip pure coindexes. */
1250 ref = ref->next;
1251 continue;
1252 }
1253 tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1254 reference_type = TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1254, __FUNCTION__))->typed.type)
;
1255
1256 if (caf_ref == NULL_TREE(tree) __null)
1257 caf_ref = tmp;
1258
1259 /* Construct the chain of refs. */
1260 if (prev_caf_ref != NULL_TREE(tree) __null)
1261 {
1262 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1262, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1263 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1264 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1264, __FUNCTION__))->typed.type)
, prev_caf_ref, field,
1265 NULL_TREE(tree) __null);
1266 gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1266, __FUNCTION__))->typed.type)
,
1267 tmp));
1268 }
1269 prev_caf_ref = tmp;
1270
1271 switch (ref->type)
1272 {
1273 case REF_COMPONENT:
1274 last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1275 last_type_n = ref->u.c.component->ts.type;
1276 /* Set the type of the ref. */
1277 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1277, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1278 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1279 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1279, __FUNCTION__))->typed.type)
, prev_caf_ref, field,
1280 NULL_TREE(tree) __null);
1281 gfc_add_modify (block, tmp, build_int_cst (integer_type_nodeinteger_types[itk_int],
1282 GFC_CAF_REF_COMPONENT));
1283
1284 /* Ref the c in union u. */
1285 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1285, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 3);
1286 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1287 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1287, __FUNCTION__))->typed.type)
, prev_caf_ref, field,
1288 NULL_TREE(tree) __null);
1289 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field))((tree_check3 ((((contains_struct_check ((field), (TS_TYPED),
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1289, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1289, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1290 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1291 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1291, __FUNCTION__))->typed.type)
, tmp, field,
1292 NULL_TREE(tree) __null);
1293
1294 /* Set the offset. */
1295 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct))((tree_check3 ((((contains_struct_check ((inner_struct), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1295, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1295, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1296 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1297 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1297, __FUNCTION__))->typed.type)
, inner_struct, field,
1298 NULL_TREE(tree) __null);
1299 /* Computing the offset is somewhat harder. The bit_offset has to be
1300 taken into account. When the bit_offset in the field_decl is non-
1301 null, divide it by the bitsize_unit and add it to the regular
1302 offset. */
1303 tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1304 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1304, __FUNCTION__))->typed.type)
);
1305 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1305, __FUNCTION__))->typed.type), tmp2)
);
1306
1307 /* Set caf_token_offset. */
1308 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct))((tree_check3 ((((contains_struct_check ((inner_struct), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1308, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1308, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1309 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1310 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1310, __FUNCTION__))->typed.type)
, inner_struct, field,
1311 NULL_TREE(tree) __null);
1312 if ((ref->u.c.component->attr.allocatable
1313 || ref->u.c.component->attr.pointer)
1314 && ref->u.c.component->attr.dimension)
1315 {
1316 tree arr_desc_token_offset;
1317 /* Get the token field from the descriptor. */
1318 arr_desc_token_offset = TREE_OPERAND ((*((const_cast<tree*> (tree_operand_check ((gfc_conv_descriptor_token
(ref->u.c.component->backend_decl)), (1), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1319, __FUNCTION__)))))
1319 gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1)(*((const_cast<tree*> (tree_operand_check ((gfc_conv_descriptor_token
(ref->u.c.component->backend_decl)), (1), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1319, __FUNCTION__)))))
;
1320 arr_desc_token_offset
1321 = compute_component_offset (arr_desc_token_offset,
1322 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1322, __FUNCTION__))->typed.type)
);
1323 tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1324 TREE_TYPE (tmp2)((contains_struct_check ((tmp2), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1324, __FUNCTION__))->typed.type)
, tmp2,
1325 arr_desc_token_offset);
1326 }
1327 else if (ref->u.c.component->caf_token)
1328 tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1329 TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1329, __FUNCTION__))->typed.type)
);
1330 else
1331 tmp2 = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
1332 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1332, __FUNCTION__))->typed.type), tmp2)
);
1333
1334 /* Remember whether this ref was to a non-allocatable/non-pointer
1335 component so the next array ref can be tailored correctly. */
1336 ref_static_array = !ref->u.c.component->attr.allocatable
1337 && !ref->u.c.component->attr.pointer;
1338 last_component_ref_tree = ref_static_array
1339 ? ref->u.c.component->backend_decl : NULL_TREE(tree) __null;
1340 break;
1341 case REF_ARRAY:
1342 if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1343 ref_static_array = false;
1344 /* Set the type of the ref. */
1345 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1345, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1346 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1347 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1347, __FUNCTION__))->typed.type)
, prev_caf_ref, field,
1348 NULL_TREE(tree) __null);
1349 gfc_add_modify (block, tmp, build_int_cst (integer_type_nodeinteger_types[itk_int],
1350 ref_static_array
1351 ? GFC_CAF_REF_STATIC_ARRAY
1352 : GFC_CAF_REF_ARRAY));
1353
1354 /* Ref the a in union u. */
1355 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1355, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 3);
1356 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1357 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1357, __FUNCTION__))->typed.type)
, prev_caf_ref, field,
1358 NULL_TREE(tree) __null);
1359 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field))((tree_check3 ((((contains_struct_check ((field), (TS_TYPED),
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1359, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1359, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1360 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1361 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1361, __FUNCTION__))->typed.type)
, tmp, field,
1362 NULL_TREE(tree) __null);
1363
1364 /* Set the static_array_type in a for static arrays. */
1365 if (ref_static_array)
1366 {
1367 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct))((tree_check3 ((((contains_struct_check ((inner_struct), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1367, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1367, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
1368 1);
1369 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1370 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1370, __FUNCTION__))->typed.type)
, inner_struct, field,
1371 NULL_TREE(tree) __null);
1372 gfc_add_modify (block, tmp, 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-intrinsic.c"
, 1372, __FUNCTION__))->typed.type)
,
1373 last_type_n));
1374 }
1375 /* Ref the mode in the inner_struct. */
1376 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct))((tree_check3 ((((contains_struct_check ((inner_struct), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1376, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1376, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1377 mode = fold_build3_loc (input_location, COMPONENT_REF,
1378 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1378, __FUNCTION__))->typed.type)
, inner_struct, field,
1379 NULL_TREE(tree) __null);
1380 /* Ref the dim in the inner_struct. */
1381 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct))((tree_check3 ((((contains_struct_check ((inner_struct), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1381, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1381, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 2);
1382 dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1383 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1383, __FUNCTION__))->typed.type)
, inner_struct, field,
1384 NULL_TREE(tree) __null);
1385 for (i = 0; i < ref->u.ar.dimen; ++i)
1386 {
1387 /* Ref dim i. */
1388 dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE(tree) __null);
1389 dim_type = TREE_TYPE (dim)((contains_struct_check ((dim), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1389, __FUNCTION__))->typed.type)
;
1390 mode_rhs = start = end = stride = NULL_TREE(tree) __null;
1391 switch (ref->u.ar.dimen_type[i])
1392 {
1393 case DIMEN_RANGE:
1394 if (ref->u.ar.end[i])
1395 {
1396 gfc_init_se (&se, NULL__null);
1397 gfc_conv_expr (&se, ref->u.ar.end[i]);
1398 gfc_add_block_to_block (block, &se.pre);
1399 if (ref_static_array)
1400 {
1401 /* Make the index zero-based, when reffing a static
1402 array. */
1403 end = se.expr;
1404 gfc_init_se (&se, NULL__null);
1405 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1406 gfc_add_block_to_block (block, &se.pre);
1407 se.expr = fold_build2 (MINUS_EXPR,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, end, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1408 gfc_array_index_type,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, end, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1409 end, fold_convert (fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, end, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1410 gfc_array_index_type,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, end, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1411 se.expr))fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, end, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
;
1412 }
1413 end = gfc_evaluate_now (fold_convert (fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1414 gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1415 se.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
,
1416 block);
1417 }
1418 else if (ref_static_array)
1419 end = fold_build2 (MINUS_EXPR,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
1420 gfc_array_index_type,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
1421 gfc_conv_array_ubound (fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
1422 last_component_ref_tree, i),fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
1423 gfc_conv_array_lbound (fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
1424 last_component_ref_tree, i))fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, gfc_conv_array_ubound ( last_component_ref_tree, i), gfc_conv_array_lbound
( last_component_ref_tree, i) )
;
1425 else
1426 {
1427 end = NULL_TREE(tree) __null;
1428 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1429 GFC_CAF_ARR_REF_OPEN_END);
1430 }
1431 if (ref->u.ar.stride[i])
1432 {
1433 gfc_init_se (&se, NULL__null);
1434 gfc_conv_expr (&se, ref->u.ar.stride[i]);
1435 gfc_add_block_to_block (block, &se.pre);
1436 stride = gfc_evaluate_now (fold_convert (fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1437 gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1438 se.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
,
1439 block);
1440 if (ref_static_array)
1441 {
1442 /* Make the index zero-based, when reffing a static
1443 array. */
1444 stride = fold_build2 (MULT_EXPR,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
1445 gfc_array_index_type,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
1446 gfc_conv_array_stride (fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
1447 last_component_ref_tree,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
1448 i),fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
1449 stride)fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, gfc_conv_array_stride ( last_component_ref_tree, i), stride
)
;
1450 gcc_assert (end != NULL_TREE)((void)(!(end != (tree) __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1450, __FUNCTION__), 0 : 0))
;
1451 /* Multiply with the product of array's stride and
1452 the step of the ref to a virtual upper bound.
1453 We cannot compute the actual upper bound here or
1454 the caflib would compute the extend
1455 incorrectly. */
1456 end = fold_build2 (MULT_EXPR, gfc_array_index_type,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, gfc_conv_array_stride ( last_component_ref_tree, i) )
1457 end, gfc_conv_array_stride (fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, gfc_conv_array_stride ( last_component_ref_tree, i) )
1458 last_component_ref_tree,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, gfc_conv_array_stride ( last_component_ref_tree, i) )
1459 i))fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, gfc_conv_array_stride ( last_component_ref_tree, i) )
;
1460 end = gfc_evaluate_now (end, block);
1461 stride = gfc_evaluate_now (stride, block);
1462 }
1463 }
1464 else if (ref_static_array)
1465 {
1466 stride = gfc_conv_array_stride (last_component_ref_tree,
1467 i);
1468 end = fold_build2 (MULT_EXPR, gfc_array_index_type,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, stride )
1469 end, stride)fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, end, stride )
;
1470 end = gfc_evaluate_now (end, block);
1471 }
1472 else
1473 /* Always set a ref stride of one to make caflib's
1474 handling easier. */
1475 stride = gfc_index_one_nodegfc_rank_cst[1];
1476
1477 /* Fall through. */
1478 case DIMEN_ELEMENT:
1479 if (ref->u.ar.start[i])
1480 {
1481 gfc_init_se (&se, NULL__null);
1482 gfc_conv_expr (&se, ref->u.ar.start[i]);
1483 gfc_add_block_to_block (block, &se.pre);
1484 if (ref_static_array)
1485 {
1486 /* Make the index zero-based, when reffing a static
1487 array. */
1488 start = fold_convert (gfc_array_index_type, se.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
;
1489 gfc_init_se (&se, NULL__null);
1490 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1491 gfc_add_block_to_block (block, &se.pre);
1492 se.expr = fold_build2 (MINUS_EXPR,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, start, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1493 gfc_array_index_type,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, start, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1494 start, fold_convert (fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, start, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1495 gfc_array_index_type,fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, start, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
1496 se.expr))fold_build2_loc (((location_t) 0), MINUS_EXPR, gfc_array_index_type
, start, fold_convert_loc (((location_t) 0), gfc_array_index_type
, se.expr) )
;
1497 /* Multiply with the stride. */
1498 se.expr = fold_build2 (MULT_EXPR,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
1499 gfc_array_index_type,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
1500 se.expr,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
1501 gfc_conv_array_stride (fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
1502 last_component_ref_tree,fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
1503 i))fold_build2_loc (((location_t) 0), MULT_EXPR, gfc_array_index_type
, se.expr, gfc_conv_array_stride ( last_component_ref_tree, i
) )
;
1504 }
1505 start = gfc_evaluate_now (fold_convert (fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1506 gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
1507 se.expr)fold_convert_loc (((location_t) 0), gfc_array_index_type, se.
expr)
,
1508 block);
1509 if (mode_rhs == NULL_TREE(tree) __null)
1510 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1511 ref->u.ar.dimen_type[i]
1512 == DIMEN_ELEMENT
1513 ? GFC_CAF_ARR_REF_SINGLE
1514 : GFC_CAF_ARR_REF_RANGE);
1515 }
1516 else if (ref_static_array)
1517 {
1518 start = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
1519 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1520 ref->u.ar.start[i] == NULL__null
1521 ? GFC_CAF_ARR_REF_FULL
1522 : GFC_CAF_ARR_REF_RANGE);
1523 }
1524 else if (end == NULL_TREE(tree) __null)
1525 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1526 GFC_CAF_ARR_REF_FULL);
1527 else
1528 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1529 GFC_CAF_ARR_REF_OPEN_START);
1530
1531 /* Ref the s in dim. */
1532 field = gfc_advance_chain (TYPE_FIELDS (dim_type)((tree_check3 ((dim_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1532, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1533 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1534 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1534, __FUNCTION__))->typed.type)
, dim, field,
1535 NULL_TREE(tree) __null);
1536
1537 /* Set start in s. */
1538 if (start != NULL_TREE(tree) __null)
1539 {
1540 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1540, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1540, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
1541 0);
1542 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1543 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1543, __FUNCTION__))->typed.type)
, tmp, field,
1544 NULL_TREE(tree) __null);
1545 gfc_add_modify (block, tmp2,
1546 fold_convert (TREE_TYPE (tmp2), start)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-intrinsic.c"
, 1546, __FUNCTION__))->typed.type), start)
);
1547 }
1548
1549 /* Set end in s. */
1550 if (end != NULL_TREE(tree) __null)
1551 {
1552 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1552, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1552, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
1553 1);
1554 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1555 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1555, __FUNCTION__))->typed.type)
, tmp, field,
1556 NULL_TREE(tree) __null);
1557 gfc_add_modify (block, tmp2,
1558 fold_convert (TREE_TYPE (tmp2), end)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-intrinsic.c"
, 1558, __FUNCTION__))->typed.type), end)
);
1559 }
1560
1561 /* Set end in s. */
1562 if (stride != NULL_TREE(tree) __null)
1563 {
1564 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1564, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1564, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
,
1565 2);
1566 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1567 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1567, __FUNCTION__))->typed.type)
, tmp, field,
1568 NULL_TREE(tree) __null);
1569 gfc_add_modify (block, tmp2,
1570 fold_convert (TREE_TYPE (tmp2), stride)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-intrinsic.c"
, 1570, __FUNCTION__))->typed.type), stride)
);
1571 }
1572 break;
1573 case DIMEN_VECTOR:
1574 /* TODO: In case of static array. */
1575 gcc_assert (!ref_static_array)((void)(!(!ref_static_array) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1575, __FUNCTION__), 0 : 0))
;
1576 mode_rhs = build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1577 GFC_CAF_ARR_REF_VECTOR);
1578 gfc_init_se (&se, NULL__null);
1579 se.descriptor_only = 1;
1580 gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1581 gfc_add_block_to_block (block, &se.pre);
1582 vector = se.expr;
1583 tmp = gfc_conv_descriptor_lbound_get (vector,
1584 gfc_rank_cst[0]);
1585 tmp2 = gfc_conv_descriptor_ubound_get (vector,
1586 gfc_rank_cst[0]);
1587 nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL__null);
1588 tmp = gfc_conv_descriptor_stride_get (vector,
1589 gfc_rank_cst[0]);
1590 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1591 TREE_TYPE (nvec)((contains_struct_check ((nvec), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1591, __FUNCTION__))->typed.type)
, nvec, tmp);
1592 vector = gfc_conv_descriptor_data_get (vector);
1593
1594 /* Ref the v in dim. */
1595 field = gfc_advance_chain (TYPE_FIELDS (dim_type)((tree_check3 ((dim_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1595, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1596 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1597 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1597, __FUNCTION__))->typed.type)
, dim, field,
1598 NULL_TREE(tree) __null);
1599
1600 /* Set vector in v. */
1601 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1601, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1601, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1602 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1603 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1603, __FUNCTION__))->typed.type)
, tmp, field,
1604 NULL_TREE(tree) __null);
1605 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-intrinsic.c"
, 1605, __FUNCTION__))->typed.type), vector)
1606 vector)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-intrinsic.c"
, 1605, __FUNCTION__))->typed.type), vector)
);
1607
1608 /* Set nvec in v. */
1609 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1609, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1609, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 1);
1610 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1611 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1611, __FUNCTION__))->typed.type)
, tmp, field,
1612 NULL_TREE(tree) __null);
1613 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-intrinsic.c"
, 1613, __FUNCTION__))->typed.type), nvec)
1614 nvec)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-intrinsic.c"
, 1613, __FUNCTION__))->typed.type), nvec)
);
1615
1616 /* Set kind in v. */
1617 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp))((tree_check3 ((((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1617, __FUNCTION__))->typed.type)), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1617, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 2);
1618 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1619 TREE_TYPE (field)((contains_struct_check ((field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1619, __FUNCTION__))->typed.type)
, tmp, field,
1620 NULL_TREE(tree) __null);
1621 gfc_add_modify (block, tmp2, build_int_cst (integer_type_nodeinteger_types[itk_int],
1622 ref->u.ar.start[i]->ts.kind));
1623 break;
1624 default:
1625 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1625, __FUNCTION__))
;
1626 }
1627 /* Set the mode for dim i. */
1628 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE(tree) __null);
1629 gfc_add_modify (block, tmp, 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-intrinsic.c"
, 1629, __FUNCTION__))->typed.type), mode_rhs)
1630 mode_rhs)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-intrinsic.c"
, 1629, __FUNCTION__))->typed.type), mode_rhs)
);
1631 }
1632
1633 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1634 if (i < GFC_MAX_DIMENSIONS15)
1635 {
1636 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE(tree) __null);
1637 gfc_add_modify (block, tmp,
1638 build_int_cst (unsigned_char_type_nodeinteger_types[itk_unsigned_char],
1639 GFC_CAF_ARR_REF_NONE));
1640 }
1641 break;
1642 default:
1643 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1643, __FUNCTION__))
;
1644 }
1645
1646 /* Set the size of the current type. */
1647 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1647, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 2);
1648 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-intrinsic.c"
, 1648, __FUNCTION__))->typed.type)
,
1649 prev_caf_ref, field, NULL_TREE(tree) __null);
1650 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1650, __FUNCTION__))->typed.type), ((tree_class_check ((
last_type), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1651, __FUNCTION__))->type_common.size_unit))
1651 TYPE_SIZE_UNIT (last_type))fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1650, __FUNCTION__))->typed.type), ((tree_class_check ((
last_type), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1651, __FUNCTION__))->type_common.size_unit))
);
1652
1653 ref = ref->next;
1654 }
1655
1656 if (prev_caf_ref != NULL_TREE(tree) __null)
1657 {
1658 field = gfc_advance_chain (TYPE_FIELDS (reference_type)((tree_check3 ((reference_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1658, __FUNCTION__, (RECORD_TYPE), (UNION_TYPE), (QUAL_UNION_TYPE
)))->type_non_common.values)
, 0);
1659 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-intrinsic.c"
, 1659, __FUNCTION__))->typed.type)
,
1660 prev_caf_ref, field, NULL_TREE(tree) __null);
1661 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1661, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
1662 null_pointer_node)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(field), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1661, __FUNCTION__))->typed.type), global_trees[TI_NULL_POINTER
])
);
1663 }
1664 return caf_ref != NULL_TREE(tree) __null ? gfc_build_addr_expr (NULL_TREE(tree) __null, caf_ref)
1665 : NULL_TREE(tree) __null;
1666}
1667
1668/* Get data from a remote coarray. */
1669
1670static void
1671gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1672 tree may_require_tmp, bool may_realloc,
1673 symbol_attribute *caf_attr)
1674{
1675 gfc_expr *array_expr, *tmp_stat;
1676 gfc_se argse;
1677 tree caf_decl, token, offset, image_index, tmp;
1678 tree res_var, dst_var, type, kind, vec, stat;
1679 tree caf_reference;
1680 symbol_attribute caf_attr_store;
1681
1682 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB)((void)(!(global_options.x_flag_coarray == GFC_FCOARRAY_LIB) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1682, __FUNCTION__), 0 : 0))
;
1683
1684 if (se->ss && se->ss->info->useflags)
1685 {
1686 /* Access the previously obtained result. */
1687 gfc_conv_tmp_array_ref (se);
1688 return;
1689 }
1690
1691 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1692 array_expr = (lhs == NULL_TREE(tree) __null) ? expr->value.function.actual->expr : expr;
1693 type = gfc_typenode_for_spec (&array_expr->ts);
1694
1695 if (caf_attr == NULL__null)
1696 {
1697 caf_attr_store = gfc_caf_attr (array_expr);
1698 caf_attr = &caf_attr_store;
1699 }
1700
1701 res_var = lhs;
1702 dst_var = lhs;
1703
1704 vec = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1705 tmp_stat = gfc_find_stat_co (expr);
1706
1707 if (tmp_stat)
1708 {
1709 gfc_se stat_se;
1710 gfc_init_se (&stat_se, NULL__null);
1711 gfc_conv_expr_reference (&stat_se, tmp_stat);
1712 stat = stat_se.expr;
1713 gfc_add_block_to_block (&se->pre, &stat_se.pre);
1714 gfc_add_block_to_block (&se->post, &stat_se.post);
1715 }
1716 else
1717 stat = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1718
1719 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1720 is reallocatable or the right-hand side has allocatable components. */
1721 if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1722 {
1723 /* Get using caf_get_by_ref. */
1724 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1725
1726 if (caf_reference != NULL_TREE(tree) __null)
1727 {
1728 if (lhs == NULL_TREE(tree) __null)
1729 {
1730 if (array_expr->ts.type == BT_CHARACTER)
1731 gfc_init_se (&argse, NULL__null);
1732 if (array_expr->rank == 0)
1733 {
1734 symbol_attribute attr;
1735 gfc_clear_attr (&attr);
1736 if (array_expr->ts.type == BT_CHARACTER)
1737 {
1738 res_var = gfc_conv_string_tmp (se,
1739 build_pointer_type (type),
1740 array_expr->ts.u.cl->backend_decl);
1741 argse.string_length = array_expr->ts.u.cl->backend_decl;
1742 }
1743 else
1744 res_var = gfc_create_var (type, "caf_res");
1745 dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1746 dst_var = gfc_build_addr_expr (NULL_TREE(tree) __null, dst_var);
1747 }
1748 else
1749 {
1750 /* Create temporary. */
1751 if (array_expr->ts.type == BT_CHARACTER)
1752 gfc_conv_expr_descriptor (&argse, array_expr);
1753 may_realloc = gfc_trans_create_temp_array (&se->pre,
1754 &se->post,
1755 se->ss, type,
1756 NULL_TREE(tree) __null, false,
1757 false, false,
1758 &array_expr->where)
1759 == NULL_TREE(tree) __null;
1760 res_var = se->ss->info->data.array.descriptor;
1761 dst_var = gfc_build_addr_expr (NULL_TREE(tree) __null, res_var);
1762 if (may_realloc)
1763 {
1764 tmp = gfc_conv_descriptor_data_get (res_var);
1765 tmp = gfc_deallocate_with_status (tmp, NULL_TREE(tree) __null,
1766 NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1767 NULL_TREE(tree) __null, true,
1768 NULL__null,
1769 GFC_CAF_COARRAY_NOCOARRAY);
1770 gfc_add_expr_to_block (&se->post, tmp);
1771 }
1772 }
1773 }
1774
1775 kind = build_int_cst (integer_type_nodeinteger_types[itk_int], expr->ts.kind);
1776 if (lhs_kind == NULL_TREE(tree) __null)
1777 lhs_kind = kind;
1778
1779 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1780 if (TREE_CODE (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-intrinsic.c"
, 1780, __FUNCTION__))->typed.type))->base.code)
== REFERENCE_TYPE)
1781 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1782 image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1783 caf_decl);
1784 gfc_get_caf_token_offset (se, &token, NULL__null, caf_decl, NULL__null,
1785 array_expr);
1786
1787 /* No overlap possible as we have generated a temporary. */
1788 if (lhs == NULL_TREE(tree) __null)
1789 may_require_tmp = boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE];
1790
1791 /* It guarantees memory consistency within the same segment. */
1792 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1793 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1794 gfc_build_string_const (1, ""), NULL_TREE(tree) __null,
1795 NULL_TREE(tree) __null, tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null),
1796 NULL_TREE(tree) __null);
1797 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1797, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1798 gfc_add_expr_to_block (&se->pre, tmp);
1799
1800 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1801 10, token, image_index, dst_var,
1802 caf_reference, lhs_kind, kind,
1803 may_require_tmp,
1804 may_realloc ? boolean_true_nodeglobal_trees[TI_BOOLEAN_TRUE] :
1805 boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE],
1806 stat, build_int_cst (integer_type_nodeinteger_types[itk_int],
1807 array_expr->ts.type));
1808
1809 gfc_add_expr_to_block (&se->pre, tmp);
1810
1811 if (se->ss)
1812 gfc_advance_se_ss_chain (se);
1813
1814 se->expr = res_var;
1815 if (array_expr->ts.type == BT_CHARACTER)
1816 se->string_length = argse.string_length;
1817
1818 return;
1819 }
1820 }
1821
1822 gfc_init_se (&argse, NULL__null);
1823 if (array_expr->rank == 0)
1824 {
1825 symbol_attribute attr;
1826
1827 gfc_clear_attr (&attr);
1828 gfc_conv_expr (&argse, array_expr);
1829
1830 if (lhs == NULL_TREE(tree) __null)
1831 {
1832 gfc_clear_attr (&attr);
1833 if (array_expr->ts.type == BT_CHARACTER)
1834 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1835 argse.string_length);
1836 else
1837 res_var = gfc_create_var (type, "caf_res");
1838 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1839 dst_var = gfc_build_addr_expr (NULL_TREE(tree) __null, dst_var);
1840 }
1841 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1842 argse.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, argse.expr);
1843 }
1844 else
1845 {
1846 /* If has_vector, pass descriptor for whole array and the
1847 vector bounds separately. */
1848 gfc_array_ref *ar, ar2;
1849 bool has_vector = false;
1850
1851 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1852 {
1853 has_vector = true;
1854 ar = gfc_find_array_ref (expr);
1855 ar2 = *ar;
1856 memset (ar, '\0', sizeof (*ar));
1857 ar->as = ar2.as;
1858 ar->type = AR_FULL;
1859 }
1860 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1861 gfc_conv_expr_descriptor (&argse, array_expr);
1862 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1863 has the wrong type if component references are done. */
1864 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1865 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1866 : array_expr->rank,
1867 type));
1868 if (has_vector)
1869 {
1870 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1871 *ar = ar2;
1872 }
1873
1874 if (lhs == NULL_TREE(tree) __null)
1875 {
1876 /* Create temporary. */
1877 for (int n = 0; n < se->ss->loop->dimen; n++)
1878 if (se->loop->to[n] == NULL_TREE(tree) __null)
1879 {
1880 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1881 gfc_rank_cst[n]);
1882 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1883 gfc_rank_cst[n]);
1884 }
1885 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1886 NULL_TREE(tree) __null, false, true, false,
1887 &array_expr->where);
1888 res_var = se->ss->info->data.array.descriptor;
1889 dst_var = gfc_build_addr_expr (NULL_TREE(tree) __null, res_var);
1890 }
1891 argse.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, argse.expr);
1892 }
1893
1894 kind = build_int_cst (integer_type_nodeinteger_types[itk_int], expr->ts.kind);
1895 if (lhs_kind == NULL_TREE(tree) __null)
1896 lhs_kind = kind;
1897
1898 gfc_add_block_to_block (&se->pre, &argse.pre);
1899 gfc_add_block_to_block (&se->post, &argse.post);
1900
1901 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1902 if (TREE_CODE (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-intrinsic.c"
, 1902, __FUNCTION__))->typed.type))->base.code)
== REFERENCE_TYPE)
1903 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1904 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1905 gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1906 array_expr);
1907
1908 /* No overlap possible as we have generated a temporary. */
1909 if (lhs == NULL_TREE(tree) __null)
1910 may_require_tmp = boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE];
1911
1912 /* It guarantees memory consistency within the same segment. */
1913 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1914 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
1915 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
1916 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
1917 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1917, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
1918 gfc_add_expr_to_block (&se->pre, tmp);
1919
1920 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1921 token, offset, image_index, argse.expr, vec,
1922 dst_var, kind, lhs_kind, may_require_tmp, stat);
1923
1924 gfc_add_expr_to_block (&se->pre, tmp);
1925
1926 if (se->ss)
1927 gfc_advance_se_ss_chain (se);
1928
1929 se->expr = res_var;
1930 if (array_expr->ts.type == BT_CHARACTER)
1931 se->string_length = argse.string_length;
1932}
1933
1934
1935/* Send data to a remote coarray. */
1936
1937static tree
1938conv_caf_send (gfc_code *code) {
1939 gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1940 gfc_se lhs_se, rhs_se;
1941 stmtblock_t block;
1942 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1943 tree may_require_tmp, src_stat, dst_stat, dst_team;
1944 tree lhs_type = NULL_TREE(tree) __null;
1945 tree vec = null_pointer_nodeglobal_trees[TI_NULL_POINTER], rhs_vec = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1946 symbol_attribute lhs_caf_attr, rhs_caf_attr;
1947
1948 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB)((void)(!(global_options.x_flag_coarray == GFC_FCOARRAY_LIB) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1948, __FUNCTION__), 0 : 0))
;
1949
1950 lhs_expr = code->ext.actual->expr;
1951 rhs_expr = code->ext.actual->next->expr;
1952 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1953 ? boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE] : boolean_true_nodeglobal_trees[TI_BOOLEAN_TRUE];
1954 gfc_init_block (&block);
1955
1956 lhs_caf_attr = gfc_caf_attr (lhs_expr);
1957 rhs_caf_attr = gfc_caf_attr (rhs_expr);
1958 src_stat = dst_stat = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1959 dst_team = null_pointer_nodeglobal_trees[TI_NULL_POINTER];
1960
1961 /* LHS. */
1962 gfc_init_se (&lhs_se, NULL__null);
1963 if (lhs_expr->rank == 0)
1964 {
1965 if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1966 {
1967 lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1968 lhs_se.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, lhs_se.expr);
1969 }
1970 else
1971 {
1972 symbol_attribute attr;
1973 gfc_clear_attr (&attr);
1974 gfc_conv_expr (&lhs_se, lhs_expr);
1975 lhs_type = TREE_TYPE (lhs_se.expr)((contains_struct_check ((lhs_se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 1975, __FUNCTION__))->typed.type)
;
1976 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1977 attr);
1978 lhs_se.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, lhs_se.expr);
1979 }
1980 }
1981 else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1982 && lhs_caf_attr.codimension)
1983 {
1984 lhs_se.want_pointer = 1;
1985 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1986 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1987 has the wrong type if component references are done. */
1988 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1989 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1990 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1991 gfc_get_dtype_rank_type (
1992 gfc_has_vector_subscript (lhs_expr)
1993 ? gfc_find_array_ref (lhs_expr)->dimen
1994 : lhs_expr->rank,
1995 lhs_type));
1996 }
1997 else
1998 {
1999 bool has_vector = gfc_has_vector_subscript (lhs_expr);
2000
2001 if (gfc_is_coindexed (lhs_expr) || !has_vector)
2002 {
2003 /* If has_vector, pass descriptor for whole array and the
2004 vector bounds separately. */
2005 gfc_array_ref *ar, ar2;
2006 bool has_tmp_lhs_array = false;
2007 if (has_vector)
2008 {
2009 has_tmp_lhs_array = true;
2010 ar = gfc_find_array_ref (lhs_expr);
2011 ar2 = *ar;
2012 memset (ar, '\0', sizeof (*ar));
2013 ar->as = ar2.as;
2014 ar->type = AR_FULL;
2015 }
2016 lhs_se.want_pointer = 1;
2017 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
2018 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2019 that has the wrong type if component references are done. */
2020 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2021 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
2022 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2023 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2024 : lhs_expr->rank,
2025 lhs_type));
2026 if (has_tmp_lhs_array)
2027 {
2028 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
2029 *ar = ar2;
2030 }
2031 }
2032 else
2033 {
2034 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2035 indexed array expression. This is rewritten to:
2036
2037 tmp_array = arr2[...]
2038 arr1 ([...]) = tmp_array
2039
2040 because using the standard gfc_conv_expr (lhs_expr) did the
2041 assignment with lhs and rhs exchanged. */
2042
2043 gfc_ss *lss_for_tmparray, *lss_real;
2044 gfc_loopinfo loop;
2045 gfc_se se;
2046 stmtblock_t body;
2047 tree tmparr_desc, src;
2048 tree index = gfc_index_zero_nodegfc_rank_cst[0];
2049 tree stride = gfc_index_zero_nodegfc_rank_cst[0];
2050 int n;
2051
2052 /* Walk both sides of the assignment, once to get the shape of the
2053 temporary array to create right. */
2054 lss_for_tmparray = gfc_walk_expr (lhs_expr);
2055 /* And a second time to be able to create an assignment of the
2056 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2057 the tree in the descriptor with the one for the temporary
2058 array. */
2059 lss_real = gfc_walk_expr (lhs_expr);
2060 gfc_init_loopinfo (&loop);
2061 gfc_add_ss_to_loop (&loop, lss_for_tmparray);
2062 gfc_add_ss_to_loop (&loop, lss_real);
2063 gfc_conv_ss_startstride (&loop);
2064 gfc_conv_loop_setup (&loop, &lhs_expr->where);
2065 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2066 gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
2067 lss_for_tmparray, lhs_type, NULL_TREE(tree) __null,
2068 false, true, false,
2069 &lhs_expr->where);
2070 tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
2071 gfc_start_scalarized_body (&loop, &body);
2072 gfc_init_se (&se, NULL__null);
2073 gfc_copy_loopinfo_to_se (&se, &loop);
2074 se.ss = lss_real;
2075 gfc_conv_expr (&se, lhs_expr);
2076 gfc_add_block_to_block (&body, &se.pre);
2077
2078 /* Walk over all indexes of the loop. */
2079 for (n = loop.dimen - 1; n > 0; --n)
2080 {
2081 tmp = loop.loopvar[n];
2082 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2083 gfc_array_index_type, tmp, loop.from[n]);
2084 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2085 gfc_array_index_type, tmp, index);
2086
2087 stride = fold_build2_loc (input_location, MINUS_EXPR,
2088 gfc_array_index_type,
2089 loop.to[n - 1], loop.from[n - 1]);
2090 stride = fold_build2_loc (input_location, PLUS_EXPR,
2091 gfc_array_index_type,
2092 stride, gfc_index_one_nodegfc_rank_cst[1]);
2093
2094 index = fold_build2_loc (input_location, MULT_EXPR,
2095 gfc_array_index_type, tmp, stride);
2096 }
2097
2098 index = fold_build2_loc (input_location, MINUS_EXPR,
2099 gfc_array_index_type,
2100 index, loop.from[0]);
2101
2102 index = fold_build2_loc (input_location, PLUS_EXPR,
2103 gfc_array_index_type,
2104 loop.loopvar[0], index);
2105
2106 src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc))build_fold_indirect_ref_loc (((location_t) 0), gfc_conv_array_data
(tmparr_desc))
;
2107 src = gfc_build_array_ref (src, index, NULL__null);
2108 /* Now create the assignment of lhs_expr = tmp_array. */
2109 gfc_add_modify (&body, se.expr, src);
2110 gfc_add_block_to_block (&body, &se.post);
2111 lhs_se.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, tmparr_desc);
2112 gfc_trans_scalarizing_loops (&loop, &body);
2113 gfc_add_block_to_block (&loop.pre, &loop.post);
2114 gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2115 gfc_free_ss (lss_for_tmparray);
2116 gfc_free_ss (lss_real);
2117 }
2118 }
2119
2120 lhs_kind = build_int_cst (integer_type_nodeinteger_types[itk_int], lhs_expr->ts.kind);
2121
2122 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2123 temporary and a loop. */
2124 if (!gfc_is_coindexed (lhs_expr)
2125 && (!lhs_caf_attr.codimension
2126 || !(lhs_expr->rank > 0
2127 && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2128 {
2129 bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2130 gcc_assert (gfc_is_coindexed (rhs_expr))((void)(!(gfc_is_coindexed (rhs_expr)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2130, __FUNCTION__), 0 : 0))
;
2131 gfc_init_se (&rhs_se, NULL__null);
2132 if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2133 {
2134 gfc_se scal_se;
2135 gfc_init_se (&scal_se, NULL__null);
2136 scal_se.want_pointer = 1;
2137 gfc_conv_expr (&scal_se, lhs_expr);
2138 /* Ensure scalar on lhs is allocated. */
2139 gfc_add_block_to_block (&block, &scal_se.pre);
2140
2141 gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2142 TYPE_SIZE_UNIT (((tree_class_check ((gfc_typenode_for_spec (&lhs_expr->
ts)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2143, __FUNCTION__))->type_common.size_unit)
2143 gfc_typenode_for_spec (&lhs_expr->ts))((tree_class_check ((gfc_typenode_for_spec (&lhs_expr->
ts)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2143, __FUNCTION__))->type_common.size_unit)
,
2144 NULL_TREE(tree) __null);
2145 tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,fold_build2_loc (((location_t) 0), EQ_EXPR, logical_type_node
, scal_se.expr, global_trees[TI_NULL_POINTER] )
2146 null_pointer_node)fold_build2_loc (((location_t) 0), EQ_EXPR, logical_type_node
, scal_se.expr, global_trees[TI_NULL_POINTER] )
;
2147 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2148 tmp, gfc_finish_block (&scal_se.pre),
2149 build_empty_stmt (input_location));
2150 gfc_add_expr_to_block (&block, tmp);
2151 }
2152 else
2153 lhs_may_realloc = lhs_may_realloc
2154 && gfc_full_array_ref_p (lhs_expr->ref, NULL__null);
2155 gfc_add_block_to_block (&block, &lhs_se.pre);
2156 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
2157 may_require_tmp, lhs_may_realloc,
2158 &rhs_caf_attr);
2159 gfc_add_block_to_block (&block, &rhs_se.pre);
2160 gfc_add_block_to_block (&block, &rhs_se.post);
2161 gfc_add_block_to_block (&block, &lhs_se.post);
2162 return gfc_finish_block (&block);
2163 }
2164
2165 gfc_add_block_to_block (&block, &lhs_se.pre);
2166
2167 /* Obtain token, offset and image index for the LHS. */
2168 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2169 if (TREE_CODE (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-intrinsic.c"
, 2169, __FUNCTION__))->typed.type))->base.code)
== REFERENCE_TYPE)
2170 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2171 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2172 tmp = lhs_se.expr;
2173 if (lhs_caf_attr.alloc_comp)
2174 gfc_get_caf_token_offset (&lhs_se, &token, NULL__null, caf_decl, NULL_TREE(tree) __null,
2175 NULL__null);
2176 else
2177 gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2178 lhs_expr);
2179 lhs_se.expr = tmp;
2180
2181 /* RHS. */
2182 gfc_init_se (&rhs_se, NULL__null);
2183 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2184 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2185 rhs_expr = rhs_expr->value.function.actual->expr;
2186 if (rhs_expr->rank == 0)
2187 {
2188 symbol_attribute attr;
2189 gfc_clear_attr (&attr);
2190 gfc_conv_expr (&rhs_se, rhs_expr);
2191 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2192 rhs_se.expr = gfc_build_addr_expr (NULL_TREE(tree) __null, rhs_se.expr);
2193 }
2194 else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2195 && rhs_caf_attr.codimension)
2196 {
2197 tree tmp2;
2198 rhs_se.want_pointer = 1;
2199 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2200 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2201 has the wrong type if component references are done. */
2202 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2203 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2204 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2205 gfc_get_dtype_rank_type (
2206 gfc_has_vector_subscript (rhs_expr)
2207 ? gfc_find_array_ref (rhs_expr)->dimen
2208 : rhs_expr->rank,
2209 tmp2));
2210 }
2211 else
2212 {
2213 /* If has_vector, pass descriptor for whole array and the
2214 vector bounds separately. */
2215 gfc_array_ref *ar, ar2;
2216 bool has_vector = false;
2217 tree tmp2;
2218
2219 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2220 {
2221 has_vector = true;
2222 ar = gfc_find_array_ref (rhs_expr);
2223 ar2 = *ar;
2224 memset (ar, '\0', sizeof (*ar));
2225 ar->as = ar2.as;
2226 ar->type = AR_FULL;
2227 }
2228 rhs_se.want_pointer = 1;
2229 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2230 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2231 has the wrong type if component references are done. */
2232 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2233 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2234 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2235 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2236 : rhs_expr->rank,
2237 tmp2));
2238 if (has_vector)
2239 {
2240 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2241 *ar = ar2;
2242 }
2243 }
2244
2245 gfc_add_block_to_block (&block, &rhs_se.pre);
2246
2247 rhs_kind = build_int_cst (integer_type_nodeinteger_types[itk_int], rhs_expr->ts.kind);
2248
2249 tmp_stat = gfc_find_stat_co (lhs_expr);
2250
2251 if (tmp_stat)
2252 {
2253 gfc_se stat_se;
2254 gfc_init_se (&stat_se, NULL__null);
2255 gfc_conv_expr_reference (&stat_se, tmp_stat);
2256 dst_stat = stat_se.expr;
2257 gfc_add_block_to_block (&block, &stat_se.pre);
2258 gfc_add_block_to_block (&block, &stat_se.post);
2259 }
2260
2261 tmp_team = gfc_find_team_co (lhs_expr);
2262
2263 if (tmp_team)
2264 {
2265 gfc_se team_se;
2266 gfc_init_se (&team_se, NULL__null);
2267 gfc_conv_expr_reference (&team_se, tmp_team);
2268 dst_team = team_se.expr;
2269 gfc_add_block_to_block (&block, &team_se.pre);
2270 gfc_add_block_to_block (&block, &team_se.post);
2271 }
2272
2273 if (!gfc_is_coindexed (rhs_expr))
2274 {
2275 if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2276 {
2277 tree reference, dst_realloc;
2278 reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2279 dst_realloc = lhs_caf_attr.allocatable ? boolean_true_nodeglobal_trees[TI_BOOLEAN_TRUE]
2280 : boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE];
2281 tmp = build_call_expr_loc (input_location,
2282 gfor_fndecl_caf_send_by_ref,
2283 10, token, image_index, rhs_se.expr,
2284 reference, lhs_kind, rhs_kind,
2285 may_require_tmp, dst_realloc, src_stat,
2286 build_int_cst (integer_type_nodeinteger_types[itk_int],
2287 lhs_expr->ts.type));
2288 }
2289 else
2290 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2291 token, offset, image_index, lhs_se.expr, vec,
2292 rhs_se.expr, lhs_kind, rhs_kind,
2293 may_require_tmp, src_stat, dst_team);
2294 }
2295 else
2296 {
2297 tree rhs_token, rhs_offset, rhs_image_index;
2298
2299 /* It guarantees memory consistency within the same segment. */
2300 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2301 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2302 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
2303 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
2304 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2304, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
2305 gfc_add_expr_to_block (&block, tmp);
2306
2307 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2308 if (TREE_CODE (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-intrinsic.c"
, 2308, __FUNCTION__))->typed.type))->base.code)
== REFERENCE_TYPE)
2309 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2310 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2311 tmp = rhs_se.expr;
2312 if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2313 {
2314 tmp_stat = gfc_find_stat_co (lhs_expr);
2315
2316 if (tmp_stat)
2317 {
2318 gfc_se stat_se;
2319 gfc_init_se (&stat_se, NULL__null);
2320 gfc_conv_expr_reference (&stat_se, tmp_stat);
2321 src_stat = stat_se.expr;
2322 gfc_add_block_to_block (&block, &stat_se.pre);
2323 gfc_add_block_to_block (&block, &stat_se.post);
2324 }
2325
2326 gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL__null, caf_decl,
2327 NULL_TREE(tree) __null, NULL__null);
2328 tree lhs_reference, rhs_reference;
2329 lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2330 rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2331 tmp = build_call_expr_loc (input_location,
2332 gfor_fndecl_caf_sendget_by_ref, 13,
2333 token, image_index, lhs_reference,
2334 rhs_token, rhs_image_index, rhs_reference,
2335 lhs_kind, rhs_kind, may_require_tmp,
2336 dst_stat, src_stat,
2337 build_int_cst (integer_type_nodeinteger_types[itk_int],
2338 lhs_expr->ts.type),
2339 build_int_cst (integer_type_nodeinteger_types[itk_int],
2340 rhs_expr->ts.type));
2341 }
2342 else
2343 {
2344 gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2345 tmp, rhs_expr);
2346 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2347 14, token, offset, image_index,
2348 lhs_se.expr, vec, rhs_token, rhs_offset,
2349 rhs_image_index, tmp, rhs_vec, lhs_kind,
2350 rhs_kind, may_require_tmp, src_stat);
2351 }
2352 }
2353 gfc_add_expr_to_block (&block, tmp);
2354 gfc_add_block_to_block (&block, &lhs_se.post);
2355 gfc_add_block_to_block (&block, &rhs_se.post);
2356
2357 /* It guarantees memory consistency within the same segment. */
2358 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2359 tmp = build5_loc (input_location, ASM_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE],
2360 gfc_build_string_const (1, ""), NULL_TREE(tree) __null, NULL_TREE(tree) __null,
2361 tree_cons (NULL_TREE(tree) __null, tmp, NULL_TREE(tree) __null), NULL_TREE(tree) __null);
2362 ASM_VOLATILE_P (tmp)((tree_check ((tmp), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2362, __FUNCTION__, (ASM_EXPR)))->base.public_flag)
= 1;
2363 gfc_add_expr_to_block (&block, tmp);
2364
2365 return gfc_finish_block (&block);
2366}
2367
2368
2369static void
2370trans_this_image (gfc_se * se, gfc_expr *expr)
2371{
2372 stmtblock_t loop;
2373 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2374 lbound, ubound, extent, ml;
2375 gfc_se argse;
2376 int rank, corank;
2377 gfc_expr *distance = expr->value.function.actual->next->next->expr;
2378
2379 if (expr->value.function.actual->expr
2380 && !gfc_is_coarray (expr->value.function.actual->expr))
2381 distance = expr->value.function.actual->expr;
2382
2383 /* The case -fcoarray=single is handled elsewhere. */
2384 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE)((void)(!(global_options.x_flag_coarray != GFC_FCOARRAY_SINGLE
) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2384, __FUNCTION__), 0 : 0))
;
2385
2386 /* Argument-free version: THIS_IMAGE(). */
2387 if (distance || expr->value.function.actual->expr == NULL__null)
2388 {
2389 if (distance)
2390 {
2391 gfc_init_se (&argse, NULL__null);
2392 gfc_conv_expr_val (&argse, distance);
2393 gfc_add_block_to_block (&se->pre, &argse.pre);
2394 gfc_add_block_to_block (&se->post, &argse.post);
2395 tmp = fold_convert (integer_type_node, argse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], argse
.expr)
;
2396 }
2397 else
2398 tmp = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
2399 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2400 tmp);
2401 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),fold_convert_loc (((location_t) 0), gfc_get_int_type (gfc_default_integer_kind
), tmp)
2402 tmp)fold_convert_loc (((location_t) 0), gfc_get_int_type (gfc_default_integer_kind
), tmp)
;
2403 return;
2404 }
2405
2406 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2407
2408 type = gfc_get_int_type (gfc_default_integer_kind);
2409 corank = gfc_get_corank (expr->value.function.actual->expr);
2410 rank = expr->value.function.actual->expr->rank;
2411
2412 /* Obtain the descriptor of the COARRAY. */
2413 gfc_init_se (&argse, NULL__null);
2414 argse.want_coarray = 1;
2415 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2416 gfc_add_block_to_block (&se->pre, &argse.pre);
2417 gfc_add_block_to_block (&se->post, &argse.post);
2418 desc = argse.expr;
2419
2420 if (se->ss)
2421 {
2422 /* Create an implicit second parameter from the loop variable. */
2423 gcc_assert (!expr->value.function.actual->next->expr)((void)(!(!expr->value.function.actual->next->expr) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2423, __FUNCTION__), 0 : 0))
;
2424 gcc_assert (corank > 0)((void)(!(corank > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2424, __FUNCTION__), 0 : 0))
;
2425 gcc_assert (se->loop->dimen == 1)((void)(!(se->loop->dimen == 1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2425, __FUNCTION__), 0 : 0))
;
2426 gcc_assert (se->ss->info->expr == expr)((void)(!(se->ss->info->expr == expr) ? fancy_abort (
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2426, __FUNCTION__), 0 : 0))
;
2427
2428 dim_arg = se->loop->loopvar[0];
2429 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2430 gfc_array_index_type, dim_arg,
2431 build_int_cst (TREE_TYPE (dim_arg)((contains_struct_check ((dim_arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2431, __FUNCTION__))->typed.type)
, 1));
2432 gfc_advance_se_ss_chain (se);
2433 }
2434 else
2435 {
2436 /* Use the passed DIM= argument. */
2437 gcc_assert (expr->value.function.actual->next->expr)((void)(!(expr->value.function.actual->next->expr) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2437, __FUNCTION__), 0 : 0))
;
2438 gfc_init_se (&argse, NULL__null);
2439 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2440 gfc_array_index_type);
2441 gfc_add_block_to_block (&se->pre, &argse.pre);
2442 dim_arg = argse.expr;
2443
2444 if (INTEGER_CST_P (dim_arg)(((enum tree_code) (dim_arg)->base.code) == INTEGER_CST))
2445 {
2446 if (wi::ltu_p (wi::to_wide (dim_arg), 1)
2447 || wi::gtu_p (wi::to_wide (dim_arg),
2448 GFC_TYPE_ARRAY_CORANK (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-intrinsic.c"
, 2448, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2448, __FUNCTION__))->type_with_lang_specific.lang_specific
)->corank)
))
2449 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2450 "dimension index", expr->value.function.isym->name,
2451 &expr->where);
2452 }
2453 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
2454 {
2455 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2456 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2457 dim_arg,
2458 build_int_cst (TREE_TYPE (dim_arg)((contains_struct_check ((dim_arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2458, __FUNCTION__))->typed.type)
, 1));
2459 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (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-intrinsic.c"
, 2459, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2459, __FUNCTION__))->type_with_lang_specific.lang_specific
)->corank)
];
2460 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2461 dim_arg, tmp);
2462 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2463 logical_type_node, cond, tmp);
2464 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2465 gfc_msg_fault);
2466 }
2467 }
2468
2469 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2470 one always has a dim_arg argument.
2471
2472 m = this_image() - 1
2473 if (corank == 1)
2474 {
2475 sub(1) = m + lcobound(corank)
2476 return;
2477 }
2478 i = rank
2479 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2480 for (;;)
2481 {
2482 extent = gfc_extent(i)
2483 ml = m
2484 m = m/extent
2485 if (i >= min_var)
2486 goto exit_label
2487 i++
2488 }
2489 exit_label:
2490 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2491 : m + lcobound(corank)
2492 */
2493
2494 /* this_image () - 1. */
2495 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2496 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
2497 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2498 fold_convert (type, tmp)fold_convert_loc (((location_t) 0), type, tmp), build_int_cst (type, 1));
2499 if (corank == 1)
2500 {
2501 /* sub(1) = m + lcobound(corank). */
2502 lbound = gfc_conv_descriptor_lbound_get (desc,
2503 build_int_cst (TREE_TYPE (gfc_array_index_type)((contains_struct_check ((gfc_array_index_type), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2503, __FUNCTION__))->typed.type)
,
2504 corank+rank-1));
2505 lbound = fold_convert (type, lbound)fold_convert_loc (((location_t) 0), type, lbound);
2506 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2507
2508 se->expr = tmp;
2509 return;
2510 }
2511
2512 m = gfc_create_var (type, NULL__null);
2513 ml = gfc_create_var (type, NULL__null);
2514 loop_var = gfc_create_var (integer_type_nodeinteger_types[itk_int], NULL__null);
2515 min_var = gfc_create_var (integer_type_nodeinteger_types[itk_int], NULL__null);
2516
2517 /* m = this_image () - 1. */
2518 gfc_add_modify (&se->pre, m, tmp);
2519
2520 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2521 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_nodeinteger_types[itk_int],
2522 fold_convert (integer_type_node, dim_arg)fold_convert_loc (((location_t) 0), integer_types[itk_int], dim_arg
)
,
2523 build_int_cst (integer_type_nodeinteger_types[itk_int], rank - 1));
2524 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_nodeinteger_types[itk_int],
2525 build_int_cst (integer_type_nodeinteger_types[itk_int], rank + corank - 2),
2526 tmp);
2527 gfc_add_modify (&se->pre, min_var, tmp);
2528
2529 /* i = rank. */
2530 tmp = build_int_cst (integer_type_nodeinteger_types[itk_int], rank);
2531 gfc_add_modify (&se->pre, loop_var, tmp);
2532
2533 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
2534 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
2535
2536 /* Loop body. */
2537 gfc_init_block (&loop);
2538
2539 /* ml = m. */
2540 gfc_add_modify (&loop, ml, m);
2541
2542 /* extent = ... */
2543 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2544 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2545 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
2546 extent = fold_convert (type, extent)fold_convert_loc (((location_t) 0), type, extent);
2547
2548 /* m = m/extent. */
2549 gfc_add_modify (&loop, m,
2550 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2551 m, extent));
2552
2553 /* Exit condition: if (i >= min_var) goto exit_label. */
2554 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2555 min_var);
2556 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2557 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_nodeglobal_trees[TI_VOID_TYPE], cond, tmp,
2558 build_empty_stmt (input_location));
2559 gfc_add_expr_to_block (&loop, tmp);
2560
2561 /* Increment loop variable: i++. */
2562 gfc_add_modify (&loop, loop_var,
2563 fold_build2_loc (input_location, PLUS_EXPR, integer_type_nodeinteger_types[itk_int],
2564 loop_var,
2565 build_int_cst (integer_type_nodeinteger_types[itk_int], 1)));
2566
2567 /* Making the loop... actually loop! */
2568 tmp = gfc_finish_block (&loop);
2569 tmp = build1_v (LOOP_EXPR, tmp)fold_build1_loc (input_location, LOOP_EXPR, global_trees[TI_VOID_TYPE
], tmp)
;
2570 gfc_add_expr_to_block (&se->pre, tmp);
2571
2572 /* The exit label. */
2573 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
2574 gfc_add_expr_to_block (&se->pre, tmp);
2575
2576 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2577 : m + lcobound(corank) */
2578
2579 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2580 build_int_cst (TREE_TYPE (dim_arg)((contains_struct_check ((dim_arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2580, __FUNCTION__))->typed.type)
, corank));
2581
2582 lbound = gfc_conv_descriptor_lbound_get (desc,
2583 fold_build2_loc (input_location, PLUS_EXPR,
2584 gfc_array_index_type, dim_arg,
2585 build_int_cst (TREE_TYPE (dim_arg)((contains_struct_check ((dim_arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2585, __FUNCTION__))->typed.type)
, rank-1)));
2586 lbound = fold_convert (type, lbound)fold_convert_loc (((location_t) 0), type, lbound);
2587
2588 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2589 fold_build2_loc (input_location, MULT_EXPR, type,
2590 m, extent));
2591 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2592
2593 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2594 fold_build2_loc (input_location, PLUS_EXPR, type,
2595 m, lbound));
2596}
2597
2598
2599/* Convert a call to image_status. */
2600
2601static void
2602conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2603{
2604 unsigned int num_args;
2605 tree *args, tmp;
2606
2607 num_args = gfc_intrinsic_argument_list_length (expr);
2608 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
2609 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2610 /* In args[0] the number of the image the status is desired for has to be
2611 given. */
2612
2613 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
2614 {
2615 tree arg;
2616 arg = gfc_evaluate_now (args[0], &se->pre);
2617 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2618 fold_convert (integer_type_node, arg)fold_convert_loc (((location_t) 0), integer_types[itk_int], arg
)
,
2619 integer_one_nodeglobal_trees[TI_INTEGER_ONE]);
2620 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_nodeinteger_types[itk_int],
2621 tmp, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
2622 build_int_cst (integer_type_nodeinteger_types[itk_int],
2623 GFC_STAT_STOPPED_IMAGE));
2624 }
2625 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
2626 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2627 args[0], build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
2628 else
2629 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2629, __FUNCTION__))
;
2630
2631 se->expr = tmp;
2632}
2633
2634static void
2635conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2636{
2637 unsigned int num_args;
2638
2639 tree *args, tmp;
2640
2641 num_args = gfc_intrinsic_argument_list_length (expr);
2642 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
2643 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2644
2645 if (flag_coarrayglobal_options.x_flag_coarray ==
2646 GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2647 {
2648 tree arg;
2649
2650 arg = gfc_evaluate_now (args[0], &se->pre);
2651 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2652 fold_convert (integer_type_node, arg)fold_convert_loc (((location_t) 0), integer_types[itk_int], arg
)
,
2653 integer_one_nodeglobal_trees[TI_INTEGER_ONE]);
2654 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_nodeinteger_types[itk_int],
2655 tmp, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
2656 build_int_cst (integer_type_nodeinteger_types[itk_int],
2657 GFC_STAT_STOPPED_IMAGE));
2658 }
2659 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
2660 {
2661 // the value -1 represents that no team has been created yet
2662 tmp = build_int_cst (integer_type_nodeinteger_types[itk_int], -1);
2663 }
2664 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2665 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2666 args[0], build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
2667 else if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
2668 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2669 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO], build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
2670 else
2671 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2671, __FUNCTION__))
;
2672
2673 se->expr = tmp;
2674}
2675
2676
2677static void
2678trans_image_index (gfc_se * se, gfc_expr *expr)
2679{
2680 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2681 tmp, invalid_bound;
2682 gfc_se argse, subse;
2683 int rank, corank, codim;
2684
2685 type = gfc_get_int_type (gfc_default_integer_kind);
2686 corank = gfc_get_corank (expr->value.function.actual->expr);
2687 rank = expr->value.function.actual->expr->rank;
2688
2689 /* Obtain the descriptor of the COARRAY. */
2690 gfc_init_se (&argse, NULL__null);
2691 argse.want_coarray = 1;
2692 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2693 gfc_add_block_to_block (&se->pre, &argse.pre);
2694 gfc_add_block_to_block (&se->post, &argse.post);
2695 desc = argse.expr;
2696
2697 /* Obtain a handle to the SUB argument. */
2698 gfc_init_se (&subse, NULL__null);
2699 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2700 gfc_add_block_to_block (&se->pre, &subse.pre);
2701 gfc_add_block_to_block (&se->post, &subse.post);
2702 subdesc = build_fold_indirect_ref_loc (input_location,
2703 gfc_conv_descriptor_data_get (subse.expr));
2704
2705 /* Fortran 2008 does not require that the values remain in the cobounds,
2706 thus we need explicitly check this - and return 0 if they are exceeded. */
2707
2708 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2709 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL__null);
2710 invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2711 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
,
2712 lbound);
2713
2714 for (codim = corank + rank - 2; codim >= rank; codim--)
2715 {
2716 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2717 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2718 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL__null);
2719 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2720 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
,
2721 lbound);
2722 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2723 logical_type_node, invalid_bound, cond);
2724 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2725 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
,
2726 ubound);
2727 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2728 logical_type_node, invalid_bound, cond);
2729 }
2730
2731 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2732
2733 /* See Fortran 2008, C.10 for the following algorithm. */
2734
2735 /* coindex = sub(corank) - lcobound(n). */
2736 coindex = fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_build_array_ref
(subdesc, gfc_rank_cst[corank-1], __null))
2737 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_build_array_ref
(subdesc, gfc_rank_cst[corank-1], __null))
2738 NULL))fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_build_array_ref
(subdesc, gfc_rank_cst[corank-1], __null))
;
2739 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2740 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2741 fold_convert (gfc_array_index_type, coindex)fold_convert_loc (((location_t) 0), gfc_array_index_type, coindex
)
,
2742 lbound);
2743
2744 for (codim = corank + rank - 2; codim >= rank; codim--)
2745 {
2746 tree extent, ubound;
2747
2748 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2749 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2750 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2751 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL__null);
2752
2753 /* coindex *= extent. */
2754 coindex = fold_build2_loc (input_location, MULT_EXPR,
2755 gfc_array_index_type, coindex, extent);
2756
2757 /* coindex += sub(codim). */
2758 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL__null);
2759 coindex = fold_build2_loc (input_location, PLUS_EXPR,
2760 gfc_array_index_type, coindex,
2761 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
);
2762
2763 /* coindex -= lbound(codim). */
2764 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2765 coindex = fold_build2_loc (input_location, MINUS_EXPR,
2766 gfc_array_index_type, coindex, lbound);
2767 }
2768
2769 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2770 fold_convert(type, coindex)fold_convert_loc (((location_t) 0), type, coindex),
2771 build_int_cst (type, 1));
2772
2773 /* Return 0 if "coindex" exceeds num_images(). */
2774
2775 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_SINGLE)
2776 num_images = build_int_cst (type, 1);
2777 else
2778 {
2779 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2780 integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
2781 build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
2782 num_images = fold_convert (type, tmp)fold_convert_loc (((location_t) 0), type, tmp);
2783 }
2784
2785 tmp = gfc_create_var (type, NULL__null);
2786 gfc_add_modify (&se->pre, tmp, coindex);
2787
2788 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2789 num_images);
2790 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2791 cond,
2792 fold_convert (logical_type_node, invalid_bound)fold_convert_loc (((location_t) 0), logical_type_node, invalid_bound
)
);
2793 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2794 build_int_cst (type, 0), tmp);
2795}
2796
2797static void
2798trans_num_images (gfc_se * se, gfc_expr *expr)
2799{
2800 tree tmp, distance, failed;
2801 gfc_se argse;
2802
2803 if (expr->value.function.actual->expr)
2804 {
2805 gfc_init_se (&argse, NULL__null);
2806 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2807 gfc_add_block_to_block (&se->pre, &argse.pre);
2808 gfc_add_block_to_block (&se->post, &argse.post);
2809 distance = fold_convert (integer_type_node, argse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], argse
.expr)
;
2810 }
2811 else
2812 distance = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
2813
2814 if (expr->value.function.actual->next->expr)
2815 {
2816 gfc_init_se (&argse, NULL__null);
2817 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2818 gfc_add_block_to_block (&se->pre, &argse.pre);
2819 gfc_add_block_to_block (&se->post, &argse.post);
2820 failed = fold_convert (integer_type_node, argse.expr)fold_convert_loc (((location_t) 0), integer_types[itk_int], argse
.expr)
;
2821 }
2822 else
2823 failed = build_int_cst (integer_type_nodeinteger_types[itk_int], -1);
2824 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2825 distance, failed);
2826 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp)fold_convert_loc (((location_t) 0), gfc_get_int_type (gfc_default_integer_kind
), tmp)
;
2827}
2828
2829
2830static void
2831gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2832{
2833 gfc_se argse;
2834
2835 gfc_init_se (&argse, NULL__null);
2836 argse.data_not_needed = 1;
2837 argse.descriptor_only = 1;
2838
2839 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2840 gfc_add_block_to_block (&se->pre, &argse.pre);
2841 gfc_add_block_to_block (&se->post, &argse.post);
2842
2843 se->expr = gfc_conv_descriptor_rank (argse.expr);
2844 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),fold_convert_loc (((location_t) 0), gfc_get_int_type (gfc_default_integer_kind
), se->expr)
2845 se->expr)fold_convert_loc (((location_t) 0), gfc_get_int_type (gfc_default_integer_kind
), se->expr)
;
2846}
2847
2848
2849static void
2850gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2851{
2852 gfc_expr *arg;
2853 arg = expr->value.function.actual->expr;
2854 gfc_conv_is_contiguous_expr (se, arg);
2855 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr)fold_convert_loc (((location_t) 0), gfc_typenode_for_spec (&
expr->ts), se->expr)
;
2856}
2857
2858/* This function does the work for gfc_conv_intrinsic_is_contiguous,
2859 plus it can be called directly. */
2860
2861void
2862gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2863{
2864 gfc_ss *ss;
2865 gfc_se argse;
2866 tree desc, tmp, stride, extent, cond;
2867 int i;
2868 tree fncall0;
2869 gfc_array_spec *as;
2870
2871 if (arg->ts.type == BT_CLASS)
2872 gfc_add_class_array_ref (arg);
2873
2874 ss = gfc_walk_expr (arg);
2875 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-intrinsic.c"
, 2875, __FUNCTION__), 0 : 0))
;
2876 gfc_init_se (&argse, NULL__null);
2877 argse.data_not_needed = 1;
2878 gfc_conv_expr_descriptor (&argse, arg);
2879
2880 as = gfc_get_full_arrayspec_from_expr (arg);
2881
2882 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2883 Note in addition that zero-sized arrays don't count as contiguous. */
2884
2885 if (as && as->type == AS_ASSUMED_RANK)
2886 {
2887 /* Build the call to is_contiguous0. */
2888 argse.want_pointer = 1;
2889 gfc_conv_expr_descriptor (&argse, arg);
2890 gfc_add_block_to_block (&se->pre, &argse.pre);
2891 gfc_add_block_to_block (&se->post, &argse.post);
2892 desc = gfc_evaluate_now (argse.expr, &se->pre);
2893 fncall0 = build_call_expr_loc (input_location,
2894 gfor_fndecl_is_contiguous0, 1, desc);
2895 se->expr = fncall0;
2896 se->expr = convert (logical_type_node, se->expr);
2897 }
2898 else
2899 {
2900 gfc_add_block_to_block (&se->pre, &argse.pre);
2901 gfc_add_block_to_block (&se->post, &argse.post);
2902 desc = gfc_evaluate_now (argse.expr, &se->pre);
2903
2904 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2905 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE],
2906 stride, build_int_cst (TREE_TYPE (stride)((contains_struct_check ((stride), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2906, __FUNCTION__))->typed.type)
, 1));
2907
2908 for (i = 0; i < arg->rank - 1; i++)
2909 {
2910 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2911 extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2912 extent = fold_build2_loc (input_location, MINUS_EXPR,
2913 gfc_array_index_type, extent, tmp);
2914 extent = fold_build2_loc (input_location, PLUS_EXPR,
2915 gfc_array_index_type, extent,
2916 gfc_index_one_nodegfc_rank_cst[1]);
2917 tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2918 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-intrinsic.c"
, 2918, __FUNCTION__))->typed.type)
,
2919 tmp, extent);
2920 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2921 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE],
2922 stride, tmp);
2923 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2924 boolean_type_nodeglobal_trees[TI_BOOLEAN_TYPE], cond, tmp);
2925 }
2926 se->expr = cond;
2927 }
2928}
2929
2930
2931/* Evaluate a single upper or lower bound. */
2932/* TODO: bound intrinsic generates way too much unnecessary code. */
2933
2934static void
2935gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2936{
2937 gfc_actual_arglist *arg;
2938 gfc_actual_arglist *arg2;
2939 tree desc;
2940 tree type;
2941 tree bound;
2942 tree tmp;
2943 tree cond, cond1, cond3, cond4, size;
2944 tree ubound;
2945 tree lbound;
2946 gfc_se argse;
2947 gfc_array_spec * as;
2948 bool assumed_rank_lb_one;
2949
2950 arg = expr->value.function.actual;
2951 arg2 = arg->next;
2952
2953 if (se->ss)
2954 {
2955 /* Create an implicit second parameter from the loop variable. */
2956 gcc_assert (!arg2->expr)((void)(!(!arg2->expr) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2956, __FUNCTION__), 0 : 0))
;
2957 gcc_assert (se->loop->dimen == 1)((void)(!(se->loop->dimen == 1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2957, __FUNCTION__), 0 : 0))
;
2958 gcc_assert (se->ss->info->expr == expr)((void)(!(se->ss->info->expr == expr) ? fancy_abort (
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2958, __FUNCTION__), 0 : 0))
;
2959 gfc_advance_se_ss_chain (se);
2960 bound = se->loop->loopvar[0];
2961 bound = fold_build2_loc (input_location, MINUS_EXPR,
2962 gfc_array_index_type, bound,
2963 se->loop->from[0]);
2964 }
2965 else
2966 {
2967 /* use the passed argument. */
2968 gcc_assert (arg2->expr)((void)(!(arg2->expr) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2968, __FUNCTION__), 0 : 0))
;
2969 gfc_init_se (&argse, NULL__null);
2970 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2971 gfc_add_block_to_block (&se->pre, &argse.pre);
2972 bound = argse.expr;
2973 /* Convert from one based to zero based. */
2974 bound = fold_build2_loc (input_location, MINUS_EXPR,
2975 gfc_array_index_type, bound,
2976 gfc_index_one_nodegfc_rank_cst[1]);
2977 }
2978
2979 /* TODO: don't re-evaluate the descriptor on each iteration. */
2980 /* Get a descriptor for the first parameter. */
2981 gfc_init_se (&argse, NULL__null);
2982 gfc_conv_expr_descriptor (&argse, arg->expr);
2983 gfc_add_block_to_block (&se->pre, &argse.pre);
2984 gfc_add_block_to_block (&se->post, &argse.post);
2985
2986 desc = argse.expr;
2987
2988 as = gfc_get_full_arrayspec_from_expr (arg->expr);
2989
2990 if (INTEGER_CST_P (bound)(((enum tree_code) (bound)->base.code) == INTEGER_CST))
2991 {
2992 if (((!as || as->type != AS_ASSUMED_RANK)
2993 && wi::geu_p (wi::to_wide (bound),
2994 GFC_TYPE_ARRAY_RANK (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-intrinsic.c"
, 2994, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 2994, __FUNCTION__))->type_with_lang_specific.lang_specific
)->rank)
))
2995 || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS15))
2996 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2997 "dimension index", upper ? "UBOUND" : "LBOUND",
2998 &expr->where);
2999 }
3000
3001 if (!INTEGER_CST_P (bound)(((enum tree_code) (bound)->base.code) == INTEGER_CST) || (as && as->type == AS_ASSUMED_RANK))
3002 {
3003 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
3004 {
3005 bound = gfc_evaluate_now (bound, &se->pre);
3006 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3007 bound, build_int_cst (TREE_TYPE (bound)((contains_struct_check ((bound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3007, __FUNCTION__))->typed.type)
, 0));
3008 if (as && as->type == AS_ASSUMED_RANK)
3009 tmp = gfc_conv_descriptor_rank (desc);
3010 else
3011 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (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-intrinsic.c"
, 3011, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3011, __FUNCTION__))->type_with_lang_specific.lang_specific
)->rank)
];
3012 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3013 bound, fold_convert(TREE_TYPE (bound), tmp)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(bound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3013, __FUNCTION__))->typed.type), tmp)
);
3014 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3015 logical_type_node, cond, tmp);
3016 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3017 gfc_msg_fault);
3018 }
3019 }
3020
3021 /* Take care of the lbound shift for assumed-rank arrays, which are
3022 nonallocatable and nonpointers. Those has a lbound of 1. */
3023 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
3024 && ((arg->expr->ts.type != BT_CLASS
3025 && !arg->expr->symtree->n.sym->attr.allocatable
3026 && !arg->expr->symtree->n.sym->attr.pointer)
3027 || (arg->expr->ts.type == BT_CLASS
3028 && !CLASS_DATA (arg->expr)arg->expr->ts.u.derived->components->attr.allocatable
3029 && !CLASS_DATA (arg->expr)arg->expr->ts.u.derived->components->attr.class_pointer));
3030
3031 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
3032 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
3033
3034 /* 13.14.53: Result value for LBOUND
3035
3036 Case (i): For an array section or for an array expression other than a
3037 whole array or array structure component, LBOUND(ARRAY, DIM)
3038 has the value 1. For a whole array or array structure
3039 component, LBOUND(ARRAY, DIM) has the value:
3040 (a) equal to the lower bound for subscript DIM of ARRAY if
3041 dimension DIM of ARRAY does not have extent zero
3042 or if ARRAY is an assumed-size array of rank DIM,
3043 or (b) 1 otherwise.
3044
3045 13.14.113: Result value for UBOUND
3046
3047 Case (i): For an array section or for an array expression other than a
3048 whole array or array structure component, UBOUND(ARRAY, DIM)
3049 has the value equal to the number of elements in the given
3050 dimension; otherwise, it has a value equal to the upper bound
3051 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3052 not have size zero and has value zero if dimension DIM has
3053 size zero. */
3054
3055 if (!upper && assumed_rank_lb_one)
3056 se->expr = gfc_index_one_nodegfc_rank_cst[1];
3057 else if (as)
3058 {
3059 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
3060
3061 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3062 ubound, lbound);
3063 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3064 stride, gfc_index_zero_nodegfc_rank_cst[0]);
3065 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3066 logical_type_node, cond3, cond1);
3067 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3068 stride, gfc_index_zero_nodegfc_rank_cst[0]);
3069
3070 if (upper)
3071 {
3072 tree cond5;
3073 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3074 logical_type_node, cond3, cond4);
3075 cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3076 gfc_index_one_nodegfc_rank_cst[1], lbound);
3077 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3078 logical_type_node, cond4, cond5);
3079
3080 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3081 logical_type_node, cond, cond5);
3082
3083 if (assumed_rank_lb_one)
3084 {
3085 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3086 gfc_array_index_type, ubound, lbound);
3087 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3088 gfc_array_index_type, tmp, gfc_index_one_nodegfc_rank_cst[1]);
3089 }
3090 else
3091 tmp = ubound;
3092
3093 se->expr = fold_build3_loc (input_location, COND_EXPR,
3094 gfc_array_index_type, cond,
3095 tmp, gfc_index_zero_nodegfc_rank_cst[0]);
3096 }
3097 else
3098 {
3099 if (as->type == AS_ASSUMED_SIZE)
3100 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3101 bound, build_int_cst (TREE_TYPE (bound)((contains_struct_check ((bound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3101, __FUNCTION__))->typed.type)
,
3102 arg->expr->rank - 1));
3103 else
3104 cond = logical_false_node;
3105
3106 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3107 logical_type_node, cond3, cond4);
3108 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3109 logical_type_node, cond, cond1);
3110
3111 se->expr = fold_build3_loc (input_location, COND_EXPR,
3112 gfc_array_index_type, cond,
3113 lbound, gfc_index_one_nodegfc_rank_cst[1]);
3114 }
3115 }
3116 else
3117 {
3118 if (upper)
3119 {
3120 size = fold_build2_loc (input_location, MINUS_EXPR,
3121 gfc_array_index_type, ubound, lbound);
3122 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
3123 gfc_array_index_type, size,
3124 gfc_index_one_nodegfc_rank_cst[1]);
3125 se->expr = fold_build2_loc (input_location, MAX_EXPR,
3126 gfc_array_index_type, se->expr,
3127 gfc_index_zero_nodegfc_rank_cst[0]);
3128 }
3129 else
3130 se->expr = gfc_index_one_nodegfc_rank_cst[1];
3131 }
3132
3133 /* According to F2018 16.9.172, para 5, an assumed rank object, argument
3134 associated with and assumed size array, has the ubound of the final
3135 dimension set to -1 and UBOUND must return this. */
3136 if (upper && as && as->type == AS_ASSUMED_RANK)
3137 {
3138 tree minus_one = build_int_cst (gfc_array_index_type, -1);
3139 tree rank = fold_convert (gfc_array_index_type,fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_conv_descriptor_rank
(desc))
3140 gfc_conv_descriptor_rank (desc))fold_convert_loc (((location_t) 0), gfc_array_index_type, gfc_conv_descriptor_rank
(desc))
;
3141 rank = fold_build2_loc (input_location, PLUS_EXPR,
3142 gfc_array_index_type, rank, minus_one);
3143 /* Fix the expression to stop it from becoming even more complicated. */
3144 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3145 cond = fold_build2_loc (input_location, NE_EXPR,
3146 logical_type_node, bound, rank);
3147 cond1 = fold_build2_loc (input_location, NE_EXPR,
3148 logical_type_node, ubound, minus_one);
3149 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3150 logical_type_node, cond, cond1);
3151 se->expr = fold_build3_loc (input_location, COND_EXPR,
3152 gfc_array_index_type, cond,
3153 se->expr, minus_one);
3154 }
3155
3156 type = gfc_typenode_for_spec (&expr->ts);
3157 se->expr = convert (type, se->expr);
3158}
3159
3160
3161static void
3162conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
3163{
3164 gfc_actual_arglist *arg;
3165 gfc_actual_arglist *arg2;
3166 gfc_se argse;
3167 tree bound, resbound, resbound2, desc, cond, tmp;
3168 tree type;
3169 int corank;
3170
3171 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND((void)(!(expr->value.function.isym->id == GFC_ISYM_LCOBOUND
|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND ||
expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3173, __FUNCTION__), 0 : 0))
3172 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND((void)(!(expr->value.function.isym->id == GFC_ISYM_LCOBOUND
|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND ||
expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3173, __FUNCTION__), 0 : 0))
3173 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE)((void)(!(expr->value.function.isym->id == GFC_ISYM_LCOBOUND
|| expr->value.function.isym->id == GFC_ISYM_UCOBOUND ||
expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3173, __FUNCTION__), 0 : 0))
;
3174
3175 arg = expr->value.function.actual;
3176 arg2 = arg->next;
3177
3178 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE)((void)(!(arg->expr->expr_type == EXPR_VARIABLE) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3178, __FUNCTION__), 0 : 0))
;
3179 corank = gfc_get_corank (arg->expr);
3180
3181 gfc_init_se (&argse, NULL__null);
3182 argse.want_coarray = 1;
3183
3184 gfc_conv_expr_descriptor (&argse, arg->expr);
3185 gfc_add_block_to_block (&se->pre, &argse.pre);
3186 gfc_add_block_to_block (&se->post, &argse.post);
3187 desc = argse.expr;
3188
3189 if (se->ss)
3190 {
3191 /* Create an implicit second parameter from the loop variable. */
3192 gcc_assert (!arg2->expr)((void)(!(!arg2->expr) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3192, __FUNCTION__), 0 : 0))
;
3193 gcc_assert (corank > 0)((void)(!(corank > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3193, __FUNCTION__), 0 : 0))
;
3194 gcc_assert (se->loop->dimen == 1)((void)(!(se->loop->dimen == 1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3194, __FUNCTION__), 0 : 0))
;
3195 gcc_assert (se->ss->info->expr == expr)((void)(!(se->ss->info->expr == expr) ? fancy_abort (
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3195, __FUNCTION__), 0 : 0))
;
3196
3197 bound = se->loop->loopvar[0];
3198 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3199 bound, gfc_rank_cst[arg->expr->rank]);
3200 gfc_advance_se_ss_chain (se);
3201 }
3202 else
3203 {
3204 /* use the passed argument. */
3205 gcc_assert (arg2->expr)((void)(!(arg2->expr) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3205, __FUNCTION__), 0 : 0))
;
3206 gfc_init_se (&argse, NULL__null);
3207 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
3208 gfc_add_block_to_block (&se->pre, &argse.pre);
3209 bound = argse.expr;
3210
3211 if (INTEGER_CST_P (bound)(((enum tree_code) (bound)->base.code) == INTEGER_CST))
3212 {
3213 if (wi::ltu_p (wi::to_wide (bound), 1)
3214 || wi::gtu_p (wi::to_wide (bound),
3215 GFC_TYPE_ARRAY_CORANK (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-intrinsic.c"
, 3215, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3215, __FUNCTION__))->type_with_lang_specific.lang_specific
)->corank)
))
3216 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3217 "dimension index", expr->value.function.isym->name,
3218 &expr->where);
3219 }
3220 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS(1<<0))
3221 {
3222 bound = gfc_evaluate_now (bound, &se->pre);
3223 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3224 bound, build_int_cst (TREE_TYPE (bound)((contains_struct_check ((bound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3224, __FUNCTION__))->typed.type)
, 1));
3225 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (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-intrinsic.c"
, 3225, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3225, __FUNCTION__))->type_with_lang_specific.lang_specific
)->corank)
];
3226 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3227 bound, tmp);
3228 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3229 logical_type_node, cond, tmp);
3230 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3231 gfc_msg_fault);
3232 }
3233
3234
3235 /* Subtract 1 to get to zero based and add dimensions. */
3236 switch (arg->expr->rank)
3237 {
3238 case 0:
3239 bound = fold_build2_loc (input_location, MINUS_EXPR,
3240 gfc_array_index_type, bound,
3241 gfc_index_one_nodegfc_rank_cst[1]);
3242 case 1:
3243 break;
3244 default:
3245 bound = fold_build2_loc (input_location, PLUS_EXPR,
3246 gfc_array_index_type, bound,
3247 gfc_rank_cst[arg->expr->rank - 1]);
3248 }
3249 }
3250
3251 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3252
3253 /* Handle UCOBOUND with special handling of the last codimension. */
3254 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3255 {
3256 /* Last codimension: For -fcoarray=single just return
3257 the lcobound - otherwise add
3258 ceiling (real (num_images ()) / real (size)) - 1
3259 = (num_images () + size - 1) / size - 1
3260 = (num_images - 1) / size(),
3261 where size is the product of the extent of all but the last
3262 codimension. */
3263
3264 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3265 {
3266 tree cosize;
3267
3268 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3269 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3270 2, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
3271 build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
3272 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3273 gfc_array_index_type,
3274 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
,
3275 build_int_cst (gfc_array_index_type, 1));
3276 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3277 gfc_array_index_type, tmp,
3278 fold_convert (gfc_array_index_type, cosize)fold_convert_loc (((location_t) 0), gfc_array_index_type, cosize
)
);
3279 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3280 gfc_array_index_type, resbound, tmp);
3281 }
3282 else if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE)
3283 {
3284 /* ubound = lbound + num_images() - 1. */
3285 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3286 2, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO],
3287 build_int_cst (integer_type_nodeinteger_types[itk_int], -1));
3288 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3289 gfc_array_index_type,
3290 fold_convert (gfc_array_index_type, tmp)fold_convert_loc (((location_t) 0), gfc_array_index_type, tmp
)
,
3291 build_int_cst (gfc_array_index_type, 1));
3292 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3293 gfc_array_index_type, resbound, tmp);
3294 }
3295
3296 if (corank > 1)
3297 {
3298 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3299 bound,
3300 build_int_cst (TREE_TYPE (bound)((contains_struct_check ((bound), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3300, __FUNCTION__))->typed.type)
,
3301 arg->expr->rank + corank - 1));
3302
3303 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3304 se->expr = fold_build3_loc (input_location, COND_EXPR,
3305 gfc_array_index_type, cond,
3306 resbound, resbound2);
3307 }
3308 else
3309 se->expr = resbound;
3310 }
3311 else
3312 se->expr = resbound;
3313
3314 type = gfc_typenode_for_spec (&expr->ts);
3315 se->expr = convert (type, se->expr);
3316}
3317
3318
3319static void
3320conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3321{
3322 gfc_actual_arglist *array_arg;
3323 gfc_actual_arglist *dim_arg;
3324 gfc_se argse;
3325 tree desc, tmp;
3326
3327 array_arg = expr->value.function.actual;
3328 dim_arg = array_arg->next;
3329
3330 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE)((void)(!(array_arg->expr->expr_type == EXPR_VARIABLE) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3330, __FUNCTION__), 0 : 0))
;
3331
3332 gfc_init_se (&argse, NULL__null);
3333 gfc_conv_expr_descriptor (&argse, array_arg->expr);
3334 gfc_add_block_to_block (&se->pre, &argse.pre);
3335 gfc_add_block_to_block (&se->post, &argse.post);
3336 desc = argse.expr;
3337
3338 gcc_assert (dim_arg->expr)((void)(!(dim_arg->expr) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3338, __FUNCTION__), 0 : 0))
;
3339 gfc_init_se (&argse, NULL__null);
3340 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
3341 gfc_add_block_to_block (&se->pre, &argse.pre);
3342 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3343 argse.expr, gfc_index_one_nodegfc_rank_cst[1]);
3344 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3345}
3346
3347static void
3348gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3349{
3350 tree arg, cabs;
3351
3352 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3353
3354 switch (expr->value.function.actual->expr->ts.type)
3355 {
3356 case BT_INTEGER:
3357 case BT_REAL:
3358 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg)((contains_struct_check ((arg), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3358, __FUNCTION__))->typed.type)
,
3359 arg);
3360 break;
3361
3362 case BT_COMPLEX:
3363 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3364 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3365 break;
3366
3367 default:
3368 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3368, __FUNCTION__))
;
3369 }
3370}
3371
3372
3373/* Create a complex value from one or two real components. */
3374
3375static void
3376gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3377{
3378 tree real;
3379 tree imag;
3380 tree type;
3381 tree *args;
3382 unsigned int num_args;
3383
3384 num_args = gfc_intrinsic_argument_list_length (expr);
3385 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
3386
3387 type = gfc_typenode_for_spec (&expr->ts);
3388 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3389 real = convert (TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3389, __FUNCTION__))->typed.type)
, args[0]);
3390 if (both)
3391 imag = convert (TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3391, __FUNCTION__))->typed.type)
, args[1]);
3392 else if (TREE_CODE (TREE_TYPE (args[0]))((enum tree_code) (((contains_struct_check ((args[0]), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3392, __FUNCTION__))->typed.type))->base.code)
== COMPLEX_TYPE)
3393 {
3394 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3395 TREE_TYPE (TREE_TYPE (args[0]))((contains_struct_check ((((contains_struct_check ((args[0]),
(TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3395, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3395, __FUNCTION__))->typed.type)
, args[0]);
3396 imag = convert (TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3396, __FUNCTION__))->typed.type)
, imag);
3397 }
3398 else
3399 imag = build_real_from_int_cst (TREE_TYPE (type)((contains_struct_check ((type), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3399, __FUNCTION__))->typed.type)
, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
3400
3401 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3402}
3403
3404
3405/* Remainder function MOD(A, P) = A - INT(A / P) * P
3406 MODULO(A, P) = A - FLOOR (A / P) * P
3407
3408 The obvious algorithms above are numerically instable for large
3409 arguments, hence these intrinsics are instead implemented via calls
3410 to the fmod family of functions. It is the responsibility of the
3411 user to ensure that the second argument is non-zero. */
3412
3413static void
3414gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3415{
3416 tree type;
3417 tree tmp;
3418 tree test;
3419 tree test2;
3420 tree fmod;
3421 tree zero;
3422 tree args[2];
3423
3424 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3425
3426 switch (expr->ts.type)
3427 {
3428 case BT_INTEGER:
3429 /* Integer case is easy, we've got a builtin op. */
3430 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3430, __FUNCTION__))->typed.type)
;
3431
3432 if (modulo)
3433 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3434 args[0], args[1]);
3435 else
3436 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3437 args[0], args[1]);
3438 break;
3439
3440 case BT_REAL:
3441 fmod = NULL_TREE(tree) __null;
3442 /* Check if we have a builtin fmod. */
3443 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3444
3445 /* The builtin should always be available. */
3446 gcc_assert (fmod != NULL_TREE)((void)(!(fmod != (tree) __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3446, __FUNCTION__), 0 : 0))
;
3447
3448 tmp = build_addr (fmod);
3449 se->expr = build_call_array_loc (input_location,
3450 TREE_TYPE (TREE_TYPE (fmod))((contains_struct_check ((((contains_struct_check ((fmod), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3450, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3450, __FUNCTION__))->typed.type)
,
3451 tmp, 2, args);
3452 if (modulo == 0)
3453 return;
3454
3455 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3455, __FUNCTION__))->typed.type)
;
3456
3457 args[0] = gfc_evaluate_now (args[0], &se->pre);
3458 args[1] = gfc_evaluate_now (args[1], &se->pre);
3459
3460 /* Definition:
3461 modulo = arg - floor (arg/arg2) * arg2
3462
3463 In order to calculate the result accurately, we use the fmod
3464 function as follows.
3465
3466 res = fmod (arg, arg2);
3467 if (res)
3468 {
3469 if ((arg < 0) xor (arg2 < 0))
3470 res += arg2;
3471 }
3472 else
3473 res = copysign (0., arg2);
3474
3475 => As two nested ternary exprs:
3476
3477 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3478 : copysign (0., arg2);
3479
3480 */
3481
3482 zero = gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
3483 tmp = gfc_evaluate_now (se->expr, &se->pre);
3484 if (!flag_signed_zerosglobal_options.x_flag_signed_zeros)
3485 {
3486 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3487 args[0], zero);
3488 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3489 args[1], zero);
3490 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3491 logical_type_node, test, test2);
3492 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3493 tmp, zero);
3494 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3495 logical_type_node, test, test2);
3496 test = gfc_evaluate_now (test, &se->pre);
3497 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3498 fold_build2_loc (input_location,
3499 PLUS_EXPR,
3500 type, tmp, args[1]),
3501 tmp);
3502 }
3503 else
3504 {
3505 tree expr1, copysign, cscall;
3506 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3507 expr->ts.kind);
3508 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3509 args[0], zero);
3510 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3511 args[1], zero);
3512 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3513 logical_type_node, test, test2);
3514 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3515 fold_build2_loc (input_location,
3516 PLUS_EXPR,
3517 type, tmp, args[1]),
3518 tmp);
3519 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3520 tmp, zero);
3521 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3522 args[1]);
3523 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3524 expr1, cscall);
3525 }
3526 return;
3527
3528 default:
3529 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3529, __FUNCTION__))
;
3530 }
3531}
3532
3533/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3534 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3535 where the right shifts are logical (i.e. 0's are shifted in).
3536 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3537 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3538 DSHIFTL(I,J,0) = I
3539 DSHIFTL(I,J,BITSIZE) = J
3540 DSHIFTR(I,J,0) = J
3541 DSHIFTR(I,J,BITSIZE) = I. */
3542
3543static void
3544gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3545{
3546 tree type, utype, stype, arg1, arg2, shift, res, left, right;
3547 tree args[3], cond, tmp;
3548 int bitsize;
3549
3550 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3551
3552 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]))((void)(!(((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3552, __FUNCTION__))->typed.type) == ((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3552, __FUNCTION__))->typed.type)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3552, __FUNCTION__), 0 : 0))
;
3553 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3553, __FUNCTION__))->typed.type)
;
3554 bitsize = TYPE_PRECISION (type)((tree_class_check ((type), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3554, __FUNCTION__))->type_common.precision)
;
3555 utype = unsigned_type_for (type);
3556 stype = TREE_TYPE (args[2])((contains_struct_check ((args[2]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3556, __FUNCTION__))->typed.type)
;
3557
3558 arg1 = gfc_evaluate_now (args[0], &se->pre);
3559 arg2 = gfc_evaluate_now (args[1], &se->pre);
3560 shift = gfc_evaluate_now (args[2], &se->pre);
3561
3562 /* The generic case. */
3563 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3564 build_int_cst (stype, bitsize), shift);
3565 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3566 arg1, dshiftl ? shift : tmp);
3567
3568 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3569 fold_convert (utype, arg2)fold_convert_loc (((location_t) 0), utype, arg2), dshiftl ? tmp : shift);
3570 right = fold_convert (type, right)fold_convert_loc (((location_t) 0), type, right);
3571
3572 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3573
3574 /* Special cases. */
3575 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3576 build_int_cst (stype, 0));
3577 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3578 dshiftl ? arg1 : arg2, res);
3579
3580 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3581 build_int_cst (stype, bitsize));
3582 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3583 dshiftl ? arg2 : arg1, res);
3584
3585 se->expr = res;
3586}
3587
3588
3589/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3590
3591static void
3592gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3593{
3594 tree val;
3595 tree tmp;
3596 tree type;
3597 tree zero;
3598 tree args[2];
3599
3600 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3601 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3601, __FUNCTION__))->typed.type)
;
3602
3603 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3604 val = gfc_evaluate_now (val, &se->pre);
3605
3606 zero = gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
3607 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3608 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3609}
3610
3611
3612/* SIGN(A, B) is absolute value of A times sign of B.
3613 The real value versions use library functions to ensure the correct
3614 handling of negative zero. Integer case implemented as:
3615 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3616 */
3617
3618static void
3619gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3620{
3621 tree tmp;
3622 tree type;
3623 tree args[2];
3624
3625 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3626 if (expr->ts.type == BT_REAL)
3627 {
3628 tree abs;
3629
3630 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3631 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3632
3633 /* We explicitly have to ignore the minus sign. We do so by using
3634 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3635 if (!flag_sign_zeroglobal_options.x_flag_sign_zero
3636 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))((((enum mode_class) mode_class[((((enum tree_code) ((tree_class_check
((((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
]) == MODE_FLOAT || ((enum mode_class) mode_class[((((enum tree_code
) ((tree_class_check ((((contains_struct_check ((args[1]), (TS_TYPED
), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
]) == MODE_DECIMAL_FLOAT || ((enum mode_class) mode_class[(((
(enum tree_code) ((tree_class_check ((((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
]) == MODE_COMPLEX_FLOAT || ((enum mode_class) mode_class[(((
(enum tree_code) ((tree_class_check ((((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
]) == MODE_VECTOR_FLOAT) && ((real_format_for_mode[((
(enum mode_class) mode_class[as_a <scalar_float_mode> (
(mode_to_inner (((((enum tree_code) ((tree_class_check ((((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
)))]) == MODE_DECIMAL_FLOAT) ? (((as_a <scalar_float_mode>
((mode_to_inner (((((enum tree_code) ((tree_class_check ((((
contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
)))) - MIN_MODE_DECIMAL_FLOAT) + (MAX_MODE_FLOAT - MIN_MODE_FLOAT
+ 1)) : ((enum mode_class) mode_class[as_a <scalar_float_mode
> ((mode_to_inner (((((enum tree_code) ((tree_class_check (
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
)))]) == MODE_FLOAT ? ((as_a <scalar_float_mode> ((mode_to_inner
(((((enum tree_code) ((tree_class_check ((((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)))->base.code) == VECTOR_TYPE) ? vector_type_mode
(((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type)) : (((contains_struct_check
((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__))->typed.type))->type_common.mode)
)))) - MIN_MODE_FLOAT) : ((fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3636, __FUNCTION__)), 0)]))->has_signed_zero)
)
3637 {
3638 tree cond, zero;
3639 zero = build_real_from_int_cst (TREE_TYPE (args[1])((contains_struct_check ((args[1]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3639, __FUNCTION__))->typed.type)
, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
3640 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3641 args[1], zero);
3642 se->expr = fold_build3_loc (input_location, COND_EXPR,
3643 TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3643, __FUNCTION__))->typed.type)
, cond,
3644 build_call_expr_loc (input_location, abs, 1,
3645 args[0]),
3646 build_call_expr_loc (input_location, tmp, 2,
3647 args[0], args[1]));
3648 }
3649 else
3650 se->expr = build_call_expr_loc (input_location, tmp, 2,
3651 args[0], args[1]);
3652 return;
3653 }
3654
3655 /* Having excluded floating point types, we know we are now dealing
3656 with signed integer types. */
3657 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3657, __FUNCTION__))->typed.type)
;
3658
3659 /* Args[0] is used multiple times below. */
3660 args[0] = gfc_evaluate_now (args[0], &se->pre);
3661
3662 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3663 the signs of A and B are the same, and of all ones if they differ. */
3664 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3665 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3666 build_int_cst (type, TYPE_PRECISION (type)((tree_class_check ((type), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3666, __FUNCTION__))->type_common.precision)
- 1));
3667 tmp = gfc_evaluate_now (tmp, &se->pre);
3668
3669 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3670 is all ones (i.e. -1). */
3671 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3672 fold_build2_loc (input_location, PLUS_EXPR,
3673 type, args[0], tmp), tmp);
3674}
3675
3676
3677/* Test for the presence of an optional argument. */
3678
3679static void
3680gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3681{
3682 gfc_expr *arg;
3683
3684 arg = expr->value.function.actual->expr;
3685 gcc_assert (arg->expr_type == EXPR_VARIABLE)((void)(!(arg->expr_type == EXPR_VARIABLE) ? fancy_abort (
"/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3685, __FUNCTION__), 0 : 0))
;
3686 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3687 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3688}
3689
3690
3691/* Calculate the double precision product of two single precision values. */
3692
3693static void
3694gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3695{
3696 tree type;
3697 tree args[2];
3698
3699 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3700
3701 /* Convert the args to double precision before multiplying. */
3702 type = gfc_typenode_for_spec (&expr->ts);
3703 args[0] = convert (type, args[0]);
3704 args[1] = convert (type, args[1]);
3705 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3706 args[1]);
3707}
3708
3709
3710/* Return a length one character string containing an ascii character. */
3711
3712static void
3713gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3714{
3715 tree arg[2];
3716 tree var;
3717 tree type;
3718 unsigned int num_args;
3719
3720 num_args = gfc_intrinsic_argument_list_length (expr);
3721 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3722
3723 type = gfc_get_char_type (expr->ts.kind);
3724 var = gfc_create_var (type, "char");
3725
3726 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3727 gfc_add_modify (&se->pre, var, arg[0]);
3728 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3729 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3730}
3731
3732
3733static void
3734gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3735{
3736 tree var;
3737 tree len;
3738 tree tmp;
3739 tree cond;
3740 tree fndecl;
3741 tree *args;
3742 unsigned int num_args;
3743
3744 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3745 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
3746
3747 var = gfc_create_var (pchar_type_node, "pstr");
3748 len = gfc_create_var (gfc_charlen_type_node, "len");
3749
3750 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3751 args[0] = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
3752 args[1] = gfc_build_addr_expr (NULL_TREE(tree) __null, len);
3753
3754 fndecl = build_addr (gfor_fndecl_ctime);
3755 tmp = build_call_array_loc (input_location,
3756 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime))((contains_struct_check ((((contains_struct_check ((gfor_fndecl_ctime
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3756, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3756, __FUNCTION__))->typed.type)
,
3757 fndecl, num_args, args);
3758 gfc_add_expr_to_block (&se->pre, tmp);
3759
3760 /* Free the temporary afterwards, if necessary. */
3761 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3762 len, 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-intrinsic.c"
, 3762, __FUNCTION__))->typed.type)
, 0));
3763 tmp = gfc_call_free (var);
3764 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
3765 gfc_add_expr_to_block (&se->post, tmp);
3766
3767 se->expr = var;
3768 se->string_length = len;
3769}
3770
3771
3772static void
3773gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3774{
3775 tree var;
3776 tree len;
3777 tree tmp;
3778 tree cond;
3779 tree fndecl;
3780 tree *args;
3781 unsigned int num_args;
3782
3783 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3784 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
3785
3786 var = gfc_create_var (pchar_type_node, "pstr");
3787 len = gfc_create_var (gfc_charlen_type_node, "len");
3788
3789 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3790 args[0] = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
3791 args[1] = gfc_build_addr_expr (NULL_TREE(tree) __null, len);
3792
3793 fndecl = build_addr (gfor_fndecl_fdate);
3794 tmp = build_call_array_loc (input_location,
3795 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate))((contains_struct_check ((((contains_struct_check ((gfor_fndecl_fdate
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3795, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 3795, __FUNCTION__))->typed.type)
,
3796 fndecl, num_args, args);
3797 gfc_add_expr_to_block (&se->pre, tmp);
3798
3799 /* Free the temporary afterwards, if necessary. */
3800 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3801 len, 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-intrinsic.c"
, 3801, __FUNCTION__))->typed.type)
, 0));
3802 tmp = gfc_call_free (var);
3803 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
3804 gfc_add_expr_to_block (&se->post, tmp);
3805
3806 se->expr = var;
3807 se->string_length = len;
3808}
3809
3810
3811/* Generate a direct call to free() for the FREE subroutine. */
3812
3813static tree
3814conv_intrinsic_free (gfc_code *code)
3815{
3816 stmtblock_t block;
3817 gfc_se argse;
3818 tree arg, call;
3819
3820 gfc_init_se (&argse, NULL__null);
3821 gfc_conv_expr (&argse, code->ext.actual->expr);
3822 arg = fold_convert (ptr_type_node, argse.expr)fold_convert_loc (((location_t) 0), global_trees[TI_PTR_TYPE]
, argse.expr)
;
3823
3824 gfc_init_block (&block);
3825 call = build_call_expr_loc (input_location,
3826 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3827 gfc_add_expr_to_block (&block, call);
3828 return gfc_finish_block (&block);
3829}
3830
3831
3832/* Call the RANDOM_INIT library subroutine with a hidden argument for
3833 handling seeding on coarray images. */
3834
3835static tree
3836conv_intrinsic_random_init (gfc_code *code)
3837{
3838 stmtblock_t block;
3839 gfc_se se;
3840 tree arg1, arg2, arg3, tmp;
3841 tree logical4_type_node = gfc_get_logical_type (4);
3842
3843 /* Make the function call. */
3844 gfc_init_block (&block);
3845 gfc_init_se (&se, NULL__null);
3846
3847 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3848 gfc_conv_expr (&se, code->ext.actual->expr);
3849 gfc_add_block_to_block (&block, &se.pre);
3850 arg1 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block))fold_convert_loc (((location_t) 0), logical4_type_node, gfc_evaluate_now
(se.expr, &block))
;
3851 gfc_add_block_to_block (&block, &se.post);
3852
3853 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3854 gfc_conv_expr (&se, code->ext.actual->next->expr);
3855 gfc_add_block_to_block (&block, &se.pre);
3856 arg2 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block))fold_convert_loc (((location_t) 0), logical4_type_node, gfc_evaluate_now
(se.expr, &block))
;
3857 gfc_add_block_to_block (&block, &se.post);
3858
3859 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3860 simply set this to 0. For -fcoarray=lib, generate a call to
3861 THIS_IMAGE() without arguments. */
3862 arg3 = build_int_cst (gfc_get_int_type (4), 0);
3863 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_LIB)
3864 {
3865 arg3 = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image,
3866 1, arg3);
3867 se.expr = fold_convert (gfc_get_int_type (4), arg3)fold_convert_loc (((location_t) 0), gfc_get_int_type (4), arg3
)
;
3868 }
3869
3870 tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3,
3871 arg1, arg2, arg3);
3872 gfc_add_expr_to_block (&block, tmp);
3873
3874 return gfc_finish_block (&block);
3875}
3876
3877
3878/* Call the SYSTEM_CLOCK library functions, handling the type and kind
3879 conversions. */
3880
3881static tree
3882conv_intrinsic_system_clock (gfc_code *code)
3883{
3884 stmtblock_t block;
3885 gfc_se count_se, count_rate_se, count_max_se;
3886 tree arg1 = NULL_TREE(tree) __null, arg2 = NULL_TREE(tree) __null, arg3 = NULL_TREE(tree) __null;
3887 tree tmp;
3888 int least;
3889
3890 gfc_expr *count = code->ext.actual->expr;
3891 gfc_expr *count_rate = code->ext.actual->next->expr;
3892 gfc_expr *count_max = code->ext.actual->next->next->expr;
3893
3894 /* Evaluate our arguments. */
3895 if (count)
3896 {
3897 gfc_init_se (&count_se, NULL__null);
3898 gfc_conv_expr (&count_se, count);
3899 }
3900
3901 if (count_rate)
3902 {
3903 gfc_init_se (&count_rate_se, NULL__null);
3904 gfc_conv_expr (&count_rate_se, count_rate);
3905 }
3906
3907 if (count_max)
3908 {
3909 gfc_init_se (&count_max_se, NULL__null);
3910 gfc_conv_expr (&count_max_se, count_max);
3911 }
3912
3913 /* Find the smallest kind found of the arguments. */
3914 least = 16;
3915 least = (count && count->ts.kind < least) ? count->ts.kind : least;
3916 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3917 : least;
3918 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3919 : least;
3920
3921 /* Prepare temporary variables. */
3922
3923 if (count)
3924 {
3925 if (least >= 8)
3926 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3927 else if (least == 4)
3928 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3929 else if (count->ts.kind == 1)
3930 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3931 count->ts.kind);
3932 else
3933 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3934 count->ts.kind);
3935 }
3936
3937 if (count_rate)
3938 {
3939 if (least >= 8)
3940 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3941 else if (least == 4)
3942 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3943 else
3944 arg2 = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
3945 }
3946
3947 if (count_max)
3948 {
3949 if (least >= 8)
3950 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3951 else if (least == 4)
3952 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3953 else
3954 arg3 = integer_zero_nodeglobal_trees[TI_INTEGER_ZERO];
3955 }
3956
3957 /* Make the function call. */
3958 gfc_init_block (&block);
3959
3960if (least <= 2)
3961 {
3962 if (least == 1)
3963 {
3964 arg1 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg1)
3965 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3966 arg2 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg2)
3967 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3968 arg3 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg3)
3969 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3970 }
3971
3972 if (least == 2)
3973 {
3974 arg1 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg1)
3975 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3976 arg2 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg2)
3977 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3978 arg3 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg3)
3979 : null_pointer_nodeglobal_trees[TI_NULL_POINTER];
3980 }
3981 }
3982else
3983 {
3984 if (least == 4)
3985 {
3986 tmp = build_call_expr_loc (input_location,
3987 gfor_fndecl_system_clock4, 3,
3988 arg1 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg1)
3989 : null_pointer_nodeglobal_trees[TI_NULL_POINTER],
3990 arg2 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg2)
3991 : null_pointer_nodeglobal_trees[TI_NULL_POINTER],
3992 arg3 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg3)
3993 : null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
3994 gfc_add_expr_to_block (&block, tmp);
3995 }
3996 /* Handle kind>=8, 10, or 16 arguments */
3997 if (least >= 8)
3998 {
3999 tmp = build_call_expr_loc (input_location,
4000 gfor_fndecl_system_clock8, 3,
4001 arg1 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg1)
4002 : null_pointer_nodeglobal_trees[TI_NULL_POINTER],
4003 arg2 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg2)
4004 : null_pointer_nodeglobal_trees[TI_NULL_POINTER],
4005 arg3 ? gfc_build_addr_expr (NULL_TREE(tree) __null, arg3)
4006 : null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
4007 gfc_add_expr_to_block (&block, tmp);
4008 }
4009 }
4010
4011 /* And store values back if needed. */
4012 if (arg1 && arg1 != count_se.expr)
4013 gfc_add_modify (&block, count_se.expr,
4014 fold_convert (TREE_TYPE (count_se.expr), arg1)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(count_se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4014, __FUNCTION__))->typed.type), arg1)
);
4015 if (arg2 && arg2 != count_rate_se.expr)
4016 gfc_add_modify (&block, count_rate_se.expr,
4017 fold_convert (TREE_TYPE (count_rate_se.expr), arg2)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(count_rate_se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4017, __FUNCTION__))->typed.type), arg2)
);
4018 if (arg3 && arg3 != count_max_se.expr)
4019 gfc_add_modify (&block, count_max_se.expr,
4020 fold_convert (TREE_TYPE (count_max_se.expr), arg3)fold_convert_loc (((location_t) 0), ((contains_struct_check (
(count_max_se.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4020, __FUNCTION__))->typed.type), arg3)
);
4021
4022 return gfc_finish_block (&block);
4023}
4024
4025
4026/* Return a character string containing the tty name. */
4027
4028static void
4029gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
4030{
4031 tree var;
4032 tree len;
4033 tree tmp;
4034 tree cond;
4035 tree fndecl;
4036 tree *args;
4037 unsigned int num_args;
4038
4039 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4040 args = XALLOCAVEC (tree, num_args)((tree *) __builtin_alloca(sizeof (tree) * (num_args)));
4041
4042 var = gfc_create_var (pchar_type_node, "pstr");
4043 len = gfc_create_var (gfc_charlen_type_node, "len");
4044
4045 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4046 args[0] = gfc_build_addr_expr (NULL_TREE(tree) __null, var);
4047 args[1] = gfc_build_addr_expr (NULL_TREE(tree) __null, len);
4048
4049 fndecl = build_addr (gfor_fndecl_ttynam);
4050 tmp = build_call_array_loc (input_location,
4051 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam))((contains_struct_check ((((contains_struct_check ((gfor_fndecl_ttynam
), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4051, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4051, __FUNCTION__))->typed.type)
,
4052 fndecl, num_args, args);
4053 gfc_add_expr_to_block (&se->pre, tmp);
4054
4055 /* Free the temporary afterwards, if necessary. */
4056 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4057 len, 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-intrinsic.c"
, 4057, __FUNCTION__))->typed.type)
, 0));
4058 tmp = gfc_call_free (var);
4059 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
4060 gfc_add_expr_to_block (&se->post, tmp);
4061
4062 se->expr = var;
4063 se->string_length = len;
4064}
4065
4066
4067/* Get the minimum/maximum value of all the parameters.
4068 minmax (a1, a2, a3, ...)
4069 {
4070 mvar = a1;
4071 mvar = COMP (mvar, a2)
4072 mvar = COMP (mvar, a3)
4073 ...
4074 return mvar;
4075 }
4076 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4077 care about NaNs, or IFN_FMIN/MAX when the target has support for
4078 fast NaN-honouring min/max. When neither holds expand a sequence
4079 of explicit comparisons. */
4080
4081/* TODO: Mismatching types can occur when specific names are used.
4082 These should be handled during resolution. */
4083static void
4084gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
4085{
4086 tree tmp;
4087 tree mvar;
4088 tree val;
4089 tree *args;
4090 tree type;
4091 tree argtype;
4092 gfc_actual_arglist *argexpr;
4093 unsigned int i, nargs;
4094
4095 nargs = gfc_intrinsic_argument_list_length (expr);
4096 args = XALLOCAVEC (tree, nargs)((tree *) __builtin_alloca(sizeof (tree) * (nargs)));
4097
4098 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
4099 type = gfc_typenode_for_spec (&expr->ts);
4100
4101 /* Only evaluate the argument once. */
4102 if (!VAR_P (args[0])(((enum tree_code) (args[0])->base.code) == VAR_DECL) && !TREE_CONSTANT (args[0])((non_type_check ((args[0]), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4102, __FUNCTION__))->base.constant_flag)
)
4103 args[0] = gfc_evaluate_now (args[0], &se->pre);
4104
4105 /* Determine suitable type of temporary, as a GNU extension allows
4106 different argument kinds. */
4107 argtype = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4107, __FUNCTION__))->typed.type)
;
4108 argexpr = expr->value.function.actual;
4109 for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4110 {
4111 tree tmptype = TREE_TYPE (args[i])((contains_struct_check ((args[i]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4111, __FUNCTION__))->typed.type)
;
4112 if (TYPE_PRECISION (tmptype)((tree_class_check ((tmptype), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4112, __FUNCTION__))->type_common.precision)
> TYPE_PRECISION (argtype)((tree_class_check ((argtype), (tcc_type), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4112, __FUNCTION__))->type_common.precision)
)
4113 argtype = tmptype;
4114 }
4115 mvar = gfc_create_var (argtype, "M");
4116 gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
4117
4118 argexpr = expr->value.function.actual;
4119 for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4120 {
4121 tree cond = NULL_TREE(tree) __null;
4122 val = args[i];
4123
4124 /* Handle absent optional arguments by ignoring the comparison. */
4125 if (argexpr->expr->expr_type == EXPR_VARIABLE
4126 && argexpr->expr->symtree->n.sym->attr.optional
4127 && TREE_CODE (val)((enum tree_code) (val)->base.code) == INDIRECT_REF)
4128 {
4129 cond = fold_build2_loc (input_location,
4130 NE_EXPR, logical_type_node,
4131 TREE_OPERAND (val, 0)(*((const_cast<tree*> (tree_operand_check ((val), (0), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4131, __FUNCTION__)))))
,
4132 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0))((contains_struct_check (((*((const_cast<tree*> (tree_operand_check
((val), (0), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4132, __FUNCTION__)))))), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4132, __FUNCTION__))->typed.type)
, 0));
4133 }
4134 else if (!VAR_P (val)(((enum tree_code) (val)->base.code) == VAR_DECL) && !TREE_CONSTANT (val)((non_type_check ((val), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4134, __FUNCTION__))->base.constant_flag)
)
4135 /* Only evaluate the argument once. */
4136 val = gfc_evaluate_now (val, &se->pre);
4137
4138 tree calc;
4139 /* For floating point types, the question is what MAX(a, NaN) or
4140 MIN(a, NaN) should return (where "a" is a normal number).
4141 There are valid usecase for returning either one, but the
4142 Fortran standard doesn't specify which one should be chosen.
4143 Also, there is no consensus among other tested compilers. In
4144 short, it's a mess. So lets just do whatever is fastest. */
4145 tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
4146 calc = fold_build2_loc (input_location, code, argtype,
4147 convert (argtype, val), mvar);
4148 tmp = build2_v (MODIFY_EXPR, mvar, calc)fold_build2_loc (input_location, MODIFY_EXPR, global_trees[TI_VOID_TYPE
], mvar, calc)
;
4149
4150 if (cond != NULL_TREE(tree) __null)
4151 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))
4152 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
4153 gfc_add_expr_to_block (&se->pre, tmp);
4154 }
4155 if (TREE_CODE (type)((enum tree_code) (type)->base.code) == INTEGER_TYPE)
4156 se->expr = fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, mvar);
4157 else
4158 se->expr = convert (type, mvar);
4159}
4160
4161
4162/* Generate library calls for MIN and MAX intrinsics for character
4163 variables. */
4164static void
4165gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
4166{
4167 tree *args;
4168 tree var, len, fndecl, tmp, cond, function;
4169 unsigned int nargs;
4170
4171 nargs = gfc_intrinsic_argument_list_length (expr);
4172 args = XALLOCAVEC (tree, nargs + 4)((tree *) __builtin_alloca(sizeof (tree) * (nargs + 4)));
4173 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
4174
4175 /* Create the result variables. */
4176 len = gfc_create_var (gfc_charlen_type_node, "len");
4177 args[0] = gfc_build_addr_expr (NULL_TREE(tree) __null, len);
4178 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4179 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
4180 args[2] = build_int_cst (integer_type_nodeinteger_types[itk_int], op);
4181 args[3] = build_int_cst (integer_type_nodeinteger_types[itk_int], nargs / 2);
4182
4183 if (expr->ts.kind == 1)
4184 function = gfor_fndecl_string_minmax;
4185 else if (expr->ts.kind == 4)
4186 function = gfor_fndecl_string_minmax_char4;
4187 else
4188 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4188, __FUNCTION__))
;
4189
4190 /* Make the function call. */
4191 fndecl = build_addr (function);
4192 tmp = build_call_array_loc (input_location,
4193 TREE_TYPE (TREE_TYPE (function))((contains_struct_check ((((contains_struct_check ((function)
, (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4193, __FUNCTION__))->typed.type)), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4193, __FUNCTION__))->typed.type)
, fndecl,
4194 nargs + 4, args);
4195 gfc_add_expr_to_block (&se->pre, tmp);
4196
4197 /* Free the temporary afterwards, if necessary. */
4198 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4199 len, 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-intrinsic.c"
, 4199, __FUNCTION__))->typed.type)
, 0));
4200 tmp = gfc_call_free (var);
4201 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
4202 gfc_add_expr_to_block (&se->post, tmp);
4203
4204 se->expr = var;
4205 se->string_length = len;
4206}
4207
4208
4209/* Create a symbol node for this intrinsic. The symbol from the frontend
4210 has the generic name. */
4211
4212static gfc_symbol *
4213gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
4214{
4215 gfc_symbol *sym;
4216
4217 /* TODO: Add symbols for intrinsic function to the global namespace. */
4218 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5)((void)(!(strlen (expr->value.function.name) <= 63 - 5)
? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4218, __FUNCTION__), 0 : 0))
;
4219 sym = gfc_new_symbol (expr->value.function.name, NULL__null);
4220
4221 sym->ts = expr->ts;
4222 sym->attr.external = 1;
4223 sym->attr.function = 1;
4224 sym->attr.always_explicit = 1;
4225 sym->attr.proc = PROC_INTRINSIC;
4226 sym->attr.flavor = FL_PROCEDURE;
4227 sym->result = sym;
4228 if (expr->rank > 0)
4229 {
4230 sym->attr.dimension = 1;
4231 sym->as = gfc_get_array_spec ()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
4232 sym->as->type = AS_ASSUMED_SHAPE;
4233 sym->as->rank = expr->rank;
4234 }
4235
4236 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4237 ignore_optional ? expr->value.function.actual
4238 : NULL__null);
4239
4240 return sym;
4241}
4242
4243/* Remove empty actual arguments. */
4244
4245static void
4246remove_empty_actual_arguments (gfc_actual_arglist **ap)
4247{
4248 while (*ap)
4249 {
4250 if ((*ap)->expr == NULL__null)
4251 {
4252 gfc_actual_arglist *r = *ap;
4253 *ap = r->next;
4254 r->next = NULL__null;
4255 gfc_free_actual_arglist (r);
4256 }
4257 else
4258 ap = &((*ap)->next);
4259 }
4260}
4261
4262#define MAX_SPEC_ARG 12
4263
4264/* Make up an fn spec that's right for intrinsic functions that we
4265 want to call. */
4266
4267static char *
4268intrinsic_fnspec (gfc_expr *expr)
4269{
4270 static char fnspec_buf[MAX_SPEC_ARG*2+1];
4271 char *fp;
4272 int i;
4273 int num_char_args;
4274
4275#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4276
4277 /* Set the fndecl. */
4278 fp = fnspec_buf;
4279 /* Function return value. FIXME: Check if the second letter could
4280 be something other than a space, for further optimization. */
4281 ADD_CHAR ('.');
4282 if (expr->rank == 0)
4283 {
4284 if (expr->ts.type == BT_CHARACTER)
4285 {
4286 ADD_CHAR ('w'); /* Address of character. */
4287 ADD_CHAR ('.'); /* Length of character. */
4288 }
4289 }
4290 else
4291 ADD_CHAR ('w'); /* Return value is a descriptor. */
4292
4293 num_char_args = 0;
4294 for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
4295 {
4296 if (a->expr == NULL__null)
4297 continue;
4298
4299 if (a->name && strcmp (a->name,"%VAL") == 0)
4300 ADD_CHAR ('.');
4301 else
4302 {
4303 if (a->expr->rank > 0)
4304 ADD_CHAR ('r');
4305 else
4306 ADD_CHAR ('R');
4307 }
4308 num_char_args += a->expr->ts.type == BT_CHARACTER;
4309 gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2)((void)(!(fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*
2) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4309, __FUNCTION__), 0 : 0))
;
4310 }
4311
4312 for (i = 0; i < num_char_args; i++)
4313 ADD_CHAR ('.');
4314
4315 *fp = '\0';
4316 return fnspec_buf;
4317}
4318
4319#undef MAX_SPEC_ARG
4320#undef ADD_CHAR
4321
4322/* Generate the right symbol for the specific intrinsic function and
4323 modify the expr accordingly. This assumes that absent optional
4324 arguments should be removed. */
4325
4326gfc_symbol *
4327specific_intrinsic_symbol (gfc_expr *expr)
4328{
4329 gfc_symbol *sym;
4330
4331 sym = gfc_find_intrinsic_symbol (expr);
22
Value assigned to field 'external_blas', which participates in a condition later
4332 if (sym == NULL__null)
23
Assuming 'sym' is not equal to NULL
24
Taking false branch
4333 {
4334 sym = gfc_get_intrinsic_function_symbol (expr);
4335 sym->ts = expr->ts;
4336 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
4337 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL__null);
4338
4339 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4340 expr->value.function.actual, true);
4341 sym->backend_decl
4342 = gfc_get_extern_function_decl (sym, expr->value.function.actual,
4343 intrinsic_fnspec (expr));
4344 }
4345
4346 remove_empty_actual_arguments (&(expr->value.function.actual));
4347
4348 return sym;
4349}
4350
4351/* Generate a call to an external intrinsic function. FIXME: So far,
4352 this only works for functions which are called with well-defined
4353 types; CSHIFT and friends will come later. */
4354
4355static void
4356gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4357{
4358 gfc_symbol *sym;
4359 vec<tree, va_gc> *append_args;
4360 bool specific_symbol;
4361
4362 gcc_assert (!se->ss || se->ss->info->expr == expr)((void)(!(!se->ss || se->ss->info->expr == expr) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4362, __FUNCTION__), 0 : 0))
;
15
'?' condition is false
4363
4364 if (se->ss
15.1
Field 'ss' is null
15.1
Field 'ss' is null
)
16
Taking false branch
4365 gcc_assert (expr->rank > 0)((void)(!(expr->rank > 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4365, __FUNCTION__), 0 : 0))
;
4366 else
4367 gcc_assert (expr->rank == 0)((void)(!(expr->rank == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4367, __FUNCTION__), 0 : 0))
;
17
'?' condition is false
4368
4369 switch (expr->value.function.isym->id)
18
Control jumps to 'case GFC_ISYM_FINDLOC:' at line 4373
4370 {
4371 case GFC_ISYM_ANY:
4372 case GFC_ISYM_ALL:
4373 case GFC_ISYM_FINDLOC:
4374 case GFC_ISYM_MAXLOC:
4375 case GFC_ISYM_MINLOC:
4376 case GFC_ISYM_MAXVAL:
4377 case GFC_ISYM_MINVAL:
4378 case GFC_ISYM_NORM2:
4379 case GFC_ISYM_PRODUCT:
4380 case GFC_ISYM_SUM:
4381 specific_symbol = true;
4382 break;
19
Execution continues on line 4387
4383 default:
4384 specific_symbol = false;
4385 }
4386
4387 if (specific_symbol
19.1
'specific_symbol' is true
19.1
'specific_symbol' is true
)
20
Taking true branch
4388 {
4389 /* Need to copy here because specific_intrinsic_symbol modifies
4390 expr to omit the absent optional arguments. */
4391 expr = gfc_copy_expr (expr);
4392 sym = specific_intrinsic_symbol (expr);
21
Calling 'specific_intrinsic_symbol'
25
Returning from 'specific_intrinsic_symbol'
4393 }
4394 else
4395 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4396
4397 /* Calls to libgfortran_matmul need to be appended special arguments,
4398 to be able to call the BLAS ?gemm functions if required and possible. */
4399 append_args = NULL__null;
4400 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
26
Assuming field 'id' is equal to GFC_ISYM_MATMUL
29
Taking true branch
4401 && !expr->external_blas
27
Assuming field 'external_blas' is 0
4402 && sym->ts.type != BT_LOGICAL)
28
Assuming field 'type' is not equal to BT_LOGICAL
4403 {
4404 tree cint = gfc_get_int_type (gfc_c_int_kind);
4405
4406 if (flag_external_blasglobal_options.x_flag_external_blas
30
Assuming field 'x_flag_external_blas' is not equal to 0
4407 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
31
Assuming field 'type' is not equal to BT_REAL
32
Assuming field 'type' is equal to BT_COMPLEX
4408 && (sym->ts.kind == 4 || sym->ts.kind == 8))
33
Assuming field 'kind' is equal to 4
4409 {
4410 tree gemm_fndecl;
4411
4412 if (sym->ts.type
33.1
Field 'type' is not equal to BT_REAL
33.1
Field 'type' is not equal to BT_REAL
== BT_REAL)
34
Taking false branch
4413 {
4414 if (sym->ts.kind == 4)
4415 gemm_fndecl = gfor_fndecl_sgemm;
4416 else
4417 gemm_fndecl = gfor_fndecl_dgemm;
4418 }
4419 else
4420 {
4421 if (sym->ts.kind
34.1
Field 'kind' is equal to 4
34.1
Field 'kind' is equal to 4
== 4)
35
Taking true branch
4422 gemm_fndecl = gfor_fndecl_cgemm;
4423 else
4424 gemm_fndecl = gfor_fndecl_zgemm;
4425 }
4426
4427 vec_alloc (append_args, 3);
36
Calling 'vec_alloc<tree_node *, va_gc>'
47
Returning from 'vec_alloc<tree_node *, va_gc>'
4428 append_args->quick_push (build_int_cst (cint, 1));
48
Called C++ object pointer is null
4429 append_args->quick_push (build_int_cst (cint,
4430 flag_blas_matmul_limitglobal_options.x_flag_blas_matmul_limit));
4431 append_args->quick_push (gfc_build_addr_expr (NULL_TREE(tree) __null,
4432 gemm_fndecl));
4433 }
4434 else
4435 {
4436 vec_alloc (append_args, 3);
4437 append_args->quick_push (build_int_cst (cint, 0));
4438 append_args->quick_push (build_int_cst (cint, 0));
4439 append_args->quick_push (null_pointer_nodeglobal_trees[TI_NULL_POINTER]);
4440 }
4441 }
4442
4443 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4444 append_args);
4445
4446 if (specific_symbol)
4447 gfc_free_expr (expr);
4448 else
4449 gfc_free_symbol (sym);
4450}
4451
4452/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4453 Implemented as
4454 any(a)
4455 {
4456 forall (i=...)
4457 if (a[i] != 0)
4458 return 1
4459 end forall
4460 return 0
4461 }
4462 all(a)
4463 {
4464 forall (i=...)
4465 if (a[i] == 0)
4466 return 0
4467 end forall
4468 return 1
4469 }
4470 */
4471static void
4472gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4473{
4474 tree resvar;
4475 stmtblock_t block;
4476 stmtblock_t body;
4477 tree type;
4478 tree tmp;
4479 tree found;
4480 gfc_loopinfo loop;
4481 gfc_actual_arglist *actual;
4482 gfc_ss *arrayss;
4483 gfc_se arrayse;
4484 tree exit_label;
4485
4486 if (se->ss)
4487 {
4488 gfc_conv_intrinsic_funcall (se, expr);
4489 return;
4490 }
4491
4492 actual = expr->value.function.actual;
4493 type = gfc_typenode_for_spec (&expr->ts);
4494 /* Initialize the result. */
4495 resvar = gfc_create_var (type, "test");
4496 if (op == EQ_EXPR)
4497 tmp = convert (type, boolean_true_nodeglobal_trees[TI_BOOLEAN_TRUE]);
4498 else
4499 tmp = convert (type, boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
4500 gfc_add_modify (&se->pre, resvar, tmp);
4501
4502 /* Walk the arguments. */
4503 arrayss = gfc_walk_expr (actual->expr);
4504 gcc_assert (arrayss != gfc_ss_terminator)((void)(!(arrayss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4504, __FUNCTION__), 0 : 0))
;
4505
4506 /* Initialize the scalarizer. */
4507 gfc_init_loopinfo (&loop);
4508 exit_label = gfc_build_label_decl (NULL_TREE(tree) __null);
4509 TREE_USED (exit_label)((exit_label)->base.used_flag) = 1;
4510 gfc_add_ss_to_loop (&loop, arrayss);
4511
4512 /* Initialize the loop. */
4513 gfc_conv_ss_startstride (&loop);
4514 gfc_conv_loop_setup (&loop, &expr->where);
4515
4516 gfc_mark_ss_chain_used (arrayss, 1);
4517 /* Generate the loop body. */
4518 gfc_start_scalarized_body (&loop, &body);
4519
4520 /* If the condition matches then set the return value. */
4521 gfc_start_block (&block);
4522 if (op == EQ_EXPR)
4523 tmp = convert (type, boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
4524 else
4525 tmp = convert (type, boolean_true_nodeglobal_trees[TI_BOOLEAN_TRUE]);
4526 gfc_add_modify (&block, resvar, tmp);
4527
4528 /* And break out of the loop. */
4529 tmp = build1_v (GOTO_EXPR, exit_label)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
4530 gfc_add_expr_to_block (&block, tmp);
4531
4532 found = gfc_finish_block (&block);
4533
4534 /* Check this element. */
4535 gfc_init_se (&arrayse, NULL__null);
4536 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4537 arrayse.ss = arrayss;
4538 gfc_conv_expr_val (&arrayse, actual->expr);
4539
4540 gfc_add_block_to_block (&body, &arrayse.pre);
4541 tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4542 build_int_cst (TREE_TYPE (arrayse.expr)((contains_struct_check ((arrayse.expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4542, __FUNCTION__))->typed.type)
, 0));
4543 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], tmp, found, build_empty_stmt (input_location))
;
4544 gfc_add_expr_to_block (&body, tmp);
4545 gfc_add_block_to_block (&body, &arrayse.post);
4546
4547 gfc_trans_scalarizing_loops (&loop, &body);
4548
4549 /* Add the exit label. */
4550 tmp = build1_v (LABEL_EXPR, exit_label)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], exit_label)
;
4551 gfc_add_expr_to_block (&loop.pre, tmp);
4552
4553 gfc_add_block_to_block (&se->pre, &loop.pre);
4554 gfc_add_block_to_block (&se->pre, &loop.post);
4555 gfc_cleanup_loop (&loop);
4556
4557 se->expr = resvar;
4558}
4559
4560
4561/* Generate the constant 180 / pi, which is used in the conversion
4562 of acosd(), asind(), atand(), atan2d(). */
4563
4564static tree
4565rad2deg (int kind)
4566{
4567 tree retval;
4568 mpfr_t pi, t0;
4569
4570 gfc_set_model_kind (kind);
4571 mpfr_init (pi);
4572 mpfr_init (t0);
4573 mpfr_set_si (t0, 180, GFC_RND_MODEMPFR_RNDN);
4574 mpfr_const_pi (pi, GFC_RND_MODEMPFR_RNDN);
4575 mpfr_div (t0, t0, pi, GFC_RND_MODEMPFR_RNDN);
4576 retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4577 mpfr_clear (t0);
4578 mpfr_clear (pi);
4579 return retval;
4580}
4581
4582
4583/* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4584 ASIND(x) is translated into ASIN(x) * 180 / pi.
4585 ATAND(x) is translated into ATAN(x) * 180 / pi. */
4586
4587static void
4588gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4589{
4590 tree arg;
4591 tree atrigd;
4592 tree type;
4593
4594 type = gfc_typenode_for_spec (&expr->ts);
4595
4596 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4597
4598 if (id == GFC_ISYM_ACOSD)
4599 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS, expr->ts.kind);
4600 else if (id == GFC_ISYM_ASIND)
4601 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN, expr->ts.kind);
4602 else if (id == GFC_ISYM_ATAND)
4603 atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN, expr->ts.kind);
4604 else
4605 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4605, __FUNCTION__))
;
4606
4607 atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4608
4609 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4610 fold_convert (type, rad2deg (expr->ts.kind))fold_convert_loc (((location_t) 0), type, rad2deg (expr->ts
.kind))
);
4611}
4612
4613
4614/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4615 COS(X) / SIN(X) for COMPLEX argument. */
4616
4617static void
4618gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4619{
4620 gfc_intrinsic_map_t *m;
4621 tree arg;
4622 tree type;
4623
4624 type = gfc_typenode_for_spec (&expr->ts);
4625 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4626
4627 if (expr->ts.type == BT_REAL)
4628 {
4629 tree tan;
4630 tree tmp;
4631 mpfr_t pio2;
4632
4633 /* Create pi/2. */
4634 gfc_set_model_kind (expr->ts.kind);
4635 mpfr_init (pio2);
4636 mpfr_const_pi (pio2, GFC_RND_MODEMPFR_RNDN);
4637 mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODEMPFR_RNDN);
4638 tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4639 mpfr_clear (pio2);
4640
4641 /* Find tan builtin function. */
4642 m = gfc_intrinsic_map;
4643 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4644 if (GFC_ISYM_TAN == m->id)
4645 break;
4646
4647 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4648 tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4649 tan = build_call_expr_loc (input_location, tan, 1, tmp);
4650 se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4651 }
4652 else
4653 {
4654 tree sin;
4655 tree cos;
4656
4657 /* Find cos builtin function. */
4658 m = gfc_intrinsic_map;
4659 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4660 if (GFC_ISYM_COS == m->id)
4661 break;
4662
4663 cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4664 cos = build_call_expr_loc (input_location, cos, 1, arg);
4665
4666 /* Find sin builtin function. */
4667 m = gfc_intrinsic_map;
4668 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4669 if (GFC_ISYM_SIN == m->id)
4670 break;
4671
4672 sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4673 sin = build_call_expr_loc (input_location, sin, 1, arg);
4674
4675 /* Divide cos by sin. */
4676 se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4677 }
4678}
4679
4680
4681/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4682
4683static void
4684gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4685{
4686 tree arg;
4687 tree type;
4688 tree ninety_tree;
4689 mpfr_t ninety;
4690
4691 type = gfc_typenode_for_spec (&expr->ts);
4692 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4693
4694 gfc_set_model_kind (expr->ts.kind);
4695
4696 /* Build the tree for x + 90. */
4697 mpfr_init_set_ui (ninety, 90, GFC_RND_MODE)( mpfr_init(ninety), mpfr_set_ui((ninety), (90), (MPFR_RNDN))
)
;
4698 ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4699 arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4700 mpfr_clear (ninety);
4701
4702 /* Find tand. */
4703 gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4704 for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4705 if (GFC_ISYM_TAND == m->id)
4706 break;
4707
4708 tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4709 tand = build_call_expr_loc (input_location, tand, 1, arg);
4710
4711 se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4712}
4713
4714
4715/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4716
4717static void
4718gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4719{
4720 tree args[2];
4721 tree atan2d;
4722 tree type;
4723
4724 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4725 type = TREE_TYPE (args[0])((contains_struct_check ((args[0]), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4725, __FUNCTION__))->typed.type)
;
4726
4727 atan2d = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2, expr->ts.kind);
4728 atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4729
4730 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4731 rad2deg (expr->ts.kind));
4732}
4733
4734
4735/* COUNT(A) = Number of true elements in A. */
4736static void
4737gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4738{
4739 tree resvar;
4740 tree type;
4741 stmtblock_t body;
4742 tree tmp;
4743 gfc_loopinfo loop;
4744 gfc_actual_arglist *actual;
4745 gfc_ss *arrayss;
4746 gfc_se arrayse;
4747
4748 if (se->ss)
4749 {
4750 gfc_conv_intrinsic_funcall (se, expr);
4751 return;
4752 }
4753
4754 actual = expr->value.function.actual;
4755
4756 type = gfc_typenode_for_spec (&expr->ts);
4757 /* Initialize the result. */
4758 resvar = gfc_create_var (type, "count");
4759 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4760
4761 /* Walk the arguments. */
4762 arrayss = gfc_walk_expr (actual->expr);
4763 gcc_assert (arrayss != gfc_ss_terminator)((void)(!(arrayss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4763, __FUNCTION__), 0 : 0))
;
4764
4765 /* Initialize the scalarizer. */
4766 gfc_init_loopinfo (&loop);
4767 gfc_add_ss_to_loop (&loop, arrayss);
4768
4769 /* Initialize the loop. */
4770 gfc_conv_ss_startstride (&loop);
4771 gfc_conv_loop_setup (&loop, &expr->where);
4772
4773 gfc_mark_ss_chain_used (arrayss, 1);
4774 /* Generate the loop body. */
4775 gfc_start_scalarized_body (&loop, &body);
4776
4777 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar)((contains_struct_check ((resvar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4777, __FUNCTION__))->typed.type)
,
4778 resvar, build_int_cst (TREE_TYPE (resvar)((contains_struct_check ((resvar), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4778, __FUNCTION__))->typed.type)
, 1));
4779 tmp = build2_v (MODIFY_EXPR, resvar, tmp)fold_build2_loc (input_location, MODIFY_EXPR, global_trees[TI_VOID_TYPE
], resvar, tmp)
;
4780
4781 gfc_init_se (&arrayse, NULL__null);
4782 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4783 arrayse.ss = arrayss;
4784 gfc_conv_expr_val (&arrayse, actual->expr);
4785 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], arrayse.expr, tmp, build_empty_stmt (input_location))
4786 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], arrayse.expr, tmp, build_empty_stmt (input_location))
;
4787
4788 gfc_add_block_to_block (&body, &arrayse.pre);
4789 gfc_add_expr_to_block (&body, tmp);
4790 gfc_add_block_to_block (&body, &arrayse.post);
4791
4792 gfc_trans_scalarizing_loops (&loop, &body);
4793
4794 gfc_add_block_to_block (&se->pre, &loop.pre);
4795 gfc_add_block_to_block (&se->pre, &loop.post);
4796 gfc_cleanup_loop (&loop);
4797
4798 se->expr = resvar;
4799}
4800
4801
4802/* Update given gfc_se to have ss component pointing to the nested gfc_ss
4803 struct and return the corresponding loopinfo. */
4804
4805static gfc_loopinfo *
4806enter_nested_loop (gfc_se *se)
4807{
4808 se->ss = se->ss->nested_ss;
4809 gcc_assert (se->ss == se->ss->loop->ss)((void)(!(se->ss == se->ss->loop->ss) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4809, __FUNCTION__), 0 : 0))
;
4810
4811 return se->ss->loop;
4812}
4813
4814/* Build the condition for a mask, which may be optional. */
4815
4816static tree
4817conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4818 bool optional_mask)
4819{
4820 tree present;
4821 tree type;
4822
4823 if (optional_mask)
4824 {
4825 type = TREE_TYPE (maskse->expr)((contains_struct_check ((maskse->expr), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4825, __FUNCTION__))->typed.type)
;
4826 present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4827 present = convert (type, present);
4828 present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4829 present);
4830 return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4831 type, present, maskse->expr);
4832 }
4833 else
4834 return maskse->expr;
4835}
4836
4837/* Inline implementation of the sum and product intrinsics. */
4838static void
4839gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4840 bool norm2)
4841{
4842 tree resvar;
4843 tree scale = NULL_TREE(tree) __null;
4844 tree type;
4845 stmtblock_t body;
4846 stmtblock_t block;
4847 tree tmp;
4848 gfc_loopinfo loop, *ploop;
4849 gfc_actual_arglist *arg_array, *arg_mask;
4850 gfc_ss *arrayss = NULL__null;
4851 gfc_ss *maskss = NULL__null;
4852 gfc_se arrayse;
4853 gfc_se maskse;
4854 gfc_se *parent_se;
4855 gfc_expr *arrayexpr;
4856 gfc_expr *maskexpr;
4857 bool optional_mask;
4858
4859 if (expr->rank > 0)
4860 {
4861 gcc_assert (gfc_inline_intrinsic_function_p (expr))((void)(!(gfc_inline_intrinsic_function_p (expr)) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4861, __FUNCTION__), 0 : 0))
;
4862 parent_se = se;
4863 }
4864 else
4865 parent_se = NULL__null;
4866
4867 type = gfc_typenode_for_spec (&expr->ts);
4868 /* Initialize the result. */
4869 resvar = gfc_create_var (type, "val");
4870 if (norm2)
4871 {
4872 /* result = 0.0;
4873 scale = 1.0. */
4874 scale = gfc_create_var (type, "scale");
4875 gfc_add_modify (&se->pre, scale,
4876 gfc_build_const (type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]));
4877 tmp = gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
4878 }
4879 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4880 tmp = gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
4881 else if (op == NE_EXPR)
4882 /* PARITY. */
4883 tmp = convert (type, boolean_false_nodeglobal_trees[TI_BOOLEAN_FALSE]);
4884 else if (op == BIT_AND_EXPR)
4885 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4886 type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]));
4887 else
4888 tmp = gfc_build_const (type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]);
4889
4890 gfc_add_modify (&se->pre, resvar, tmp);
4891
4892 arg_array = expr->value.function.actual;
4893
4894 arrayexpr = arg_array->expr;
4895
4896 if (op == NE_EXPR || norm2)
4897 {
4898 /* PARITY and NORM2. */
4899 maskexpr = NULL__null;
4900 optional_mask = false;
4901 }
4902 else
4903 {
4904 arg_mask = arg_array->next->next;
4905 gcc_assert (arg_mask != NULL)((void)(!(arg_mask != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4905, __FUNCTION__), 0 : 0))
;
4906 maskexpr = arg_mask->expr;
4907 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4908 && maskexpr->symtree->n.sym->attr.dummy
4909 && maskexpr->symtree->n.sym->attr.optional;
4910 }
4911
4912 if (expr->rank == 0)
4913 {
4914 /* Walk the arguments. */
4915 arrayss = gfc_walk_expr (arrayexpr);
4916 gcc_assert (arrayss != gfc_ss_terminator)((void)(!(arrayss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4916, __FUNCTION__), 0 : 0))
;
4917
4918 if (maskexpr && maskexpr->rank > 0)
4919 {
4920 maskss = gfc_walk_expr (maskexpr);
4921 gcc_assert (maskss != gfc_ss_terminator)((void)(!(maskss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4921, __FUNCTION__), 0 : 0))
;
4922 }
4923 else
4924 maskss = NULL__null;
4925
4926 /* Initialize the scalarizer. */
4927 gfc_init_loopinfo (&loop);
4928
4929 /* We add the mask first because the number of iterations is
4930 taken from the last ss, and this breaks if an absent
4931 optional argument is used for mask. */
4932
4933 if (maskexpr && maskexpr->rank > 0)
4934 gfc_add_ss_to_loop (&loop, maskss);
4935 gfc_add_ss_to_loop (&loop, arrayss);
4936
4937 /* Initialize the loop. */
4938 gfc_conv_ss_startstride (&loop);
4939 gfc_conv_loop_setup (&loop, &expr->where);
4940
4941 if (maskexpr && maskexpr->rank > 0)
4942 gfc_mark_ss_chain_used (maskss, 1);
4943 gfc_mark_ss_chain_used (arrayss, 1);
4944
4945 ploop = &loop;
4946 }
4947 else
4948 /* All the work has been done in the parent loops. */
4949 ploop = enter_nested_loop (se);
4950
4951 gcc_assert (ploop)((void)(!(ploop) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 4951, __FUNCTION__), 0 : 0))
;
4952
4953 /* Generate the loop body. */
4954 gfc_start_scalarized_body (ploop, &body);
4955
4956 /* If we have a mask, only add this element if the mask is set. */
4957 if (maskexpr && maskexpr->rank > 0)
4958 {
4959 gfc_init_se (&maskse, parent_se);
4960 gfc_copy_loopinfo_to_se (&maskse, ploop);
4961 if (expr->rank == 0)
4962 maskse.ss = maskss;
4963 gfc_conv_expr_val (&maskse, maskexpr);
4964 gfc_add_block_to_block (&body, &maskse.pre);
4965
4966 gfc_start_block (&block);
4967 }
4968 else
4969 gfc_init_block (&block);
4970
4971 /* Do the actual summation/product. */
4972 gfc_init_se (&arrayse, parent_se);
4973 gfc_copy_loopinfo_to_se (&arrayse, ploop);
4974 if (expr->rank == 0)
4975 arrayse.ss = arrayss;
4976 gfc_conv_expr_val (&arrayse, arrayexpr);
4977 gfc_add_block_to_block (&block, &arrayse.pre);
4978
4979 if (norm2)
4980 {
4981 /* if (x (i) != 0.0)
4982 {
4983 absX = abs(x(i))
4984 if (absX > scale)
4985 {
4986 val = scale/absX;
4987 result = 1.0 + result * val * val;
4988 scale = absX;
4989 }
4990 else
4991 {
4992 val = absX/scale;
4993 result += val * val;
4994 }
4995 } */
4996 tree res1, res2, cond, absX, val;
4997 stmtblock_t ifblock1, ifblock2, ifblock3;
4998
4999 gfc_init_block (&ifblock1);
5000
5001 absX = gfc_create_var (type, "absX");
5002 gfc_add_modify (&ifblock1, absX,
5003 fold_build1_loc (input_location, ABS_EXPR, type,
5004 arrayse.expr));
5005 val = gfc_create_var (type, "val");
5006 gfc_add_expr_to_block (&ifblock1, val);
5007
5008 gfc_init_block (&ifblock2);
5009 gfc_add_modify (&ifblock2, val,
5010 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
5011 absX));
5012 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5013 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
5014 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
5015 gfc_build_const (type, integer_one_nodeglobal_trees[TI_INTEGER_ONE]));
5016 gfc_add_modify (&ifblock2, resvar, res1);
5017 gfc_add_modify (&ifblock2, scale, absX);
5018 res1 = gfc_finish_block (&ifblock2);
5019
5020 gfc_init_block (&ifblock3);
5021 gfc_add_modify (&ifblock3, val,
5022 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
5023 scale));
5024 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5025 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
5026 gfc_add_modify (&ifblock3, resvar, res2);
5027 res2 = gfc_finish_block (&ifblock3);
5028
5029 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5030 absX, scale);
5031 tmp = build3_v (COND_EXPR, cond, res1, res2)fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, res1, res2)
;
5032 gfc_add_expr_to_block (&ifblock1, tmp);
5033 tmp = gfc_finish_block (&ifblock1);
5034
5035 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
5036 arrayse.expr,
5037 gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]));
5038
5039 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, tmp, build_empty_stmt (input_location))
;
5040 gfc_add_expr_to_block (&block, tmp);
5041 }
5042 else
5043 {
5044 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
5045 gfc_add_modify (&block, resvar, tmp);
5046 }
5047
5048 gfc_add_block_to_block (&block, &arrayse.post);
5049
5050 if (maskexpr && maskexpr->rank > 0)
5051 {
5052 /* We enclose the above in if (mask) {...} . If the mask is an
5053 optional argument, generate
5054 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5055 tree ifmask;
5056 tmp = gfc_finish_block (&block);
5057 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5058 tmp = build3_v (COND_EXPR, ifmask, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
5059 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
;
5060 }
5061 else
5062 tmp = gfc_finish_block (&block);
5063 gfc_add_expr_to_block (&body, tmp);
5064
5065 gfc_trans_scalarizing_loops (ploop, &body);
5066
5067 /* For a scalar mask, enclose the loop in an if statement. */
5068 if (maskexpr && maskexpr->rank == 0)
5069 {
5070 gfc_init_block (&block);
5071 gfc_add_block_to_block (&block, &ploop->pre);
5072 gfc_add_block_to_block (&block, &ploop->post);
5073 tmp = gfc_finish_block (&block);
5074
5075 if (expr->rank > 0)
5076 {
5077 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], se->ss->info->data.scalar.value, tmp, build_empty_stmt
(input_location))
5078 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], se->ss->info->data.scalar.value, tmp, build_empty_stmt
(input_location))
;
5079 gfc_advance_se_ss_chain (se);
5080 }
5081 else
5082 {
5083 tree ifmask;
5084
5085 gcc_assert (expr->rank == 0)((void)(!(expr->rank == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5085, __FUNCTION__), 0 : 0))
;
5086 gfc_init_se (&maskse, NULL__null);
5087 gfc_conv_expr_val (&maskse, maskexpr);
5088 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5089 tmp = build3_v (COND_EXPR, ifmask, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
5090 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
;
5091 }
5092
5093 gfc_add_expr_to_block (&block, tmp);
5094 gfc_add_block_to_block (&se->pre, &block);
5095 gcc_assert (se->post.head == NULL)((void)(!(se->post.head == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5095, __FUNCTION__), 0 : 0))
;
5096 }
5097 else
5098 {
5099 gfc_add_block_to_block (&se->pre, &ploop->pre);
5100 gfc_add_block_to_block (&se->pre, &ploop->post);
5101 }
5102
5103 if (expr->rank == 0)
5104 gfc_cleanup_loop (ploop);
5105
5106 if (norm2)
5107 {
5108 /* result = scale * sqrt(result). */
5109 tree sqrt;
5110 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
5111 resvar = build_call_expr_loc (input_location,
5112 sqrt, 1, resvar);
5113 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
5114 }
5115
5116 se->expr = resvar;
5117}
5118
5119
5120/* Inline implementation of the dot_product intrinsic. This function
5121 is based on gfc_conv_intrinsic_arith (the previous function). */
5122static void
5123gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
5124{
5125 tree resvar;
5126 tree type;
5127 stmtblock_t body;
5128 stmtblock_t block;
5129 tree tmp;
5130 gfc_loopinfo loop;
5131 gfc_actual_arglist *actual;
5132 gfc_ss *arrayss1, *arrayss2;
5133 gfc_se arrayse1, arrayse2;
5134 gfc_expr *arrayexpr1, *arrayexpr2;
5135
5136 type = gfc_typenode_for_spec (&expr->ts);
5137
5138 /* Initialize the result. */
5139 resvar = gfc_create_var (type, "val");
5140 if (expr->ts.type == BT_LOGICAL)
5141 tmp = build_int_cst (type, 0);
5142 else
5143 tmp = gfc_build_const (type, integer_zero_nodeglobal_trees[TI_INTEGER_ZERO]);
5144
5145 gfc_add_modify (&se->pre, resvar, tmp);
5146
5147 /* Walk argument #1. */
5148 actual = expr->value.function.actual;
5149 arrayexpr1 = actual->expr;
5150 arrayss1 = gfc_walk_expr (arrayexpr1);
5151 gcc_assert (arrayss1 != gfc_ss_terminator)((void)(!(arrayss1 != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5151, __FUNCTION__), 0 : 0))
;
5152
5153 /* Walk argument #2. */
5154 actual = actual->next;
5155 arrayexpr2 = actual->expr;
5156 arrayss2 = gfc_walk_expr (arrayexpr2);
5157 gcc_assert (arrayss2 != gfc_ss_terminator)((void)(!(arrayss2 != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5157, __FUNCTION__), 0 : 0))
;
5158
5159 /* Initialize the scalarizer. */
5160 gfc_init_loopinfo (&loop);
5161 gfc_add_ss_to_loop (&loop, arrayss1);
5162 gfc_add_ss_to_loop (&loop, arrayss2);
5163
5164 /* Initialize the loop. */
5165 gfc_conv_ss_startstride (&loop);
5166 gfc_conv_loop_setup (&loop, &expr->where);
5167
5168 gfc_mark_ss_chain_used (arrayss1, 1);
5169 gfc_mark_ss_chain_used (arrayss2, 1);
5170
5171 /* Generate the loop body. */
5172 gfc_start_scalarized_body (&loop, &body);
5173 gfc_init_block (&block);
5174
5175 /* Make the tree expression for [conjg(]array1[)]. */
5176 gfc_init_se (&arrayse1, NULL__null);
5177 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
5178 arrayse1.ss = arrayss1;
5179 gfc_conv_expr_val (&arrayse1, arrayexpr1);
5180 if (expr->ts.type == BT_COMPLEX)
5181 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
5182 arrayse1.expr);
5183 gfc_add_block_to_block (&block, &arrayse1.pre);
5184
5185 /* Make the tree expression for array2. */
5186 gfc_init_se (&arrayse2, NULL__null);
5187 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
5188 arrayse2.ss = arrayss2;
5189 gfc_conv_expr_val (&arrayse2, arrayexpr2);
5190 gfc_add_block_to_block (&block, &arrayse2.pre);
5191
5192 /* Do the actual product and sum. */
5193 if (expr->ts.type == BT_LOGICAL)
5194 {
5195 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
5196 arrayse1.expr, arrayse2.expr);
5197 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
5198 }
5199 else
5200 {
5201 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
5202 arrayse2.expr);
5203 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
5204 }
5205 gfc_add_modify (&block, resvar, tmp);
5206
5207 /* Finish up the loop block and the loop. */
5208 tmp = gfc_finish_block (&block);
5209 gfc_add_expr_to_block (&body, tmp);
5210
5211 gfc_trans_scalarizing_loops (&loop, &body);
5212 gfc_add_block_to_block (&se->pre, &loop.pre);
5213 gfc_add_block_to_block (&se->pre, &loop.post);
5214 gfc_cleanup_loop (&loop);
5215
5216 se->expr = resvar;
5217}
5218
5219
5220/* Remove unneeded kind= argument from actual argument list when the
5221 result conversion is dealt with in a different place. */
5222
5223static void
5224strip_kind_from_actual (gfc_actual_arglist * actual)
5225{
5226 for (gfc_actual_arglist *a = actual; a; a = a->next)
5227 {
5228 if (a && a->name && strcmp (a->name, "kind") == 0)
5229 {
5230 gfc_free_expr (a->expr);
5231 a->expr = NULL__null;
5232 }
5233 }
5234}
5235
5236/* Emit code for minloc or maxloc intrinsic. There are many different cases
5237 we need to handle. For performance reasons we sometimes create two
5238 loops instead of one, where the second one is much simpler.
5239 Examples for minloc intrinsic:
5240 1) Result is an array, a call is generated
5241 2) Array mask is used and NaNs need to be supported:
5242 limit = Infinity;
5243 pos = 0;
5244 S = from;
5245 while (S <= to) {
5246 if (mask[S]) {
5247 if (pos == 0) pos = S + (1 - from);
5248 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5249 }
5250 S++;
5251 }
5252 goto lab2;
5253 lab1:;
5254 while (S <= to) {
5255 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5256 S++;
5257 }
5258 lab2:;
5259 3) NaNs need to be supported, but it is known at compile time or cheaply
5260 at runtime whether array is nonempty or not:
5261 limit = Infinity;
5262 pos = 0;
5263 S = from;
5264 while (S <= to) {
5265 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5266 S++;
5267 }
5268 if (from <= to) pos = 1;
5269 goto lab2;
5270 lab1:;
5271 while (S <= to) {
5272 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5273 S++;
5274 }
5275 lab2:;
5276 4) NaNs aren't supported, array mask is used:
5277 limit = infinities_supported ? Infinity : huge (limit);
5278 pos = 0;
5279 S = from;
5280 while (S <= to) {
5281 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5282 S++;
5283 }
5284 goto lab2;
5285 lab1:;
5286 while (S <= to) {
5287 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5288 S++;
5289 }
5290 lab2:;
5291 5) Same without array mask:
5292 limit = infinities_supported ? Infinity : huge (limit);
5293 pos = (from <= to) ? 1 : 0;
5294 S = from;
5295 while (S <= to) {
5296 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5297 S++;
5298 }
5299 For 3) and 5), if mask is scalar, this all goes into a conditional,
5300 setting pos = 0; in the else branch.
5301
5302 Since we now also support the BACK argument, instead of using
5303 if (a[S] < limit), we now use
5304
5305 if (back)
5306 cond = a[S] <= limit;
5307 else
5308 cond = a[S] < limit;
5309 if (cond) {
5310 ....
5311
5312 The optimizer is smart enough to move the condition out of the loop.
5313 The are now marked as unlikely to for further speedup. */
5314
5315static void
5316gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5317{
5318 stmtblock_t body;
5319 stmtblock_t block;
5320 stmtblock_t ifblock;
5321 stmtblock_t elseblock;
5322 tree limit;
5323 tree type;
5324 tree tmp;
5325 tree cond;
5326 tree elsetmp;
5327 tree ifbody;
5328 tree offset;
5329 tree nonempty;
5330 tree lab1, lab2;
5331 tree b_if, b_else;
5332 gfc_loopinfo loop;
5333 gfc_actual_arglist *actual;
5334 gfc_ss *arrayss;
5335 gfc_ss *maskss;
5336 gfc_se arrayse;
5337 gfc_se maskse;
5338 gfc_expr *arrayexpr;
5339 gfc_expr *maskexpr;
5340 gfc_expr *backexpr;
5341 gfc_se backse;
5342 tree pos;
5343 int n;
5344 bool optional_mask;
5345
5346 actual = expr->value.function.actual;
5347
5348 /* The last argument, BACK, is passed by value. Ensure that
5349 by setting its name to %VAL. */
5350 for (gfc_actual_arglist *a = actual; a; a = a->next)
5351 {
5352 if (a->next == NULL__null)
5353 a->name = "%VAL";
5354 }
5355
5356 if (se->ss)
5357 {
5358 gfc_conv_intrinsic_funcall (se, expr);
5359 return;
5360 }
5361
5362 arrayexpr = actual->expr;
5363
5364 /* Special case for character maxloc. Remove unneeded actual
5365 arguments, then call a library function. */
5366
5367 if (arrayexpr->ts.type == BT_CHARACTER)
5368 {
5369 gfc_actual_arglist *a;
5370 a = actual;
5371 strip_kind_from_actual (a);
5372 while (a)
5373 {
5374 if (a->name && strcmp (a->name, "dim") == 0)
5375 {
5376 gfc_free_expr (a->expr);
5377 a->expr = NULL__null;
5378 }
5379 a = a->next;
5380 }
5381 gfc_conv_intrinsic_funcall (se, expr);
5382 return;
5383 }
5384
5385 /* Initialize the result. */
5386 pos = gfc_create_var (gfc_array_index_type, "pos");
5387 offset = gfc_create_var (gfc_array_index_type, "offset");
5388 type = gfc_typenode_for_spec (&expr->ts);
5389
5390 /* Walk the arguments. */
5391 arrayss = gfc_walk_expr (arrayexpr);
5392 gcc_assert (arrayss != gfc_ss_terminator)((void)(!(arrayss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5392, __FUNCTION__), 0 : 0))
;
5393
5394 actual = actual->next->next;
5395 gcc_assert (actual)((void)(!(actual) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5395, __FUNCTION__), 0 : 0))
;
5396 maskexpr = actual->expr;
5397 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5398 && maskexpr->symtree->n.sym->attr.dummy
5399 && maskexpr->symtree->n.sym->attr.optional;
5400 backexpr = actual->next->next->expr;
5401 nonempty = NULL__null;
5402 if (maskexpr && maskexpr->rank != 0)
5403 {
5404 maskss = gfc_walk_expr (maskexpr);
5405 gcc_assert (maskss != gfc_ss_terminator)((void)(!(maskss != gfc_ss_terminator) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5405, __FUNCTION__), 0 : 0))
;
5406 }
5407 else
5408 {
5409 mpz_t asize;
5410 if (gfc_array_size (arrayexpr, &asize))
5411 {
5412 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5413 mpz_clear__gmpz_clear (asize);
5414 nonempty = fold_build2_loc (input_location, GT_EXPR,
5415 logical_type_node, nonempty,
5416 gfc_index_zero_nodegfc_rank_cst[0]);
5417 }
5418 maskss = NULL__null;
5419 }
5420
5421 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5422 switch (arrayexpr->ts.type)
5423 {
5424 case BT_REAL:
5425 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit)((contains_struct_check ((limit), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5425, __FUNCTION__))->typed.type)
, arrayexpr->ts.kind);
5426 break;
5427
5428 case BT_INTEGER:
5429 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5430 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5431 arrayexpr->ts.kind);
5432 break;
5433
5434 default:
5435 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5435, __FUNCTION__))
;
5436 }
5437
5438 /* We start with the most negative possible value for MAXLOC, and the most
5439 positive possible value for MINLOC. The most negative possible value is
5440 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5441 possible value is HUGE in both cases. */
5442 if (op == GT_EXPR)
5443 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5443, __FUNCTION__))->typed.type)
, tmp);
5444 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5445 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp)((contains_struct_check ((tmp), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5445, __FUNCTION__))->typed.type)
, tmp,
5446 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-intrinsic.c"
, 5446, __FUNCTION__))->typed.type)
, 1));
5447
5448 gfc_add_modify (&se->pre, limit, tmp);
5449
5450 /* Initialize the scalarizer. */
5451 gfc_init_loopinfo (&loop);
5452
5453 /* We add the mask first because the number of iterations is taken
5454 from the last ss, and this breaks if an absent optional argument
5455 is used for mask. */
5456
5457 if (maskss)
5458 gfc_add_ss_to_loop (&loop, maskss);
5459
5460 gfc_add_ss_to_loop (&loop, arrayss);
5461
5462 /* Initialize the loop. */
5463 gfc_conv_ss_startstride (&loop);
5464
5465 /* The code generated can have more than one loop in sequence (see the
5466 comment at the function header). This doesn't work well with the
5467 scalarizer, which changes arrays' offset when the scalarization loops
5468 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5469 are currently inlined in the scalar case only (for which loop is of rank
5470 one). As there is no dependency to care about in that case, there is no
5471 temporary, so that we can use the scalarizer temporary code to handle
5472 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5473 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5474 to restore offset.
5475 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5476 should eventually go away. We could either create two loops properly,
5477 or find another way to save/restore the array offsets between the two
5478 loops (without conflicting with temporary management), or use a single
5479 loop minmaxloc implementation. See PR 31067. */
5480 loop.temp_dim = loop.dimen;
5481 gfc_conv_loop_setup (&loop, &expr->where);
5482
5483 gcc_assert (loop.dimen == 1)((void)(!(loop.dimen == 1) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5483, __FUNCTION__), 0 : 0))
;
5484 if (nonempty == NULL__null && maskss == NULL__null && loop.from[0] && loop.to[0])
5485 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5486 loop.from[0], loop.to[0]);
5487
5488 lab1 = NULL__null;
5489 lab2 = NULL__null;
5490 /* Initialize the position to zero, following Fortran 2003. We are free
5491 to do this because Fortran 95 allows the result of an entirely false
5492 mask to be processor dependent. If we know at compile time the array
5493 is non-empty and no MASK is used, we can initialize to 1 to simplify
5494 the inner loop. */
5495 if (nonempty != NULL__null && !HONOR_NANS (DECL_MODE (limit)((contains_struct_check ((limit), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5495, __FUNCTION__))->decl_common.mode)
))
5496 gfc_add_modify (&loop.pre, pos,
5497 fold_build3_loc (input_location, COND_EXPR,
5498 gfc_array_index_type,
5499 nonempty, gfc_index_one_nodegfc_rank_cst[1],
5500 gfc_index_zero_nodegfc_rank_cst[0]));
5501 else
5502 {
5503 gfc_add_modify (&loop.pre, pos, gfc_index_zero_nodegfc_rank_cst[0]);
5504 lab1 = gfc_build_label_decl (NULL_TREE(tree) __null);
5505 TREE_USED (lab1)((lab1)->base.used_flag) = 1;
5506 lab2 = gfc_build_label_decl (NULL_TREE(tree) __null);
5507 TREE_USED (lab2)((lab2)->base.used_flag) = 1;
5508 }
5509
5510 /* An offset must be added to the loop
5511 counter to obtain the required position. */
5512 gcc_assert (loop.from[0])((void)(!(loop.from[0]) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5512, __FUNCTION__), 0 : 0))
;
5513
5514 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5515 gfc_index_one_nodegfc_rank_cst[1], loop.from[0]);
5516 gfc_add_modify (&loop.pre, offset, tmp);
5517
5518 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5519 if (maskss)
5520 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5521 /* Generate the loop body. */
5522 gfc_start_scalarized_body (&loop, &body);
5523
5524 /* If we have a mask, only check this element if the mask is set. */
5525 if (maskss)
5526 {
5527 gfc_init_se (&maskse, NULL__null);
5528 gfc_copy_loopinfo_to_se (&maskse, &loop);
5529 maskse.ss = maskss;
5530 gfc_conv_expr_val (&maskse, maskexpr);
5531 gfc_add_block_to_block (&body, &maskse.pre);
5532
5533 gfc_start_block (&block);
5534 }
5535 else
5536 gfc_init_block (&block);
5537
5538 /* Compare with the current limit. */
5539 gfc_init_se (&arrayse, NULL__null);
5540 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5541 arrayse.ss = arrayss;
5542 gfc_conv_expr_val (&arrayse, arrayexpr);
5543 gfc_add_block_to_block (&block, &arrayse.pre);
5544
5545 gfc_init_se (&backse, NULL__null);
5546 gfc_conv_expr_val (&backse, backexpr);
5547 gfc_add_block_to_block (&block, &backse.pre);
5548
5549 /* We do the following if this is a more extreme value. */
5550 gfc_start_block (&ifblock);
5551
5552 /* Assign the value to the limit... */
5553 gfc_add_modify (&ifblock, limit, arrayse.expr);
5554
5555 if (nonempty == NULL__null && HONOR_NANS (DECL_MODE (limit)((contains_struct_check ((limit), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5555, __FUNCTION__))->decl_common.mode)
))
5556 {
5557 stmtblock_t ifblock2;
5558 tree ifbody2;
5559
5560 gfc_start_block (&ifblock2);
5561 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos)((contains_struct_check ((pos), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5561, __FUNCTION__))->typed.type)
,
5562 loop.loopvar[0], offset);
5563 gfc_add_modify (&ifblock2, pos, tmp);
5564 ifbody2 = gfc_finish_block (&ifblock2);
5565 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
5566 gfc_index_zero_nodegfc_rank_cst[0]);
5567 tmp = build3_v (COND_EXPR, cond, ifbody2,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody2, build_empty_stmt (input_location))
5568 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody2, build_empty_stmt (input_location))
;
5569 gfc_add_expr_to_block (&block, tmp);
5570 }
5571
5572 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos)((contains_struct_check ((pos), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5572, __FUNCTION__))->typed.type)
,
5573 loop.loopvar[0], offset);
5574 gfc_add_modify (&ifblock, pos, tmp);
5575
5576 if (lab1)
5577 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], lab1)
);
5578
5579 ifbody = gfc_finish_block (&ifblock);
5580
5581 if (!lab1 || HONOR_NANS (DECL_MODE (limit)((contains_struct_check ((limit), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5581, __FUNCTION__))->decl_common.mode)
))
5582 {
5583 if (lab1)
5584 cond = fold_build2_loc (input_location,
5585 op == GT_EXPR ? GE_EXPR : LE_EXPR,
5586 logical_type_node, arrayse.expr, limit);
5587 else
5588 {
5589 tree ifbody2, elsebody2;
5590
5591 /* We switch to > or >= depending on the value of the BACK argument. */
5592 cond = gfc_create_var (logical_type_node, "cond");
5593
5594 gfc_start_block (&ifblock);
5595 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5596 logical_type_node, arrayse.expr, limit);
5597
5598 gfc_add_modify (&ifblock, cond, b_if);
5599 ifbody2 = gfc_finish_block (&ifblock);
5600
5601 gfc_start_block (&elseblock);
5602 b_else = fold_build2_loc (input_location, op, logical_type_node,
5603 arrayse.expr, limit);
5604
5605 gfc_add_modify (&elseblock, cond, b_else);
5606 elsebody2 = gfc_finish_block (&elseblock);
5607
5608 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5609 backse.expr, ifbody2, elsebody2);
5610
5611 gfc_add_expr_to_block (&block, tmp);
5612 }
5613
5614 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5615 ifbody = build3_v (COND_EXPR, cond, ifbody,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody, build_empty_stmt (input_location))
5616 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody, build_empty_stmt (input_location))
;
5617 }
5618 gfc_add_expr_to_block (&block, ifbody);
5619
5620 if (maskss)
5621 {
5622 /* We enclose the above in if (mask) {...}. If the mask is an
5623 optional argument, generate IF (.NOT. PRESENT(MASK)
5624 .OR. MASK(I)). */
5625
5626 tree ifmask;
5627 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5628 tmp = gfc_finish_block (&block);
5629 tmp = build3_v (COND_EXPR, ifmask, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
5630 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
;
5631 }
5632 else
5633 tmp = gfc_finish_block (&block);
5634 gfc_add_expr_to_block (&body, tmp);
5635
5636 if (lab1)
5637 {
5638 gfc_trans_scalarized_loop_boundary (&loop, &body);
5639
5640 if (HONOR_NANS (DECL_MODE (limit)((contains_struct_check ((limit), (TS_DECL_COMMON), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5640, __FUNCTION__))->decl_common.mode)
))
5641 {
5642 if (nonempty != NULL__null)
5643 {
5644 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node)fold_build2_loc (input_location, MODIFY_EXPR, global_trees[TI_VOID_TYPE
], pos, gfc_rank_cst[1])
;
5645 tmp = build3_v (COND_EXPR, nonempty, ifbody,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], nonempty, ifbody, build_empty_stmt (input_location))
5646 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], nonempty, ifbody, build_empty_stmt (input_location))
;
5647 gfc_add_expr_to_block (&loop.code[0], tmp);
5648 }
5649 }
5650
5651 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)fold_build1_loc (input_location, GOTO_EXPR, global_trees[TI_VOID_TYPE
], lab2)
);
5652 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], lab1)
);
5653
5654 /* If we have a mask, only check this element if the mask is set. */
5655 if (maskss)
5656 {
5657 gfc_init_se (&maskse, NULL__null);
5658 gfc_copy_loopinfo_to_se (&maskse, &loop);
5659 maskse.ss = maskss;
5660 gfc_conv_expr_val (&maskse, maskexpr);
5661 gfc_add_block_to_block (&body, &maskse.pre);
5662
5663 gfc_start_block (&block);
5664 }
5665 else
5666 gfc_init_block (&block);
5667
5668 /* Compare with the current limit. */
5669 gfc_init_se (&arrayse, NULL__null);
5670 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5671 arrayse.ss = arrayss;
5672 gfc_conv_expr_val (&arrayse, arrayexpr);
5673 gfc_add_block_to_block (&block, &arrayse.pre);
5674
5675 /* We do the following if this is a more extreme value. */
5676 gfc_start_block (&ifblock);
5677
5678 /* Assign the value to the limit... */
5679 gfc_add_modify (&ifblock, limit, arrayse.expr);
5680
5681 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos)((contains_struct_check ((pos), (TS_TYPED), "/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/trans-intrinsic.c"
, 5681, __FUNCTION__))->typed.type)
,
5682 loop.loopvar[0], offset);
5683 gfc_add_modify (&ifblock, pos, tmp);
5684
5685 ifbody = gfc_finish_block (&ifblock);
5686
5687 /* We switch to > or >= depending on the value of the BACK argument. */
5688 {
5689 tree ifbody2, elsebody2;
5690
5691 cond = gfc_create_var (logical_type_node, "cond");
5692
5693 gfc_start_block (&ifblock);
5694 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5695 logical_type_node, arrayse.expr, limit);
5696
5697 gfc_add_modify (&ifblock, cond, b_if);
5698 ifbody2 = gfc_finish_block (&ifblock);
5699
5700 gfc_start_block (&elseblock);
5701 b_else = fold_build2_loc (input_location, op, logical_type_node,
5702 arrayse.expr, limit);
5703
5704 gfc_add_modify (&elseblock, cond, b_else);
5705 elsebody2 = gfc_finish_block (&elseblock);
5706
5707 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5708 backse.expr, ifbody2, elsebody2);
5709 }
5710
5711 gfc_add_expr_to_block (&block, tmp);
5712 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5713 tmp = build3_v (COND_EXPR, cond, ifbody,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody, build_empty_stmt (input_location))
5714 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], cond, ifbody, build_empty_stmt (input_location))
;
5715
5716 gfc_add_expr_to_block (&block, tmp);
5717
5718 if (maskss)
5719 {
5720 /* We enclose the above in if (mask) {...}. If the mask is
5721 an optional argument, generate IF (.NOT. PRESENT(MASK)
5722 .OR. MASK(I)).*/
5723
5724 tree ifmask;
5725 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5726 tmp = gfc_finish_block (&block);
5727 tmp = build3_v (COND_EXPR, ifmask, tmp,fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
5728 build_empty_stmt (input_location))fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, build_empty_stmt (input_location))
;
5729 }
5730 else
5731 tmp = gfc_finish_block (&block);
5732 gfc_add_expr_to_block (&body, tmp);
5733 /* Avoid initializing loopvar[0] again, it should be left where
5734 it finished by the first loop. */
5735 loop.from[0] = loop.loopvar[0];
5736 }
5737
5738 gfc_trans_scalarizing_loops (&loop, &body);
5739
5740 if (lab2)
5741 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)fold_build1_loc (input_location, LABEL_EXPR, global_trees[TI_VOID_TYPE
], lab2)
);
5742
5743 /* For a scalar mask, enclose the loop in an if statement. */
5744 if (maskexpr && maskss == NULL__null)
5745 {
5746 tree ifmask;
5747
5748 gfc_init_se (&maskse, NULL__null);
5749 gfc_conv_expr_val (&maskse, maskexpr);
5750 gfc_init_block (&block);
5751 gfc_add_block_to_block (&block, &loop.pre);
5752 gfc_add_block_to_block (&block, &loop.post);
5753 tmp = gfc_finish_block (&block);
5754
5755 /* For the else part of the scalar mask, just initialize
5756 the pos variable the same way as above. */
5757
5758 gfc_init_block (&elseblock);
5759 gfc_add_modify (&elseblock, pos, gfc_index_zero_nodegfc_rank_cst[0]);
5760 elsetmp = gfc_finish_block (&elseblock);
5761 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5762 tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp)fold_build3_loc (input_location, COND_EXPR, global_trees[TI_VOID_TYPE
], ifmask, tmp, elsetmp)
;
5763 gfc_add_expr_to_block (&block, tmp);
5764 gfc_add_block_to_block (&se->pre, &block);
5765 }
5766 else
5767 {
5768 gfc_add_block_to_block (&se->pre, &loop.pre);
5769 gfc_add_block_to_block (&se->pre, &loop.post);
5770 }
5771 gfc_cleanup_loop (&loop);
5772
5773 se->expr = convert (type, pos);
5774}
5775
5776/* Emit code for findloc. */
5777
5778static void
5779gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5780{
5781 gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5782 *kind_arg, *back_arg;
5783 gfc_expr *value_expr;
5784 int ikind;
5785 tree resvar;
5786 stmtblock_t block;
5787 stmtblock_t body;
5788 stmtblock_t loopblock;
5789 tree type;
5790 tree tmp;
5791 tree found;
5792 tree forward_branch = NULL_TREE(tree) __null;
5793 tree back_branch;
5794 gfc_loopinfo loop;
5795 gfc_ss *arrayss;
5796 gfc_ss *maskss;
5797 gfc_se arrayse;
5798 gfc_se valuese;
5799 gfc_se maskse;
5800 gfc_se backse;
5801 tree exit_label;
5802 gfc_expr *maskexpr;
5803 tree offset;
5804 int i;
5805 bool optional_mask;
5806
5807 array_arg = expr->value.function.actual;
5808 value_arg = array_arg->next;
5809 dim_arg = value_arg->next;
5810 mask_arg = dim_arg->next;
5811 kind_arg = mask_arg->next;
5812 back_arg = kind_arg->next;
5813
5814 /* Remove kind and set ikind. */
5815