Bug Summary

File:build/gcc/fortran/trans-intrinsic.c
Warning:line 7371, column 6
Value stored to 'decl' is never read

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