Branch data Line data Source code
1 : : /* Intrinsic translation
2 : : Copyright (C) 2002-2025 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook <paul@nowt.org>
4 : : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 : :
6 : : This file is part of GCC.
7 : :
8 : : GCC is free software; you can redistribute it and/or modify it under
9 : : the terms of the GNU General Public License as published by the Free
10 : : Software Foundation; either version 3, or (at your option) any later
11 : : version.
12 : :
13 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : : for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GCC; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : /* trans-intrinsic.cc-- 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 : : #include "realmpfr.h"
45 : : #include "constructor.h"
46 : :
47 : : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
48 : :
49 : : /* This maps Fortran intrinsic math functions to external library or GCC
50 : : builtin functions. */
51 : : typedef struct GTY(()) gfc_intrinsic_map_t {
52 : : /* The explicit enum is required to work around inadequacies in the
53 : : garbage collection/gengtype parsing mechanism. */
54 : : enum gfc_isym_id id;
55 : :
56 : : /* Enum value from the "language-independent", aka C-centric, part
57 : : of gcc, or END_BUILTINS of no such value set. */
58 : : enum built_in_function float_built_in;
59 : : enum built_in_function double_built_in;
60 : : enum built_in_function long_double_built_in;
61 : : enum built_in_function complex_float_built_in;
62 : : enum built_in_function complex_double_built_in;
63 : : enum built_in_function complex_long_double_built_in;
64 : :
65 : : /* True if the naming pattern is to prepend "c" for complex and
66 : : append "f" for kind=4. False if the naming pattern is to
67 : : prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68 : : bool libm_name;
69 : :
70 : : /* True if a complex version of the function exists. */
71 : : bool complex_available;
72 : :
73 : : /* True if the function should be marked const. */
74 : : bool is_constant;
75 : :
76 : : /* The base library name of this function. */
77 : : const char *name;
78 : :
79 : : /* Cache decls created for the various operand types. */
80 : : tree real4_decl;
81 : : tree real8_decl;
82 : : tree real10_decl;
83 : : tree real16_decl;
84 : : tree complex4_decl;
85 : : tree complex8_decl;
86 : : tree complex10_decl;
87 : : tree complex16_decl;
88 : : }
89 : : gfc_intrinsic_map_t;
90 : :
91 : : /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 : : defines complex variants of all of the entries in mathbuiltins.def
93 : : except for atan2. */
94 : : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 : : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 : : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
97 : : true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 : : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 : :
100 : : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 : : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 : : BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
103 : : BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
104 : : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 : :
106 : : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 : : { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 : : END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 : : false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 : : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 : :
112 : : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
113 : : { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
114 : : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 : : true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
116 : : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 : :
118 : : static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
119 : : {
120 : : /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
121 : : DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
122 : : to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
123 : : #include "mathbuiltins.def"
124 : :
125 : : /* Functions in libgfortran. */
126 : : LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
127 : : LIB_FUNCTION (SIND, "sind", false),
128 : : LIB_FUNCTION (COSD, "cosd", false),
129 : : LIB_FUNCTION (TAND, "tand", false),
130 : :
131 : : /* End the list. */
132 : : LIB_FUNCTION (NONE, NULL, false)
133 : :
134 : : };
135 : : #undef OTHER_BUILTIN
136 : : #undef LIB_FUNCTION
137 : : #undef DEFINE_MATH_BUILTIN
138 : : #undef DEFINE_MATH_BUILTIN_C
139 : :
140 : :
141 : : enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
142 : :
143 : :
144 : : /* Find the correct variant of a given builtin from its argument. */
145 : : static tree
146 : 11425 : builtin_decl_for_precision (enum built_in_function base_built_in,
147 : : int precision)
148 : : {
149 : 11425 : enum built_in_function i = END_BUILTINS;
150 : :
151 : 11425 : gfc_intrinsic_map_t *m;
152 : 489497 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
153 : : ;
154 : :
155 : 11425 : if (precision == TYPE_PRECISION (float_type_node))
156 : 5801 : i = m->float_built_in;
157 : 5624 : else if (precision == TYPE_PRECISION (double_type_node))
158 : : i = m->double_built_in;
159 : 1695 : else if (precision == TYPE_PRECISION (long_double_type_node)
160 : 1695 : && (!gfc_real16_is_float128
161 : 1571 : || long_double_type_node != gfc_float128_type_node))
162 : 1571 : i = m->long_double_built_in;
163 : 124 : else if (precision == TYPE_PRECISION (gfc_float128_type_node))
164 : : {
165 : : /* Special treatment, because it is not exactly a built-in, but
166 : : a library function. */
167 : 124 : return m->real16_decl;
168 : : }
169 : :
170 : 11301 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
171 : : }
172 : :
173 : :
174 : : tree
175 : 10386 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
176 : : int kind)
177 : : {
178 : 10386 : int i = gfc_validate_kind (BT_REAL, kind, false);
179 : :
180 : 10386 : if (gfc_real_kinds[i].c_float128)
181 : : {
182 : : /* For _Float128, the story is a bit different, because we return
183 : : a decl to a library function rather than a built-in. */
184 : : gfc_intrinsic_map_t *m;
185 : 36328 : for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
186 : : ;
187 : :
188 : 905 : return m->real16_decl;
189 : : }
190 : :
191 : 9481 : return builtin_decl_for_precision (double_built_in,
192 : 9481 : gfc_real_kinds[i].mode_precision);
193 : : }
194 : :
195 : :
196 : : /* Evaluate the arguments to an intrinsic function. The value
197 : : of NARGS may be less than the actual number of arguments in EXPR
198 : : to allow optional "KIND" arguments that are not included in the
199 : : generated code to be ignored. */
200 : :
201 : : static void
202 : 78739 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
203 : : tree *argarray, int nargs)
204 : : {
205 : 78739 : gfc_actual_arglist *actual;
206 : 78739 : gfc_expr *e;
207 : 78739 : gfc_intrinsic_arg *formal;
208 : 78739 : gfc_se argse;
209 : 78739 : int curr_arg;
210 : :
211 : 78739 : formal = expr->value.function.isym->formal;
212 : 78739 : actual = expr->value.function.actual;
213 : :
214 : 177552 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
215 : 61784 : actual = actual->next,
216 : 98813 : formal = formal ? formal->next : NULL)
217 : : {
218 : 98813 : gcc_assert (actual);
219 : 98813 : e = actual->expr;
220 : : /* Skip omitted optional arguments. */
221 : 98813 : if (!e)
222 : : {
223 : 31 : --curr_arg;
224 : 31 : continue;
225 : : }
226 : :
227 : : /* Evaluate the parameter. This will substitute scalarized
228 : : references automatically. */
229 : 98782 : gfc_init_se (&argse, se);
230 : :
231 : 98782 : if (e->ts.type == BT_CHARACTER)
232 : : {
233 : 9571 : gfc_conv_expr (&argse, e);
234 : 9571 : gfc_conv_string_parameter (&argse);
235 : 9571 : argarray[curr_arg++] = argse.string_length;
236 : 9571 : gcc_assert (curr_arg < nargs);
237 : : }
238 : : else
239 : 89211 : gfc_conv_expr_val (&argse, e);
240 : :
241 : : /* If an optional argument is itself an optional dummy argument,
242 : : check its presence and substitute a null if absent. */
243 : 98782 : if (e->expr_type == EXPR_VARIABLE
244 : 51451 : && e->symtree->n.sym->attr.optional
245 : 203 : && formal
246 : 153 : && formal->optional)
247 : 80 : gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
248 : :
249 : 98782 : gfc_add_block_to_block (&se->pre, &argse.pre);
250 : 98782 : gfc_add_block_to_block (&se->post, &argse.post);
251 : 98782 : argarray[curr_arg] = argse.expr;
252 : : }
253 : 78739 : }
254 : :
255 : : /* Count the number of actual arguments to the intrinsic function EXPR
256 : : including any "hidden" string length arguments. */
257 : :
258 : : static unsigned int
259 : 54398 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
260 : : {
261 : 54398 : int n = 0;
262 : 54398 : gfc_actual_arglist *actual;
263 : :
264 : 123916 : for (actual = expr->value.function.actual; actual; actual = actual->next)
265 : : {
266 : 69518 : if (!actual->expr)
267 : 6319 : continue;
268 : :
269 : 63199 : if (actual->expr->ts.type == BT_CHARACTER)
270 : 4505 : n += 2;
271 : : else
272 : 58694 : n++;
273 : : }
274 : :
275 : 54398 : return n;
276 : : }
277 : :
278 : :
279 : : /* Conversions between different types are output by the frontend as
280 : : intrinsic functions. We implement these directly with inline code. */
281 : :
282 : : static void
283 : 38401 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
284 : : {
285 : 38401 : tree type;
286 : 38401 : tree *args;
287 : 38401 : int nargs;
288 : :
289 : 38401 : nargs = gfc_intrinsic_argument_list_length (expr);
290 : 38401 : args = XALLOCAVEC (tree, nargs);
291 : :
292 : : /* Evaluate all the arguments passed. Whilst we're only interested in the
293 : : first one here, there are other parts of the front-end that assume this
294 : : and will trigger an ICE if it's not the case. */
295 : 38401 : type = gfc_typenode_for_spec (&expr->ts);
296 : 38401 : gcc_assert (expr->value.function.actual->expr);
297 : 38401 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
298 : :
299 : : /* Conversion between character kinds involves a call to a library
300 : : function. */
301 : 38401 : if (expr->ts.type == BT_CHARACTER)
302 : : {
303 : 208 : tree fndecl, var, addr, tmp;
304 : :
305 : 208 : if (expr->ts.kind == 1
306 : 77 : && expr->value.function.actual->expr->ts.kind == 4)
307 : 77 : fndecl = gfor_fndecl_convert_char4_to_char1;
308 : 131 : else if (expr->ts.kind == 4
309 : 131 : && expr->value.function.actual->expr->ts.kind == 1)
310 : 131 : fndecl = gfor_fndecl_convert_char1_to_char4;
311 : : else
312 : 0 : gcc_unreachable ();
313 : :
314 : : /* Create the variable storing the converted value. */
315 : 208 : type = gfc_get_pchar_type (expr->ts.kind);
316 : 208 : var = gfc_create_var (type, "str");
317 : 208 : addr = gfc_build_addr_expr (build_pointer_type (type), var);
318 : :
319 : : /* Call the library function that will perform the conversion. */
320 : 208 : gcc_assert (nargs >= 2);
321 : 208 : tmp = build_call_expr_loc (input_location,
322 : : fndecl, 3, addr, args[0], args[1]);
323 : 208 : gfc_add_expr_to_block (&se->pre, tmp);
324 : :
325 : : /* Free the temporary afterwards. */
326 : 208 : tmp = gfc_call_free (var);
327 : 208 : gfc_add_expr_to_block (&se->post, tmp);
328 : :
329 : 208 : se->expr = var;
330 : 208 : se->string_length = args[0];
331 : :
332 : 208 : return;
333 : : }
334 : :
335 : : /* Conversion from complex to non-complex involves taking the real
336 : : component of the value. */
337 : 38193 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
338 : 38193 : && expr->ts.type != BT_COMPLEX)
339 : : {
340 : 577 : tree artype;
341 : :
342 : 577 : artype = TREE_TYPE (TREE_TYPE (args[0]));
343 : 577 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
344 : : args[0]);
345 : : }
346 : :
347 : 38193 : se->expr = convert (type, args[0]);
348 : : }
349 : :
350 : : /* This is needed because the gcc backend only implements
351 : : FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
352 : : FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
353 : : Similarly for CEILING. */
354 : :
355 : : static tree
356 : 132 : build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
357 : : {
358 : 132 : tree tmp;
359 : 132 : tree cond;
360 : 132 : tree argtype;
361 : 132 : tree intval;
362 : :
363 : 132 : argtype = TREE_TYPE (arg);
364 : 132 : arg = gfc_evaluate_now (arg, pblock);
365 : :
366 : 132 : intval = convert (type, arg);
367 : 132 : intval = gfc_evaluate_now (intval, pblock);
368 : :
369 : 132 : tmp = convert (argtype, intval);
370 : 248 : cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
371 : : logical_type_node, tmp, arg);
372 : :
373 : 248 : tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
374 : : intval, build_int_cst (type, 1));
375 : 132 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
376 : 132 : return tmp;
377 : : }
378 : :
379 : :
380 : : /* Round to nearest integer, away from zero. */
381 : :
382 : : static tree
383 : 516 : build_round_expr (tree arg, tree restype)
384 : : {
385 : 516 : tree argtype;
386 : 516 : tree fn;
387 : 516 : int argprec, resprec;
388 : :
389 : 516 : argtype = TREE_TYPE (arg);
390 : 516 : argprec = TYPE_PRECISION (argtype);
391 : 516 : resprec = TYPE_PRECISION (restype);
392 : :
393 : : /* Depending on the type of the result, choose the int intrinsic (iround,
394 : : available only as a builtin, therefore cannot use it for _Float128), long
395 : : int intrinsic (lround family) or long long intrinsic (llround). If we
396 : : don't have an appropriate function that converts directly to the integer
397 : : type (such as kind == 16), just use ROUND, and then convert the result to
398 : : an integer. We might also need to convert the result afterwards. */
399 : 516 : if (resprec <= INT_TYPE_SIZE
400 : 516 : && argprec <= TYPE_PRECISION (long_double_type_node))
401 : 458 : fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
402 : 62 : else if (resprec <= LONG_TYPE_SIZE)
403 : 46 : fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
404 : 12 : else if (resprec <= LONG_LONG_TYPE_SIZE)
405 : 0 : fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
406 : 12 : else if (resprec >= argprec)
407 : 12 : fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
408 : : else
409 : 0 : gcc_unreachable ();
410 : :
411 : 516 : return convert (restype, build_call_expr_loc (input_location,
412 : 516 : fn, 1, arg));
413 : : }
414 : :
415 : :
416 : : /* Convert a real to an integer using a specific rounding mode.
417 : : Ideally we would just build the corresponding GENERIC node,
418 : : however the RTL expander only actually supports FIX_TRUNC_EXPR. */
419 : :
420 : : static tree
421 : 1566 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
422 : : enum rounding_mode op)
423 : : {
424 : 1566 : switch (op)
425 : : {
426 : 116 : case RND_FLOOR:
427 : 116 : return build_fixbound_expr (pblock, arg, type, 0);
428 : :
429 : 16 : case RND_CEIL:
430 : 16 : return build_fixbound_expr (pblock, arg, type, 1);
431 : :
432 : 162 : case RND_ROUND:
433 : 162 : return build_round_expr (arg, type);
434 : :
435 : 1272 : case RND_TRUNC:
436 : 1272 : return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
437 : :
438 : 0 : default:
439 : 0 : gcc_unreachable ();
440 : : }
441 : : }
442 : :
443 : :
444 : : /* Round a real value using the specified rounding mode.
445 : : We use a temporary integer of that same kind size as the result.
446 : : Values larger than those that can be represented by this kind are
447 : : unchanged, as they will not be accurate enough to represent the
448 : : rounding.
449 : : huge = HUGE (KIND (a))
450 : : aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
451 : : */
452 : :
453 : : static void
454 : 220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
455 : : {
456 : 220 : tree type;
457 : 220 : tree itype;
458 : 220 : tree arg[2];
459 : 220 : tree tmp;
460 : 220 : tree cond;
461 : 220 : tree decl;
462 : 220 : mpfr_t huge;
463 : 220 : int n, nargs;
464 : 220 : int kind;
465 : :
466 : 220 : kind = expr->ts.kind;
467 : 220 : nargs = gfc_intrinsic_argument_list_length (expr);
468 : :
469 : 220 : decl = NULL_TREE;
470 : : /* We have builtin functions for some cases. */
471 : 220 : switch (op)
472 : : {
473 : 74 : case RND_ROUND:
474 : 74 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
475 : 74 : break;
476 : :
477 : 146 : case RND_TRUNC:
478 : 146 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 : 146 : break;
480 : :
481 : 0 : default:
482 : 0 : gcc_unreachable ();
483 : : }
484 : :
485 : : /* Evaluate the argument. */
486 : 220 : gcc_assert (expr->value.function.actual->expr);
487 : 220 : gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
488 : :
489 : : /* Use a builtin function if one exists. */
490 : 220 : if (decl != NULL_TREE)
491 : : {
492 : 220 : se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
493 : 220 : return;
494 : : }
495 : :
496 : : /* This code is probably redundant, but we'll keep it lying around just
497 : : in case. */
498 : 0 : type = gfc_typenode_for_spec (&expr->ts);
499 : 0 : arg[0] = gfc_evaluate_now (arg[0], &se->pre);
500 : :
501 : : /* Test if the value is too large to handle sensibly. */
502 : 0 : gfc_set_model_kind (kind);
503 : 0 : mpfr_init (huge);
504 : 0 : n = gfc_validate_kind (BT_INTEGER, kind, false);
505 : 0 : mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
506 : 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
507 : 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
508 : : tmp);
509 : :
510 : 0 : mpfr_neg (huge, huge, GFC_RND_MODE);
511 : 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
512 : 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
513 : : tmp);
514 : 0 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
515 : : cond, tmp);
516 : 0 : itype = gfc_get_int_type (kind);
517 : :
518 : 0 : tmp = build_fix_expr (&se->pre, arg[0], itype, op);
519 : 0 : tmp = convert (type, tmp);
520 : 0 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
521 : : arg[0]);
522 : 0 : mpfr_clear (huge);
523 : : }
524 : :
525 : :
526 : : /* Convert to an integer using the specified rounding mode. */
527 : :
528 : : static void
529 : 3093 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530 : : {
531 : 3093 : tree type;
532 : 3093 : tree *args;
533 : 3093 : int nargs;
534 : :
535 : 3093 : nargs = gfc_intrinsic_argument_list_length (expr);
536 : 3093 : args = XALLOCAVEC (tree, nargs);
537 : :
538 : : /* Evaluate the argument, we process all arguments even though we only
539 : : use the first one for code generation purposes. */
540 : 3093 : type = gfc_typenode_for_spec (&expr->ts);
541 : 3093 : gcc_assert (expr->value.function.actual->expr);
542 : 3093 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
543 : :
544 : 3093 : if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
545 : : {
546 : : /* Conversion to a different integer kind. */
547 : 1527 : se->expr = convert (type, args[0]);
548 : : }
549 : : else
550 : : {
551 : : /* Conversion from complex to non-complex involves taking the real
552 : : component of the value. */
553 : 1566 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
554 : 1566 : && expr->ts.type != BT_COMPLEX)
555 : : {
556 : 192 : tree artype;
557 : :
558 : 192 : artype = TREE_TYPE (TREE_TYPE (args[0]));
559 : 192 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
560 : : args[0]);
561 : : }
562 : :
563 : 1566 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
564 : : }
565 : 3093 : }
566 : :
567 : :
568 : : /* Get the imaginary component of a value. */
569 : :
570 : : static void
571 : 428 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
572 : : {
573 : 428 : tree arg;
574 : :
575 : 428 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
576 : 428 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
577 : 428 : TREE_TYPE (TREE_TYPE (arg)), arg);
578 : 428 : }
579 : :
580 : :
581 : : /* Get the complex conjugate of a value. */
582 : :
583 : : static void
584 : 257 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
585 : : {
586 : 257 : tree arg;
587 : :
588 : 257 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
589 : 257 : se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
590 : 257 : }
591 : :
592 : :
593 : :
594 : : static tree
595 : 649467 : define_quad_builtin (const char *name, tree type, bool is_const)
596 : : {
597 : 649467 : tree fndecl;
598 : 649467 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
599 : : type);
600 : :
601 : : /* Mark the decl as external. */
602 : 649467 : DECL_EXTERNAL (fndecl) = 1;
603 : 649467 : TREE_PUBLIC (fndecl) = 1;
604 : :
605 : : /* Mark it __attribute__((const)). */
606 : 649467 : TREE_READONLY (fndecl) = is_const;
607 : :
608 : 649467 : rest_of_decl_compilation (fndecl, 1, 0);
609 : :
610 : 649467 : return fndecl;
611 : : }
612 : :
613 : : /* Add SIMD attribute for FNDECL built-in if the built-in
614 : : name is in VECTORIZED_BUILTINS. */
615 : :
616 : : static void
617 : 44340270 : add_simd_flag_for_built_in (tree fndecl)
618 : : {
619 : 44340270 : if (gfc_vectorized_builtins == NULL
620 : 17833930 : || fndecl == NULL_TREE)
621 : 36632385 : return;
622 : :
623 : 7707885 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
624 : 7707885 : int *clauses = gfc_vectorized_builtins->get (name);
625 : 7707885 : if (clauses)
626 : : {
627 : 4835708 : for (unsigned i = 0; i < 3; i++)
628 : 3626781 : if (*clauses & (1 << i))
629 : : {
630 : 1208932 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
631 : 1208932 : tree omp_clause = NULL_TREE;
632 : 1208932 : if (simd_type == SIMD_NONE)
633 : : ; /* No SIMD clause. */
634 : : else
635 : : {
636 : 1208932 : omp_clause_code code
637 : : = (simd_type == SIMD_INBRANCH
638 : 1208932 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
639 : 1208932 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
640 : 1208932 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
641 : : }
642 : :
643 : 1208932 : DECL_ATTRIBUTES (fndecl)
644 : 2417864 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
645 : 1208932 : DECL_ATTRIBUTES (fndecl));
646 : : }
647 : : }
648 : : }
649 : :
650 : : /* Set SIMD attribute to all built-in functions that are mentioned
651 : : in gfc_vectorized_builtins vector. */
652 : :
653 : : void
654 : 75153 : gfc_adjust_builtins (void)
655 : : {
656 : 75153 : gfc_intrinsic_map_t *m;
657 : 4509180 : for (m = gfc_intrinsic_map;
658 : 4509180 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
659 : : {
660 : 4434027 : add_simd_flag_for_built_in (m->real4_decl);
661 : 4434027 : add_simd_flag_for_built_in (m->complex4_decl);
662 : 4434027 : add_simd_flag_for_built_in (m->real8_decl);
663 : 4434027 : add_simd_flag_for_built_in (m->complex8_decl);
664 : 4434027 : add_simd_flag_for_built_in (m->real10_decl);
665 : 4434027 : add_simd_flag_for_built_in (m->complex10_decl);
666 : 4434027 : add_simd_flag_for_built_in (m->real16_decl);
667 : 4434027 : add_simd_flag_for_built_in (m->complex16_decl);
668 : 4434027 : add_simd_flag_for_built_in (m->real16_decl);
669 : 4434027 : add_simd_flag_for_built_in (m->complex16_decl);
670 : : }
671 : :
672 : : /* Release all strings. */
673 : 75153 : if (gfc_vectorized_builtins != NULL)
674 : : {
675 : 1662276 : for (hash_map<nofree_string_hash, int>::iterator it
676 : 30227 : = gfc_vectorized_builtins->begin ();
677 : 1662276 : it != gfc_vectorized_builtins->end (); ++it)
678 : 1632049 : free (CONST_CAST (char *, (*it).first));
679 : :
680 : 60454 : delete gfc_vectorized_builtins;
681 : 30227 : gfc_vectorized_builtins = NULL;
682 : : }
683 : 75153 : }
684 : :
685 : : /* Initialize function decls for library functions. The external functions
686 : : are created as required. Builtin functions are added here. */
687 : :
688 : : void
689 : 30927 : gfc_build_intrinsic_lib_fndecls (void)
690 : : {
691 : 30927 : gfc_intrinsic_map_t *m;
692 : 30927 : tree quad_decls[END_BUILTINS + 1];
693 : :
694 : 30927 : if (gfc_real16_is_float128)
695 : : {
696 : : /* If we have soft-float types, we create the decls for their
697 : : C99-like library functions. For now, we only handle _Float128
698 : : q-suffixed or IEC 60559 f128-suffixed functions. */
699 : :
700 : 30927 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
701 : 30927 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
702 : :
703 : 30927 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
704 : :
705 : 30927 : type = gfc_float128_type_node;
706 : 30927 : complex_type = gfc_complex_float128_type_node;
707 : : /* type (*) (type) */
708 : 30927 : func_1 = build_function_type_list (type, type, NULL_TREE);
709 : : /* int (*) (type) */
710 : 30927 : func_iround = build_function_type_list (integer_type_node,
711 : : type, NULL_TREE);
712 : : /* long (*) (type) */
713 : 30927 : func_lround = build_function_type_list (long_integer_type_node,
714 : : type, NULL_TREE);
715 : : /* long long (*) (type) */
716 : 30927 : func_llround = build_function_type_list (long_long_integer_type_node,
717 : : type, NULL_TREE);
718 : : /* type (*) (type, type) */
719 : 30927 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
720 : : /* type (*) (type, type, type) */
721 : 30927 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
722 : : /* type (*) (type, &int) */
723 : 30927 : func_frexp
724 : 30927 : = build_function_type_list (type,
725 : : type,
726 : : build_pointer_type (integer_type_node),
727 : : NULL_TREE);
728 : : /* type (*) (type, int) */
729 : 30927 : func_scalbn = build_function_type_list (type,
730 : : type, integer_type_node, NULL_TREE);
731 : : /* type (*) (complex type) */
732 : 30927 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
733 : : /* complex type (*) (complex type, complex type) */
734 : 30927 : func_cpow
735 : 30927 : = build_function_type_list (complex_type,
736 : : complex_type, complex_type, NULL_TREE);
737 : :
738 : : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
739 : : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
740 : : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
741 : :
742 : : /* Only these built-ins are actually needed here. These are used directly
743 : : from the code, when calling builtin_decl_for_precision() or
744 : : builtin_decl_for_float_type(). The others are all constructed by
745 : : gfc_get_intrinsic_lib_fndecl(). */
746 : : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
747 : : quad_decls[BUILT_IN_ ## ID] \
748 : : = define_quad_builtin (gfc_real16_use_iec_60559 \
749 : : ? NAME "f128" : NAME "q", func_ ## TYPE, \
750 : : CONST);
751 : :
752 : : #include "mathbuiltins.def"
753 : :
754 : : #undef OTHER_BUILTIN
755 : : #undef LIB_FUNCTION
756 : : #undef DEFINE_MATH_BUILTIN
757 : : #undef DEFINE_MATH_BUILTIN_C
758 : :
759 : : /* There is one built-in we defined manually, because it gets called
760 : : with builtin_decl_for_precision() or builtin_decl_for_float_type()
761 : : even though it is not an OTHER_BUILTIN: it is SQRT. */
762 : 30927 : quad_decls[BUILT_IN_SQRT]
763 : 30927 : = define_quad_builtin (gfc_real16_use_iec_60559
764 : : ? "sqrtf128" : "sqrtq", func_1, true);
765 : : }
766 : :
767 : : /* Add GCC builtin functions. */
768 : 1824693 : for (m = gfc_intrinsic_map;
769 : 1855620 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
770 : : {
771 : 1824693 : if (m->float_built_in != END_BUILTINS)
772 : 1700985 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
773 : 1824693 : if (m->complex_float_built_in != END_BUILTINS)
774 : 494832 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
775 : 1824693 : if (m->double_built_in != END_BUILTINS)
776 : 1700985 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
777 : 1824693 : if (m->complex_double_built_in != END_BUILTINS)
778 : 494832 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
779 : :
780 : : /* If real(kind=10) exists, it is always long double. */
781 : 1824693 : if (m->long_double_built_in != END_BUILTINS)
782 : 1700985 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
783 : 1824693 : if (m->complex_long_double_built_in != END_BUILTINS)
784 : 494832 : m->complex10_decl
785 : 494832 : = builtin_decl_explicit (m->complex_long_double_built_in);
786 : :
787 : 1824693 : if (!gfc_real16_is_float128)
788 : : {
789 : 0 : if (m->long_double_built_in != END_BUILTINS)
790 : 0 : m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
791 : 0 : if (m->complex_long_double_built_in != END_BUILTINS)
792 : 0 : m->complex16_decl
793 : 0 : = builtin_decl_explicit (m->complex_long_double_built_in);
794 : : }
795 : 1824693 : else if (quad_decls[m->double_built_in] != NULL_TREE)
796 : : {
797 : : /* Quad-precision function calls are constructed when first
798 : : needed by builtin_decl_for_precision(), except for those
799 : : that will be used directly (define by OTHER_BUILTIN). */
800 : 649467 : m->real16_decl = quad_decls[m->double_built_in];
801 : : }
802 : 1175226 : else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
803 : : {
804 : : /* Same thing for the complex ones. */
805 : 0 : m->complex16_decl = quad_decls[m->double_built_in];
806 : : }
807 : : }
808 : 30927 : }
809 : :
810 : :
811 : : /* Create a fndecl for a simple intrinsic library function. */
812 : :
813 : : static tree
814 : 4392 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
815 : : {
816 : 4392 : tree type;
817 : 4392 : vec<tree, va_gc> *argtypes;
818 : 4392 : tree fndecl;
819 : 4392 : gfc_actual_arglist *actual;
820 : 4392 : tree *pdecl;
821 : 4392 : gfc_typespec *ts;
822 : 4392 : char name[GFC_MAX_SYMBOL_LEN + 3];
823 : :
824 : 4392 : ts = &expr->ts;
825 : 4392 : if (ts->type == BT_REAL)
826 : : {
827 : 3548 : switch (ts->kind)
828 : : {
829 : 1265 : case 4:
830 : 1265 : pdecl = &m->real4_decl;
831 : 1265 : break;
832 : 1272 : case 8:
833 : 1272 : pdecl = &m->real8_decl;
834 : 1272 : break;
835 : 571 : case 10:
836 : 571 : pdecl = &m->real10_decl;
837 : 571 : break;
838 : 440 : case 16:
839 : 440 : pdecl = &m->real16_decl;
840 : 440 : break;
841 : 0 : default:
842 : 0 : gcc_unreachable ();
843 : : }
844 : : }
845 : 844 : else if (ts->type == BT_COMPLEX)
846 : : {
847 : 844 : gcc_assert (m->complex_available);
848 : :
849 : 844 : switch (ts->kind)
850 : : {
851 : 386 : case 4:
852 : 386 : pdecl = &m->complex4_decl;
853 : 386 : break;
854 : 387 : case 8:
855 : 387 : pdecl = &m->complex8_decl;
856 : 387 : break;
857 : 51 : case 10:
858 : 51 : pdecl = &m->complex10_decl;
859 : 51 : break;
860 : 20 : case 16:
861 : 20 : pdecl = &m->complex16_decl;
862 : 20 : break;
863 : 0 : default:
864 : 0 : gcc_unreachable ();
865 : : }
866 : : }
867 : : else
868 : 0 : gcc_unreachable ();
869 : :
870 : 4392 : if (*pdecl)
871 : 4055 : return *pdecl;
872 : :
873 : 337 : if (m->libm_name)
874 : : {
875 : 160 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
876 : 160 : if (gfc_real_kinds[n].c_float)
877 : 0 : snprintf (name, sizeof (name), "%s%s%s",
878 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
879 : 160 : else if (gfc_real_kinds[n].c_double)
880 : 0 : snprintf (name, sizeof (name), "%s%s",
881 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name);
882 : 160 : else if (gfc_real_kinds[n].c_long_double)
883 : 0 : snprintf (name, sizeof (name), "%s%s%s",
884 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
885 : 160 : else if (gfc_real_kinds[n].c_float128)
886 : 160 : snprintf (name, sizeof (name), "%s%s%s",
887 : 160 : ts->type == BT_COMPLEX ? "c" : "", m->name,
888 : 160 : gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
889 : : else
890 : 0 : gcc_unreachable ();
891 : : }
892 : : else
893 : : {
894 : 354 : snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
895 : 177 : ts->type == BT_COMPLEX ? 'c' : 'r',
896 : : gfc_type_abi_kind (ts));
897 : : }
898 : :
899 : 337 : argtypes = NULL;
900 : 690 : for (actual = expr->value.function.actual; actual; actual = actual->next)
901 : : {
902 : 353 : type = gfc_typenode_for_spec (&actual->expr->ts);
903 : 353 : vec_safe_push (argtypes, type);
904 : : }
905 : 1011 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
906 : 337 : fndecl = build_decl (input_location,
907 : : FUNCTION_DECL, get_identifier (name), type);
908 : :
909 : : /* Mark the decl as external. */
910 : 337 : DECL_EXTERNAL (fndecl) = 1;
911 : 337 : TREE_PUBLIC (fndecl) = 1;
912 : :
913 : : /* Mark it __attribute__((const)), if possible. */
914 : 337 : TREE_READONLY (fndecl) = m->is_constant;
915 : :
916 : 337 : rest_of_decl_compilation (fndecl, 1, 0);
917 : :
918 : 337 : (*pdecl) = fndecl;
919 : 337 : return fndecl;
920 : : }
921 : :
922 : :
923 : : /* Convert an intrinsic function into an external or builtin call. */
924 : :
925 : : static void
926 : 3846 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
927 : : {
928 : 3846 : gfc_intrinsic_map_t *m;
929 : 3846 : tree fndecl;
930 : 3846 : tree rettype;
931 : 3846 : tree *args;
932 : 3846 : unsigned int num_args;
933 : 3846 : gfc_isym_id id;
934 : :
935 : 3846 : id = expr->value.function.isym->id;
936 : : /* Find the entry for this function. */
937 : 79025 : for (m = gfc_intrinsic_map;
938 : 79025 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
939 : : {
940 : 79025 : if (id == m->id)
941 : : break;
942 : : }
943 : :
944 : 3846 : if (m->id == GFC_ISYM_NONE)
945 : : {
946 : 0 : gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
947 : : expr->value.function.name, id);
948 : : }
949 : :
950 : : /* Get the decl and generate the call. */
951 : 3846 : num_args = gfc_intrinsic_argument_list_length (expr);
952 : 3846 : args = XALLOCAVEC (tree, num_args);
953 : :
954 : 3846 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
955 : 3846 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
956 : 3846 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
957 : :
958 : 3846 : fndecl = build_addr (fndecl);
959 : 3846 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
960 : 3846 : }
961 : :
962 : :
963 : : /* If bounds-checking is enabled, create code to verify at runtime that the
964 : : string lengths for both expressions are the same (needed for e.g. MERGE).
965 : : If bounds-checking is not enabled, does nothing. */
966 : :
967 : : void
968 : 1518 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
969 : : tree a, tree b, stmtblock_t* target)
970 : : {
971 : 1518 : tree cond;
972 : 1518 : tree name;
973 : :
974 : : /* If bounds-checking is disabled, do nothing. */
975 : 1518 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
976 : : return;
977 : :
978 : : /* Compare the two string lengths. */
979 : 94 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
980 : :
981 : : /* Output the runtime-check. */
982 : 94 : name = gfc_build_cstring_const (intr_name);
983 : 94 : name = gfc_build_addr_expr (pchar_type_node, name);
984 : 94 : gfc_trans_runtime_check (true, false, cond, target, where,
985 : : "Unequal character lengths (%ld/%ld) in %s",
986 : : fold_convert (long_integer_type_node, a),
987 : : fold_convert (long_integer_type_node, b), name);
988 : : }
989 : :
990 : :
991 : : /* The EXPONENT(X) intrinsic function is translated into
992 : : int ret;
993 : : return isfinite(X) ? (frexp (X, &ret) , ret) : huge
994 : : so that if X is a NaN or infinity, the result is HUGE(0).
995 : : */
996 : :
997 : : static void
998 : 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
999 : : {
1000 : 228 : tree arg, type, res, tmp, frexp, cond, huge;
1001 : 228 : int i;
1002 : :
1003 : 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1004 : 228 : expr->value.function.actual->expr->ts.kind);
1005 : :
1006 : 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1007 : 228 : arg = gfc_evaluate_now (arg, &se->pre);
1008 : :
1009 : 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1010 : 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1011 : 228 : cond = build_call_expr_loc (input_location,
1012 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
1013 : : 1, arg);
1014 : :
1015 : 228 : res = gfc_create_var (integer_type_node, NULL);
1016 : 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1017 : : gfc_build_addr_expr (NULL_TREE, res));
1018 : 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1019 : : tmp, res);
1020 : 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1021 : : cond, tmp, huge);
1022 : :
1023 : 228 : type = gfc_typenode_for_spec (&expr->ts);
1024 : 228 : se->expr = fold_convert (type, se->expr);
1025 : 228 : }
1026 : :
1027 : :
1028 : : static int caf_call_cnt = 0;
1029 : :
1030 : : static tree
1031 : 1162 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1032 : : gfc_expr *hash)
1033 : : {
1034 : 1162 : char *name;
1035 : 1162 : gfc_se argse;
1036 : 1162 : gfc_expr func_index;
1037 : 1162 : gfc_symtree *index_st;
1038 : 1162 : tree func_index_tree;
1039 : 1162 : stmtblock_t blk;
1040 : :
1041 : : /* Need to get namespace where static variables are possible. */
1042 : 1162 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1043 : 0 : ns = ns->parent;
1044 : 1162 : gcc_assert (ns);
1045 : :
1046 : 1162 : name = xasprintf (pat, caf_call_cnt);
1047 : 1162 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1048 : 1162 : free (name);
1049 : :
1050 : 1162 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1051 : 1162 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1052 : 1162 : index_st->n.sym->value
1053 : 1162 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1054 : : &gfc_current_locus);
1055 : 1162 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1056 : 1162 : index_st->n.sym->ts.type = BT_INTEGER;
1057 : 1162 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1058 : 1162 : gfc_set_sym_referenced (index_st->n.sym);
1059 : 1162 : memset (&func_index, 0, sizeof (gfc_expr));
1060 : 1162 : gfc_clear_ts (&func_index.ts);
1061 : 1162 : func_index.expr_type = EXPR_VARIABLE;
1062 : 1162 : func_index.symtree = index_st;
1063 : 1162 : func_index.ts = index_st->n.sym->ts;
1064 : 1162 : gfc_commit_symbol (index_st->n.sym);
1065 : :
1066 : 1162 : gfc_init_se (&argse, NULL);
1067 : 1162 : gfc_conv_expr (&argse, &func_index);
1068 : 1162 : gfc_add_block_to_block (block, &argse.pre);
1069 : 1162 : func_index_tree = argse.expr;
1070 : :
1071 : 1162 : gfc_init_se (&argse, NULL);
1072 : 1162 : gfc_conv_expr (&argse, hash);
1073 : :
1074 : 1162 : gfc_init_block (&blk);
1075 : 1162 : gfc_add_modify (&blk, func_index_tree,
1076 : : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1077 : : argse.expr));
1078 : 1162 : gfc_add_expr_to_block (
1079 : : block,
1080 : : build3 (COND_EXPR, void_type_node,
1081 : : gfc_likely (build2 (EQ_EXPR, logical_type_node, func_index_tree,
1082 : : build_int_cst (integer_type_node, -1)),
1083 : : PRED_FIRST_MATCH),
1084 : : gfc_finish_block (&blk), NULL_TREE));
1085 : :
1086 : 1162 : return func_index_tree;
1087 : : }
1088 : :
1089 : : static tree
1090 : 1162 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1091 : : gfc_symbol *data_sym, tree *data_size)
1092 : : {
1093 : 1162 : char *name;
1094 : 1162 : gfc_symtree *data_st;
1095 : 1162 : gfc_constructor *con;
1096 : 1162 : gfc_expr data, data_init;
1097 : 1162 : gfc_se argse;
1098 : 1162 : tree data_tree;
1099 : :
1100 : 1162 : memset (&data, 0, sizeof (gfc_expr));
1101 : 1162 : gfc_clear_ts (&data.ts);
1102 : 1162 : data.expr_type = EXPR_VARIABLE;
1103 : 1162 : name = xasprintf (pat, caf_call_cnt);
1104 : 1162 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1105 : 1162 : free (name);
1106 : 1162 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1107 : 1162 : data_st->n.sym->ts = data_sym->ts;
1108 : 1162 : data.symtree = data_st;
1109 : 1162 : gfc_set_sym_referenced (data.symtree->n.sym);
1110 : 1162 : data.ts = data_st->n.sym->ts;
1111 : 1162 : gfc_commit_symbol (data_st->n.sym);
1112 : :
1113 : 1162 : memset (&data_init, 0, sizeof (gfc_expr));
1114 : 1162 : gfc_clear_ts (&data_init.ts);
1115 : 1162 : data_init.expr_type = EXPR_STRUCTURE;
1116 : 1162 : data_init.ts = data.ts;
1117 : 1366 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1118 : 204 : comp = comp->next)
1119 : : {
1120 : 204 : con = gfc_constructor_get ();
1121 : 204 : con->expr = comp->initializer;
1122 : 204 : comp->initializer = NULL;
1123 : 204 : gfc_constructor_append (&data_init.value.constructor, con);
1124 : : }
1125 : :
1126 : 1162 : if (data.ts.u.derived->components)
1127 : : {
1128 : 68 : gfc_init_se (&argse, NULL);
1129 : 68 : gfc_conv_expr (&argse, &data);
1130 : 68 : data_tree = argse.expr;
1131 : 68 : gfc_add_expr_to_block (blk,
1132 : : gfc_trans_structure_assign (data_tree, &data_init,
1133 : : true, true));
1134 : 68 : gfc_constructor_free (data_init.value.constructor);
1135 : 68 : *data_size = TREE_TYPE (data_tree)->type_common.size_unit;
1136 : 68 : data_tree = gfc_build_addr_expr (pvoid_type_node, data_tree);
1137 : : }
1138 : : else
1139 : : {
1140 : 1094 : data_tree = build_zero_cst (pvoid_type_node);
1141 : 1094 : *data_size = build_zero_cst (size_type_node);
1142 : : }
1143 : :
1144 : 1162 : return data_tree;
1145 : : }
1146 : :
1147 : : static tree
1148 : 282 : conv_shape_to_cst (gfc_expr *e)
1149 : : {
1150 : 282 : tree tmp = NULL;
1151 : 760 : for (int d = 0; d < e->rank; ++d)
1152 : : {
1153 : 478 : if (!tmp)
1154 : 282 : tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind);
1155 : : else
1156 : 196 : tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp,
1157 : : gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind));
1158 : : }
1159 : 282 : return fold_convert (size_type_node, tmp);
1160 : : }
1161 : :
1162 : : static void
1163 : 1030 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1164 : : tree *team_no)
1165 : : {
1166 : 1030 : gfc_expr *stat_e, *team_e;
1167 : :
1168 : 1030 : stat_e = gfc_find_stat_co (expr);
1169 : 1030 : if (stat_e)
1170 : : {
1171 : 22 : gfc_se stat_se;
1172 : 22 : gfc_init_se (&stat_se, NULL);
1173 : 22 : gfc_conv_expr_reference (&stat_se, stat_e);
1174 : 22 : *stat = stat_se.expr;
1175 : 22 : gfc_add_block_to_block (block, &stat_se.pre);
1176 : 22 : gfc_add_block_to_block (block, &stat_se.post);
1177 : : }
1178 : : else
1179 : 1008 : *stat = null_pointer_node;
1180 : :
1181 : 1030 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1182 : 1030 : if (team_e)
1183 : : {
1184 : 9 : gfc_se team_se;
1185 : 9 : gfc_init_se (&team_se, NULL);
1186 : 9 : gfc_conv_expr (&team_se, team_e);
1187 : 9 : *team
1188 : 9 : = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
1189 : : team_se.expr));
1190 : 9 : gfc_add_block_to_block (block, &team_se.pre);
1191 : 9 : gfc_add_block_to_block (block, &team_se.post);
1192 : : }
1193 : : else
1194 : 1021 : *team = null_pointer_node;
1195 : :
1196 : 1030 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1197 : 1030 : if (team_e)
1198 : : {
1199 : 15 : gfc_se team_se;
1200 : 15 : gfc_init_se (&team_se, NULL);
1201 : 15 : gfc_conv_expr (&team_se, team_e);
1202 : 15 : *team_no = gfc_build_addr_expr (
1203 : : NULL_TREE,
1204 : : gfc_trans_force_lval (&team_se.pre,
1205 : : fold_convert (integer_type_node, team_se.expr)));
1206 : 15 : gfc_add_block_to_block (block, &team_se.pre);
1207 : 15 : gfc_add_block_to_block (block, &team_se.post);
1208 : : }
1209 : : else
1210 : 1015 : *team_no = null_pointer_node;
1211 : 1030 : }
1212 : :
1213 : : /* Get data from a remote coarray. */
1214 : :
1215 : : static void
1216 : 895 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1217 : : bool may_realloc, symbol_attribute *caf_attr)
1218 : : {
1219 : 895 : gfc_expr *array_expr;
1220 : 895 : tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
1221 : : dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
1222 : : opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
1223 : 895 : symbol_attribute caf_attr_store;
1224 : 895 : gfc_namespace *ns;
1225 : 895 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1226 : 895 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1227 : 895 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1228 : :
1229 : 895 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1230 : :
1231 : 895 : if (se->ss && se->ss->info->useflags)
1232 : : {
1233 : : /* Access the previously obtained result. */
1234 : 352 : gfc_conv_tmp_array_ref (se);
1235 : 352 : return;
1236 : : }
1237 : :
1238 : 543 : array_expr = expr->value.function.actual->expr;
1239 : 543 : ns = array_expr->expr_type == EXPR_VARIABLE
1240 : 543 : && !array_expr->symtree->n.sym->attr.associate_var
1241 : 543 : ? array_expr->symtree->n.sym->ns
1242 : : : gfc_current_ns;
1243 : 543 : type = gfc_typenode_for_spec (&array_expr->ts);
1244 : :
1245 : 543 : if (caf_attr == NULL)
1246 : : {
1247 : 543 : caf_attr_store = gfc_caf_attr (array_expr);
1248 : 543 : caf_attr = &caf_attr_store;
1249 : : }
1250 : :
1251 : 543 : res_var = lhs;
1252 : :
1253 : 543 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1254 : :
1255 : 543 : get_fn_index_tree
1256 : 543 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1257 : : get_fn_hash);
1258 : 543 : add_data_tree
1259 : 543 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1260 : : add_data_sym, &add_data_size);
1261 : 543 : ++caf_call_cnt;
1262 : :
1263 : 543 : if (array_expr->rank == 0)
1264 : : {
1265 : 190 : res_var = gfc_create_var (type, "caf_res");
1266 : 190 : if (array_expr->ts.type == BT_CHARACTER)
1267 : : {
1268 : 17 : gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre);
1269 : 17 : se->string_length = array_expr->ts.u.cl->backend_decl;
1270 : 17 : opt_src_charlen = gfc_build_addr_expr (
1271 : : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1272 : 17 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1273 : : }
1274 : : else
1275 : : {
1276 : 173 : dest_size = res_var->typed.type->type_common.size_unit;
1277 : 173 : opt_src_charlen
1278 : 173 : = build_zero_cst (build_pointer_type (size_type_node));
1279 : : }
1280 : 190 : dest_data
1281 : 190 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1282 : 190 : res_var = build_fold_indirect_ref (dest_data);
1283 : 190 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1284 : 190 : opt_dest_desc = build_zero_cst (pvoid_type_node);
1285 : : }
1286 : : else
1287 : : {
1288 : : /* Create temporary. */
1289 : 353 : may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
1290 : : type, NULL_TREE, false, false,
1291 : : false, &array_expr->where)
1292 : : == NULL_TREE;
1293 : 353 : res_var = se->ss->info->data.array.descriptor;
1294 : 353 : if (array_expr->ts.type == BT_CHARACTER)
1295 : : {
1296 : 8 : se->string_length = array_expr->ts.u.cl->backend_decl;
1297 : 8 : opt_src_charlen = gfc_build_addr_expr (
1298 : : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1299 : 8 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1300 : : }
1301 : : else
1302 : : {
1303 : 345 : opt_src_charlen
1304 : 345 : = build_zero_cst (build_pointer_type (size_type_node));
1305 : 345 : dest_size = fold_build2 (
1306 : : MULT_EXPR, size_type_node,
1307 : : fold_convert (size_type_node,
1308 : : array_expr->shape
1309 : : ? conv_shape_to_cst (array_expr)
1310 : : : gfc_conv_descriptor_size (res_var,
1311 : : array_expr->rank)),
1312 : : fold_convert (size_type_node,
1313 : : gfc_conv_descriptor_span_get (res_var)));
1314 : : }
1315 : 353 : opt_dest_desc = res_var;
1316 : 353 : dest_data = gfc_conv_descriptor_data_get (res_var);
1317 : 353 : opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc);
1318 : 353 : if (may_realloc)
1319 : : {
1320 : 52 : tmp = gfc_conv_descriptor_data_get (res_var);
1321 : 52 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1322 : : NULL_TREE, NULL_TREE, true, NULL,
1323 : : GFC_CAF_COARRAY_NOCOARRAY);
1324 : 52 : gfc_add_expr_to_block (&se->post, tmp);
1325 : : }
1326 : 353 : dest_data
1327 : 353 : = gfc_build_addr_expr (NULL_TREE,
1328 : : gfc_trans_force_lval (&se->pre, dest_data));
1329 : : }
1330 : :
1331 : 543 : opt_dest_charlen = opt_src_charlen;
1332 : 543 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1333 : 543 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1334 : 1 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1335 : :
1336 : 543 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1337 : 543 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1338 : 473 : opt_src_desc = build_zero_cst (pvoid_type_node);
1339 : : else
1340 : 70 : opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1341 : :
1342 : 543 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1343 : 543 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1344 : :
1345 : : /* It guarantees memory consistency within the same segment. */
1346 : 543 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1347 : 543 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1348 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1349 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1350 : 543 : ASM_VOLATILE_P (tmp) = 1;
1351 : 543 : gfc_add_expr_to_block (&se->pre, tmp);
1352 : :
1353 : 543 : tmp = build_call_expr_loc (
1354 : : input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
1355 : : opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
1356 : : opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
1357 : : get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
1358 : :
1359 : 543 : gfc_add_expr_to_block (&se->pre, tmp);
1360 : :
1361 : 543 : if (se->ss)
1362 : 353 : gfc_advance_se_ss_chain (se);
1363 : :
1364 : 543 : se->expr = res_var;
1365 : :
1366 : 543 : return;
1367 : : }
1368 : :
1369 : : /* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1370 : : calls. */
1371 : :
1372 : : static void
1373 : 132 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374 : : {
1375 : 132 : gfc_expr *caf_expr, *hash, *present_fn;
1376 : 132 : gfc_symbol *add_data_sym;
1377 : 132 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378 : :
1379 : 132 : gcc_assert (e->expr_type == EXPR_FUNCTION
1380 : : && e->value.function.isym->id
1381 : : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382 : 132 : caf_expr = e->value.function.actual->expr;
1383 : 132 : hash = e->value.function.actual->next->expr;
1384 : 132 : present_fn = e->value.function.actual->next->next->expr;
1385 : 132 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386 : :
1387 : 132 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1388 : : "__caf_present_on_remote_fn_index_%d", hash);
1389 : 132 : add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
1390 : : "__caf_present_on_remote_add_data_%d",
1391 : : add_data_sym, &add_data_size);
1392 : 132 : ++caf_call_cnt;
1393 : :
1394 : 132 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395 : 132 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396 : 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397 : :
1398 : 132 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399 : 132 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400 : :
1401 : 132 : se->expr
1402 : 132 : = fold_convert (logical_type_node,
1403 : : build_call_expr_loc (input_location,
1404 : : gfor_fndecl_caf_is_present_on_remote,
1405 : : 5, token, image_index, fn_index,
1406 : : add_data_tree, add_data_size));
1407 : 132 : }
1408 : :
1409 : : static tree
1410 : 293 : conv_caf_send_to_remote (gfc_code *code)
1411 : : {
1412 : 293 : gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1413 : 293 : gfc_symbol *add_data_sym;
1414 : 293 : gfc_se lhs_se, rhs_se;
1415 : 293 : stmtblock_t block;
1416 : 293 : gfc_namespace *ns;
1417 : 293 : tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1418 : 293 : tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1419 : 293 : tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1420 : 293 : tree receiver_fn_index_tree, add_data_tree, add_data_size;
1421 : :
1422 : 293 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1423 : 293 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1424 : :
1425 : 293 : lhs_expr = code->ext.actual->expr;
1426 : 293 : rhs_expr = code->ext.actual->next->expr;
1427 : 293 : lhs_hash = code->ext.actual->next->next->expr;
1428 : 293 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1429 : 293 : add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1430 : :
1431 : 293 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1432 : 293 : && !lhs_expr->symtree->n.sym->attr.associate_var
1433 : 293 : ? lhs_expr->symtree->n.sym->ns
1434 : : : gfc_current_ns;
1435 : :
1436 : 293 : gfc_init_block (&block);
1437 : :
1438 : : /* LHS. */
1439 : 293 : gfc_init_se (&lhs_se, NULL);
1440 : 293 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1441 : 293 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1442 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1443 : 293 : if (lhs_expr->rank == 0)
1444 : : {
1445 : 241 : if (lhs_expr->ts.type == BT_CHARACTER)
1446 : : {
1447 : 12 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1448 : 12 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1449 : 12 : opt_lhs_charlen = gfc_build_addr_expr (
1450 : : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1451 : : }
1452 : : else
1453 : 229 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1454 : 241 : opt_lhs_desc = null_pointer_node;
1455 : : }
1456 : : else
1457 : : {
1458 : 52 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1459 : 52 : gfc_add_block_to_block (&block, &lhs_se.pre);
1460 : 52 : opt_lhs_desc = lhs_se.expr;
1461 : 52 : if (lhs_expr->ts.type == BT_CHARACTER)
1462 : 22 : opt_lhs_charlen = gfc_build_addr_expr (
1463 : : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1464 : : else
1465 : 30 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1466 : : /* Get the third formal argument of the receiver function. (This is the
1467 : : location where to put the data on the remote image.) Need to look at
1468 : : the argument in the function decl, because in the gfc_symbol's formal
1469 : : argument an array may have no descriptor while in the generated
1470 : : function decl it has. */
1471 : 52 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1472 : : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1473 : 52 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1474 : 28 : opt_lhs_desc = null_pointer_node;
1475 : : else
1476 : 24 : opt_lhs_desc
1477 : 24 : = gfc_build_addr_expr (NULL_TREE,
1478 : : gfc_trans_force_lval (&block, opt_lhs_desc));
1479 : : }
1480 : :
1481 : : /* Obtain token, offset and image index for the LHS. */
1482 : 293 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1483 : 293 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1484 : :
1485 : : /* RHS. */
1486 : 293 : gfc_init_se (&rhs_se, NULL);
1487 : 293 : if (rhs_expr->rank == 0)
1488 : : {
1489 : 171 : rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER;
1490 : 171 : gfc_conv_expr (&rhs_se, rhs_expr);
1491 : 171 : gfc_add_block_to_block (&block, &rhs_se.pre);
1492 : 171 : opt_rhs_desc = null_pointer_node;
1493 : 171 : if (rhs_expr->ts.type == BT_CHARACTER)
1494 : : {
1495 : 20 : rhs_data
1496 : 20 : = rhs_expr->expr_type == EXPR_CONSTANT
1497 : 20 : ? gfc_build_addr_expr (NULL_TREE,
1498 : : gfc_trans_force_lval (&block,
1499 : : rhs_se.expr))
1500 : : : rhs_se.expr;
1501 : 20 : opt_rhs_charlen = gfc_build_addr_expr (
1502 : : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1503 : 20 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1504 : : }
1505 : : else
1506 : : {
1507 : 151 : rhs_data
1508 : 151 : = gfc_build_addr_expr (NULL_TREE,
1509 : : gfc_trans_force_lval (&block, rhs_se.expr));
1510 : 151 : opt_rhs_charlen
1511 : 151 : = build_zero_cst (build_pointer_type (size_type_node));
1512 : 151 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1513 : : }
1514 : : }
1515 : : else
1516 : : {
1517 : 244 : rhs_se.force_tmp = rhs_expr->shape == NULL
1518 : 122 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1519 : 122 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1520 : 122 : gfc_add_block_to_block (&block, &rhs_se.pre);
1521 : 122 : opt_rhs_desc = rhs_se.expr;
1522 : 122 : if (rhs_expr->ts.type == BT_CHARACTER)
1523 : : {
1524 : 14 : opt_rhs_charlen = gfc_build_addr_expr (
1525 : : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1526 : 14 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1527 : : }
1528 : : else
1529 : : {
1530 : 108 : opt_rhs_charlen
1531 : 108 : = build_zero_cst (build_pointer_type (size_type_node));
1532 : 108 : rhs_size = fold_build2 (
1533 : : MULT_EXPR, size_type_node,
1534 : : fold_convert (size_type_node,
1535 : : rhs_expr->shape
1536 : : ? conv_shape_to_cst (rhs_expr)
1537 : : : gfc_conv_descriptor_size (rhs_se.expr,
1538 : : rhs_expr->rank)),
1539 : : fold_convert (size_type_node,
1540 : : gfc_conv_descriptor_span_get (rhs_se.expr)));
1541 : : }
1542 : :
1543 : 122 : rhs_data = gfc_build_addr_expr (
1544 : : NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1545 : : opt_rhs_desc)));
1546 : 122 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1547 : : }
1548 : 293 : gfc_add_block_to_block (&block, &rhs_se.pre);
1549 : :
1550 : 293 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1551 : :
1552 : 293 : receiver_fn_index_tree
1553 : 293 : = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
1554 : : lhs_hash);
1555 : 293 : add_data_tree
1556 : 293 : = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
1557 : : add_data_sym, &add_data_size);
1558 : 293 : ++caf_call_cnt;
1559 : :
1560 : 293 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1561 : : token, opt_lhs_desc, opt_lhs_charlen, image_index,
1562 : : rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1563 : : receiver_fn_index_tree, add_data_tree,
1564 : : add_data_size, lhs_stat, lhs_team, lhs_team_no);
1565 : :
1566 : 293 : gfc_add_expr_to_block (&block, tmp);
1567 : 293 : gfc_add_block_to_block (&block, &lhs_se.post);
1568 : 293 : gfc_add_block_to_block (&block, &rhs_se.post);
1569 : :
1570 : : /* It guarantees memory consistency within the same segment. */
1571 : 293 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1572 : 293 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1573 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1574 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1575 : 293 : ASM_VOLATILE_P (tmp) = 1;
1576 : 293 : gfc_add_expr_to_block (&block, tmp);
1577 : :
1578 : 293 : return gfc_finish_block (&block);
1579 : : }
1580 : :
1581 : : /* Send-get data to a remote coarray. */
1582 : :
1583 : : static tree
1584 : 97 : conv_caf_sendget (gfc_code *code)
1585 : : {
1586 : : /* lhs stuff */
1587 : 97 : gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1588 : 97 : gfc_symbol *lhs_add_data_sym;
1589 : 97 : gfc_se lhs_se;
1590 : 97 : tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1591 : 97 : opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1592 : : lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1593 : 97 : int transfer_rank;
1594 : :
1595 : : /* rhs stuff */
1596 : 97 : gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1597 : 97 : gfc_symbol *rhs_add_data_sym;
1598 : 97 : gfc_se rhs_se;
1599 : 97 : tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1600 : 97 : opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1601 : : rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1602 : :
1603 : : /* shared */
1604 : 97 : stmtblock_t block;
1605 : 97 : gfc_namespace *ns;
1606 : 97 : tree tmp, rhs_size;
1607 : :
1608 : 97 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1609 : 97 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1610 : :
1611 : 97 : lhs_expr = code->ext.actual->expr;
1612 : 97 : rhs_expr = code->ext.actual->next->expr;
1613 : 97 : lhs_hash = code->ext.actual->next->next->expr;
1614 : 97 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1615 : 97 : rhs_hash = code->ext.actual->next->next->next->next->expr;
1616 : 97 : sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1617 : :
1618 : 97 : lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1619 : 97 : rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1620 : :
1621 : 97 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1622 : 97 : && !lhs_expr->symtree->n.sym->attr.associate_var
1623 : 97 : ? lhs_expr->symtree->n.sym->ns
1624 : : : gfc_current_ns;
1625 : :
1626 : 97 : gfc_init_block (&block);
1627 : :
1628 : 97 : lhs_stat = null_pointer_node;
1629 : 97 : lhs_team = null_pointer_node;
1630 : 97 : rhs_stat = null_pointer_node;
1631 : 97 : rhs_team = null_pointer_node;
1632 : :
1633 : : /* LHS. */
1634 : 97 : gfc_init_se (&lhs_se, NULL);
1635 : 97 : lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1636 : 97 : if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1637 : 0 : lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1638 : 97 : if (lhs_expr->rank == 0)
1639 : : {
1640 : 63 : if (lhs_expr->ts.type == BT_CHARACTER)
1641 : : {
1642 : 8 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1643 : 8 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1644 : 8 : opt_lhs_charlen = gfc_build_addr_expr (
1645 : : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1646 : : }
1647 : : else
1648 : 55 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1649 : 63 : opt_lhs_desc = null_pointer_node;
1650 : : }
1651 : : else
1652 : : {
1653 : 34 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1654 : 34 : gfc_add_block_to_block (&block, &lhs_se.pre);
1655 : 34 : opt_lhs_desc = lhs_se.expr;
1656 : 34 : if (lhs_expr->ts.type == BT_CHARACTER)
1657 : 16 : opt_lhs_charlen = gfc_build_addr_expr (
1658 : : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1659 : : else
1660 : 18 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1661 : : /* Get the third formal argument of the receiver function. (This is the
1662 : : location where to put the data on the remote image.) Need to look at
1663 : : the argument in the function decl, because in the gfc_symbol's formal
1664 : : argument an array may have no descriptor while in the generated
1665 : : function decl it has. */
1666 : 34 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1667 : : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1668 : 34 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1669 : 30 : opt_lhs_desc = null_pointer_node;
1670 : : else
1671 : 4 : opt_lhs_desc
1672 : 4 : = gfc_build_addr_expr (NULL_TREE,
1673 : : gfc_trans_force_lval (&block, opt_lhs_desc));
1674 : : }
1675 : :
1676 : : /* Obtain token, offset and image index for the LHS. */
1677 : 97 : lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1678 : 97 : gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1679 : : lhs_expr);
1680 : :
1681 : : /* RHS. */
1682 : 97 : rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1683 : 97 : if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1684 : 0 : rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1685 : 97 : transfer_rank = rhs_expr->rank;
1686 : 97 : gfc_expression_rank (rhs_expr);
1687 : 97 : gfc_init_se (&rhs_se, NULL);
1688 : 97 : if (rhs_expr->rank == 0)
1689 : : {
1690 : 64 : opt_rhs_desc = null_pointer_node;
1691 : 64 : if (rhs_expr->ts.type == BT_CHARACTER)
1692 : : {
1693 : 16 : gfc_conv_expr (&rhs_se, rhs_expr);
1694 : 16 : gfc_add_block_to_block (&block, &rhs_se.pre);
1695 : 16 : opt_rhs_charlen = gfc_build_addr_expr (
1696 : : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1697 : 16 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1698 : : }
1699 : : else
1700 : : {
1701 : 48 : gfc_typespec *ts
1702 : 48 : = &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1703 : :
1704 : 48 : opt_rhs_charlen
1705 : 48 : = build_zero_cst (build_pointer_type (size_type_node));
1706 : 48 : rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1707 : : }
1708 : : }
1709 : : /* Get the fifth formal argument of the getter function. This is the argument
1710 : : pointing to the data to get on the remote image. Need to look at the
1711 : : argument in the function decl, because in the gfc_symbol's formal argument
1712 : : an array may have no descriptor while in the generated function decl it
1713 : : has. */
1714 : 33 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1715 : : TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1716 : : TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1717 : : {
1718 : 29 : rhs_se.data_not_needed = 1;
1719 : 29 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1720 : 29 : gfc_add_block_to_block (&block, &rhs_se.pre);
1721 : 29 : if (rhs_expr->ts.type == BT_CHARACTER)
1722 : : {
1723 : 8 : opt_rhs_charlen = gfc_build_addr_expr (
1724 : : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1725 : 8 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1726 : : }
1727 : : else
1728 : : {
1729 : 21 : opt_rhs_charlen
1730 : 21 : = build_zero_cst (build_pointer_type (size_type_node));
1731 : 21 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1732 : : }
1733 : 29 : opt_rhs_desc = null_pointer_node;
1734 : : }
1735 : : else
1736 : : {
1737 : 4 : gfc_ref *arr_ref = rhs_expr->ref;
1738 : 4 : while (arr_ref && arr_ref->type != REF_ARRAY)
1739 : 0 : arr_ref = arr_ref->next;
1740 : 4 : rhs_se.force_tmp
1741 : 8 : = (rhs_expr->shape == NULL
1742 : 4 : && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1743 : 8 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1744 : 4 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1745 : 4 : gfc_add_block_to_block (&block, &rhs_se.pre);
1746 : 4 : opt_rhs_desc = rhs_se.expr;
1747 : 4 : if (rhs_expr->ts.type == BT_CHARACTER)
1748 : : {
1749 : 0 : opt_rhs_charlen = gfc_build_addr_expr (
1750 : : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1751 : 0 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1752 : : }
1753 : : else
1754 : : {
1755 : 4 : opt_rhs_charlen
1756 : 4 : = build_zero_cst (build_pointer_type (size_type_node));
1757 : 4 : rhs_size = fold_build2 (
1758 : : MULT_EXPR, size_type_node,
1759 : : fold_convert (size_type_node,
1760 : : rhs_expr->shape
1761 : : ? conv_shape_to_cst (rhs_expr)
1762 : : : gfc_conv_descriptor_size (rhs_se.expr,
1763 : : rhs_expr->rank)),
1764 : : fold_convert (size_type_node,
1765 : : gfc_conv_descriptor_span_get (rhs_se.expr)));
1766 : : }
1767 : :
1768 : 4 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1769 : : }
1770 : 97 : gfc_add_block_to_block (&block, &rhs_se.pre);
1771 : :
1772 : : /* Obtain token, offset and image index for the RHS. */
1773 : 97 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1774 : 97 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1775 : : rhs_expr);
1776 : :
1777 : : /* stat and team. */
1778 : 97 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1779 : 97 : conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
1780 : :
1781 : 97 : sender_fn_index_tree
1782 : 97 : = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
1783 : : rhs_hash);
1784 : 97 : rhs_add_data_tree
1785 : 97 : = conv_caf_add_call_data (&block, ns,
1786 : : "__caf_transfer_from_remote_add_data_%d",
1787 : : rhs_add_data_sym, &rhs_add_data_size);
1788 : 97 : receiver_fn_index_tree
1789 : 97 : = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
1790 : : lhs_hash);
1791 : 97 : lhs_add_data_tree
1792 : 97 : = conv_caf_add_call_data (&block, ns,
1793 : : "__caf_transfer_to_remote_add_data_%d",
1794 : : lhs_add_data_sym, &lhs_add_data_size);
1795 : 97 : ++caf_call_cnt;
1796 : :
1797 : 97 : tmp = build_call_expr_loc (
1798 : : input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1799 : : opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1800 : : lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1801 : : opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1802 : : rhs_add_data_size, rhs_size,
1803 : : transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1804 : : rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1805 : :
1806 : 97 : gfc_add_expr_to_block (&block, tmp);
1807 : 97 : gfc_add_block_to_block (&block, &lhs_se.post);
1808 : 97 : gfc_add_block_to_block (&block, &rhs_se.post);
1809 : :
1810 : : /* It guarantees memory consistency within the same segment. */
1811 : 97 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1812 : 97 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1813 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1814 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1815 : 97 : ASM_VOLATILE_P (tmp) = 1;
1816 : 97 : gfc_add_expr_to_block (&block, tmp);
1817 : :
1818 : 97 : return gfc_finish_block (&block);
1819 : : }
1820 : :
1821 : :
1822 : : static void
1823 : 727 : trans_this_image (gfc_se * se, gfc_expr *expr)
1824 : : {
1825 : 727 : stmtblock_t loop;
1826 : 727 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1827 : : ubound, extent, ml, team;
1828 : 727 : gfc_se argse;
1829 : 727 : int rank, corank;
1830 : :
1831 : : /* The case -fcoarray=single is handled elsewhere. */
1832 : 727 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1833 : :
1834 : : /* Translate team, if present. */
1835 : 727 : if (expr->value.function.actual->next->next->expr)
1836 : : {
1837 : 18 : gfc_init_se (&argse, NULL);
1838 : 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
1839 : 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
1840 : 18 : gfc_add_block_to_block (&se->post, &argse.post);
1841 : 18 : team = fold_convert (pvoid_type_node, argse.expr);
1842 : : }
1843 : : else
1844 : 709 : team = null_pointer_node;
1845 : :
1846 : : /* Argument-free version: THIS_IMAGE(). */
1847 : 727 : if (expr->value.function.actual->expr == NULL)
1848 : : {
1849 : 556 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1850 : : team);
1851 : 556 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1852 : : tmp);
1853 : 560 : return;
1854 : : }
1855 : :
1856 : : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1857 : :
1858 : 171 : type = gfc_get_int_type (gfc_default_integer_kind);
1859 : 171 : corank = expr->value.function.actual->expr->corank;
1860 : 171 : rank = expr->value.function.actual->expr->rank;
1861 : :
1862 : : /* Obtain the descriptor of the COARRAY. */
1863 : 171 : gfc_init_se (&argse, NULL);
1864 : 171 : argse.want_coarray = 1;
1865 : 171 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1866 : 171 : gfc_add_block_to_block (&se->pre, &argse.pre);
1867 : 171 : gfc_add_block_to_block (&se->post, &argse.post);
1868 : 171 : desc = argse.expr;
1869 : :
1870 : 171 : if (se->ss)
1871 : : {
1872 : : /* Create an implicit second parameter from the loop variable. */
1873 : 41 : gcc_assert (!expr->value.function.actual->next->expr);
1874 : 41 : gcc_assert (corank > 0);
1875 : 41 : gcc_assert (se->loop->dimen == 1);
1876 : 41 : gcc_assert (se->ss->info->expr == expr);
1877 : :
1878 : 41 : dim_arg = se->loop->loopvar[0];
1879 : 41 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1880 : : gfc_array_index_type, dim_arg,
1881 : 41 : build_int_cst (TREE_TYPE (dim_arg), 1));
1882 : 41 : gfc_advance_se_ss_chain (se);
1883 : : }
1884 : : else
1885 : : {
1886 : : /* Use the passed DIM= argument. */
1887 : 130 : gcc_assert (expr->value.function.actual->next->expr);
1888 : 130 : gfc_init_se (&argse, NULL);
1889 : 130 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1890 : : gfc_array_index_type);
1891 : 130 : gfc_add_block_to_block (&se->pre, &argse.pre);
1892 : 130 : dim_arg = argse.expr;
1893 : :
1894 : 130 : if (INTEGER_CST_P (dim_arg))
1895 : : {
1896 : 72 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1897 : 144 : || wi::gtu_p (wi::to_wide (dim_arg),
1898 : 72 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1899 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1900 : 0 : "dimension index", expr->value.function.isym->name,
1901 : : &expr->where);
1902 : : }
1903 : 58 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1904 : : {
1905 : 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1906 : 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1907 : : dim_arg,
1908 : 0 : build_int_cst (TREE_TYPE (dim_arg), 1));
1909 : 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1910 : 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1911 : : dim_arg, tmp);
1912 : 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1913 : : logical_type_node, cond, tmp);
1914 : 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1915 : : gfc_msg_fault);
1916 : : }
1917 : : }
1918 : :
1919 : : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1920 : : one always has a dim_arg argument.
1921 : :
1922 : : m = this_image() - 1
1923 : : if (corank == 1)
1924 : : {
1925 : : sub(1) = m + lcobound(corank)
1926 : : return;
1927 : : }
1928 : : i = rank
1929 : : min_var = min (rank + corank - 2, rank + dim_arg - 1)
1930 : : for (;;)
1931 : : {
1932 : : extent = gfc_extent(i)
1933 : : ml = m
1934 : : m = m/extent
1935 : : if (i >= min_var)
1936 : : goto exit_label
1937 : : i++
1938 : : }
1939 : : exit_label:
1940 : : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1941 : : : m + lcobound(corank)
1942 : : */
1943 : :
1944 : : /* this_image () - 1. */
1945 : 171 : tmp
1946 : 171 : = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1947 : 171 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1948 : : fold_convert (type, tmp), build_int_cst (type, 1));
1949 : 171 : if (corank == 1)
1950 : : {
1951 : : /* sub(1) = m + lcobound(corank). */
1952 : 4 : lbound = gfc_conv_descriptor_lbound_get (desc,
1953 : 4 : build_int_cst (TREE_TYPE (gfc_array_index_type),
1954 : 4 : corank+rank-1));
1955 : 4 : lbound = fold_convert (type, lbound);
1956 : 4 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1957 : :
1958 : 4 : se->expr = tmp;
1959 : 4 : return;
1960 : : }
1961 : :
1962 : 167 : m = gfc_create_var (type, NULL);
1963 : 167 : ml = gfc_create_var (type, NULL);
1964 : 167 : loop_var = gfc_create_var (integer_type_node, NULL);
1965 : 167 : min_var = gfc_create_var (integer_type_node, NULL);
1966 : :
1967 : : /* m = this_image () - 1. */
1968 : 167 : gfc_add_modify (&se->pre, m, tmp);
1969 : :
1970 : : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1971 : 167 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1972 : : fold_convert (integer_type_node, dim_arg),
1973 : 167 : build_int_cst (integer_type_node, rank - 1));
1974 : 167 : tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1975 : 167 : build_int_cst (integer_type_node, rank + corank - 2),
1976 : : tmp);
1977 : 167 : gfc_add_modify (&se->pre, min_var, tmp);
1978 : :
1979 : : /* i = rank. */
1980 : 167 : tmp = build_int_cst (integer_type_node, rank);
1981 : 167 : gfc_add_modify (&se->pre, loop_var, tmp);
1982 : :
1983 : 167 : exit_label = gfc_build_label_decl (NULL_TREE);
1984 : 167 : TREE_USED (exit_label) = 1;
1985 : :
1986 : : /* Loop body. */
1987 : 167 : gfc_init_block (&loop);
1988 : :
1989 : : /* ml = m. */
1990 : 167 : gfc_add_modify (&loop, ml, m);
1991 : :
1992 : : /* extent = ... */
1993 : 167 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1994 : 167 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1995 : 167 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1996 : 167 : extent = fold_convert (type, extent);
1997 : :
1998 : : /* m = m/extent. */
1999 : 167 : gfc_add_modify (&loop, m,
2000 : : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2001 : : m, extent));
2002 : :
2003 : : /* Exit condition: if (i >= min_var) goto exit_label. */
2004 : 167 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2005 : : min_var);
2006 : 167 : tmp = build1_v (GOTO_EXPR, exit_label);
2007 : 167 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2008 : : build_empty_stmt (input_location));
2009 : 167 : gfc_add_expr_to_block (&loop, tmp);
2010 : :
2011 : : /* Increment loop variable: i++. */
2012 : 167 : gfc_add_modify (&loop, loop_var,
2013 : : fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2014 : : loop_var,
2015 : : integer_one_node));
2016 : :
2017 : : /* Making the loop... actually loop! */
2018 : 167 : tmp = gfc_finish_block (&loop);
2019 : 167 : tmp = build1_v (LOOP_EXPR, tmp);
2020 : 167 : gfc_add_expr_to_block (&se->pre, tmp);
2021 : :
2022 : : /* The exit label. */
2023 : 167 : tmp = build1_v (LABEL_EXPR, exit_label);
2024 : 167 : gfc_add_expr_to_block (&se->pre, tmp);
2025 : :
2026 : : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2027 : : : m + lcobound(corank) */
2028 : :
2029 : 167 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2030 : 167 : build_int_cst (TREE_TYPE (dim_arg), corank));
2031 : :
2032 : 167 : lbound = gfc_conv_descriptor_lbound_get (desc,
2033 : : fold_build2_loc (input_location, PLUS_EXPR,
2034 : : gfc_array_index_type, dim_arg,
2035 : 167 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2036 : 167 : lbound = fold_convert (type, lbound);
2037 : :
2038 : 167 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2039 : : fold_build2_loc (input_location, MULT_EXPR, type,
2040 : : m, extent));
2041 : 167 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2042 : :
2043 : 167 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2044 : : fold_build2_loc (input_location, PLUS_EXPR, type,
2045 : : m, lbound));
2046 : : }
2047 : :
2048 : :
2049 : : /* Convert a call to image_status. */
2050 : :
2051 : : static void
2052 : 16 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2053 : : {
2054 : 16 : unsigned int num_args;
2055 : 16 : tree *args, tmp;
2056 : :
2057 : 16 : num_args = gfc_intrinsic_argument_list_length (expr);
2058 : 16 : args = XALLOCAVEC (tree, num_args);
2059 : 16 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2060 : : /* In args[0] the number of the image the status is desired for has to be
2061 : : given. */
2062 : :
2063 : 16 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2064 : : {
2065 : 0 : tree arg;
2066 : 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2067 : 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2068 : : fold_convert (integer_type_node, arg),
2069 : : integer_one_node);
2070 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2071 : : tmp, integer_zero_node,
2072 : : build_int_cst (integer_type_node,
2073 : : GFC_STAT_STOPPED_IMAGE));
2074 : : }
2075 : 16 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2076 : 16 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2077 : : args[0],
2078 : : num_args < 2 ? null_pointer_node : args[1]);
2079 : : else
2080 : 0 : gcc_unreachable ();
2081 : :
2082 : 16 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2083 : 16 : }
2084 : :
2085 : : static void
2086 : 19 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2087 : : {
2088 : 19 : unsigned int num_args;
2089 : :
2090 : 19 : tree *args, tmp;
2091 : :
2092 : 19 : num_args = gfc_intrinsic_argument_list_length (expr);
2093 : 19 : args = XALLOCAVEC (tree, num_args);
2094 : 19 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2095 : :
2096 : 19 : if (flag_coarray ==
2097 : 18 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2098 : 0 : tmp = gfc_evaluate_now (args[0], &se->pre);
2099 : 19 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2100 : : {
2101 : : // the value -1 represents that no team has been created yet
2102 : 18 : tmp = build_int_cst (integer_type_node, -1);
2103 : : }
2104 : 1 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2105 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2106 : : args[0]);
2107 : 1 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2108 : 1 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2109 : : null_pointer_node);
2110 : : else
2111 : 0 : gcc_unreachable ();
2112 : :
2113 : 19 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2114 : 19 : }
2115 : :
2116 : :
2117 : : static void
2118 : 152 : trans_image_index (gfc_se * se, gfc_expr *expr)
2119 : : {
2120 : 152 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2121 : 152 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2122 : 152 : gfc_se argse, subse;
2123 : 152 : int rank, corank, codim;
2124 : :
2125 : 152 : type = gfc_get_int_type (gfc_default_integer_kind);
2126 : 152 : corank = expr->value.function.actual->expr->corank;
2127 : 152 : rank = expr->value.function.actual->expr->rank;
2128 : :
2129 : : /* Obtain the descriptor of the COARRAY. */
2130 : 152 : gfc_init_se (&argse, NULL);
2131 : 152 : argse.want_coarray = 1;
2132 : 152 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2133 : 152 : gfc_add_block_to_block (&se->pre, &argse.pre);
2134 : 152 : gfc_add_block_to_block (&se->post, &argse.post);
2135 : 152 : desc = argse.expr;
2136 : :
2137 : : /* Obtain a handle to the SUB argument. */
2138 : 152 : gfc_init_se (&subse, NULL);
2139 : 152 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2140 : 152 : gfc_add_block_to_block (&se->pre, &subse.pre);
2141 : 152 : gfc_add_block_to_block (&se->post, &subse.post);
2142 : 152 : subdesc = build_fold_indirect_ref_loc (input_location,
2143 : : gfc_conv_descriptor_data_get (subse.expr));
2144 : :
2145 : 152 : if (expr->value.function.actual->next->next->expr)
2146 : : {
2147 : 0 : gfc_init_se (&argse, NULL);
2148 : 0 : gfc_conv_expr_descriptor (&argse,
2149 : 0 : expr->value.function.actual->next->next->expr);
2150 : 0 : if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2151 : 0 : team = argse.expr;
2152 : : else
2153 : 0 : team_number = gfc_build_addr_expr (
2154 : : NULL_TREE,
2155 : : gfc_trans_force_lval (&argse.pre,
2156 : : fold_convert (integer_type_node, argse.expr)));
2157 : 0 : gfc_add_block_to_block (&se->pre, &argse.pre);
2158 : 0 : gfc_add_block_to_block (&se->post, &argse.post);
2159 : : }
2160 : :
2161 : : /* Fortran 2008 does not require that the values remain in the cobounds,
2162 : : thus we need explicitly check this - and return 0 if they are exceeded. */
2163 : :
2164 : 152 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2165 : 152 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2166 : 152 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2167 : : fold_convert (gfc_array_index_type, tmp),
2168 : : lbound);
2169 : :
2170 : 352 : for (codim = corank + rank - 2; codim >= rank; codim--)
2171 : : {
2172 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2173 : 200 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2174 : 200 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2175 : 200 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2176 : : fold_convert (gfc_array_index_type, tmp),
2177 : : lbound);
2178 : 200 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2179 : : logical_type_node, invalid_bound, cond);
2180 : 200 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2181 : : fold_convert (gfc_array_index_type, tmp),
2182 : : ubound);
2183 : 200 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2184 : : logical_type_node, invalid_bound, cond);
2185 : : }
2186 : :
2187 : 152 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2188 : :
2189 : : /* See Fortran 2008, C.10 for the following algorithm. */
2190 : :
2191 : : /* coindex = sub(corank) - lcobound(n). */
2192 : 152 : coindex = fold_convert (gfc_array_index_type,
2193 : : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2194 : : NULL));
2195 : 152 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2196 : 152 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2197 : : fold_convert (gfc_array_index_type, coindex),
2198 : : lbound);
2199 : :
2200 : 352 : for (codim = corank + rank - 2; codim >= rank; codim--)
2201 : : {
2202 : 200 : tree extent, ubound;
2203 : :
2204 : : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2205 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2206 : 200 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2207 : 200 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2208 : :
2209 : : /* coindex *= extent. */
2210 : 200 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2211 : : gfc_array_index_type, coindex, extent);
2212 : :
2213 : : /* coindex += sub(codim). */
2214 : 200 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2215 : 200 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2216 : : gfc_array_index_type, coindex,
2217 : : fold_convert (gfc_array_index_type, tmp));
2218 : :
2219 : : /* coindex -= lbound(codim). */
2220 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2221 : 200 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2222 : : gfc_array_index_type, coindex, lbound);
2223 : : }
2224 : :
2225 : 152 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2226 : : fold_convert(type, coindex),
2227 : : build_int_cst (type, 1));
2228 : :
2229 : : /* Return 0 if "coindex" exceeds num_images(). */
2230 : :
2231 : 152 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2232 : 108 : num_images = build_int_cst (type, 1);
2233 : : else
2234 : : {
2235 : 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2236 : : team, team_number);
2237 : 44 : num_images = fold_convert (type, tmp);
2238 : : }
2239 : :
2240 : 152 : tmp = gfc_create_var (type, NULL);
2241 : 152 : gfc_add_modify (&se->pre, tmp, coindex);
2242 : :
2243 : 152 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2244 : : num_images);
2245 : 152 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2246 : : cond,
2247 : : fold_convert (logical_type_node, invalid_bound));
2248 : 152 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2249 : : build_int_cst (type, 0), tmp);
2250 : 152 : }
2251 : :
2252 : : static void
2253 : 429 : trans_num_images (gfc_se * se, gfc_expr *expr)
2254 : : {
2255 : 429 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2256 : 429 : gfc_se argse;
2257 : :
2258 : 429 : if (expr->value.function.actual->expr)
2259 : : {
2260 : 18 : gfc_init_se (&argse, NULL);
2261 : 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2262 : 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2263 : 6 : team = argse.expr;
2264 : : else
2265 : 12 : team_number = gfc_build_addr_expr (
2266 : : NULL_TREE,
2267 : : gfc_trans_force_lval (&se->pre,
2268 : : fold_convert (integer_type_node, argse.expr)));
2269 : 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2270 : 18 : gfc_add_block_to_block (&se->post, &argse.post);
2271 : : }
2272 : :
2273 : 429 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2274 : : team, team_number);
2275 : 429 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2276 : 429 : }
2277 : :
2278 : :
2279 : : static void
2280 : 10970 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2281 : : {
2282 : 10970 : gfc_se argse;
2283 : :
2284 : 10970 : gfc_init_se (&argse, NULL);
2285 : 10970 : argse.data_not_needed = 1;
2286 : 10970 : argse.descriptor_only = 1;
2287 : :
2288 : 10970 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2289 : 10970 : gfc_add_block_to_block (&se->pre, &argse.pre);
2290 : 10970 : gfc_add_block_to_block (&se->post, &argse.post);
2291 : :
2292 : 10970 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2293 : 10970 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2294 : : se->expr);
2295 : 10970 : }
2296 : :
2297 : :
2298 : : static void
2299 : 729 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2300 : : {
2301 : 729 : gfc_expr *arg;
2302 : 729 : arg = expr->value.function.actual->expr;
2303 : 729 : gfc_conv_is_contiguous_expr (se, arg);
2304 : 729 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2305 : 729 : }
2306 : :
2307 : : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2308 : : plus it can be called directly. */
2309 : :
2310 : : void
2311 : 2072 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2312 : : {
2313 : 2072 : gfc_ss *ss;
2314 : 2072 : gfc_se argse;
2315 : 2072 : tree desc, tmp, stride, extent, cond;
2316 : 2072 : int i;
2317 : 2072 : tree fncall0;
2318 : 2072 : gfc_array_spec *as;
2319 : 2072 : gfc_symbol *sym = NULL;
2320 : :
2321 : 2072 : if (arg->ts.type == BT_CLASS)
2322 : 90 : gfc_add_class_array_ref (arg);
2323 : :
2324 : 2072 : if (arg->expr_type == EXPR_VARIABLE)
2325 : 2036 : sym = arg->symtree->n.sym;
2326 : :
2327 : 2072 : ss = gfc_walk_expr (arg);
2328 : 2072 : gcc_assert (ss != gfc_ss_terminator);
2329 : 2072 : gfc_init_se (&argse, NULL);
2330 : 2072 : argse.data_not_needed = 1;
2331 : 2072 : gfc_conv_expr_descriptor (&argse, arg);
2332 : :
2333 : 2072 : as = gfc_get_full_arrayspec_from_expr (arg);
2334 : :
2335 : : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2336 : : Note in addition that zero-sized arrays don't count as contiguous. */
2337 : :
2338 : 2072 : if (as && as->type == AS_ASSUMED_RANK)
2339 : : {
2340 : : /* Build the call to is_contiguous0. */
2341 : 243 : argse.want_pointer = 1;
2342 : 243 : gfc_conv_expr_descriptor (&argse, arg);
2343 : 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2344 : 243 : gfc_add_block_to_block (&se->post, &argse.post);
2345 : 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2346 : 243 : fncall0 = build_call_expr_loc (input_location,
2347 : : gfor_fndecl_is_contiguous0, 1, desc);
2348 : 243 : se->expr = fncall0;
2349 : 243 : se->expr = convert (boolean_type_node, se->expr);
2350 : : }
2351 : : else
2352 : : {
2353 : 1829 : gfc_add_block_to_block (&se->pre, &argse.pre);
2354 : 1829 : gfc_add_block_to_block (&se->post, &argse.post);
2355 : 1829 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2356 : :
2357 : 1829 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2358 : 1829 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2359 : 1829 : stride, build_int_cst (TREE_TYPE (stride), 1));
2360 : :
2361 : 2155 : for (i = 0; i < arg->rank - 1; i++)
2362 : : {
2363 : 326 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2364 : 326 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2365 : 326 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2366 : : gfc_array_index_type, extent, tmp);
2367 : 326 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2368 : : gfc_array_index_type, extent,
2369 : : gfc_index_one_node);
2370 : 326 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2371 : 326 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2372 : : tmp, extent);
2373 : 326 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2374 : 326 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2375 : : stride, tmp);
2376 : 326 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2377 : : boolean_type_node, cond, tmp);
2378 : : }
2379 : 1829 : se->expr = cond;
2380 : : }
2381 : :
2382 : : /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2383 : : if it points to an array whose span differs from the element size. */
2384 : 2072 : if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2385 : : {
2386 : 180 : tree span = gfc_conv_descriptor_span_get (desc);
2387 : 180 : tmp = fold_convert (TREE_TYPE (span),
2388 : : gfc_conv_descriptor_elem_len (desc));
2389 : 180 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2390 : : span, tmp);
2391 : 180 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2392 : : boolean_type_node, cond,
2393 : : convert (boolean_type_node, se->expr));
2394 : : }
2395 : :
2396 : 2072 : gfc_free_ss_chain (ss);
2397 : 2072 : }
2398 : :
2399 : :
2400 : : /* Evaluate a single upper or lower bound. */
2401 : : /* TODO: bound intrinsic generates way too much unnecessary code. */
2402 : :
2403 : : static void
2404 : 16002 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2405 : : {
2406 : 16002 : gfc_actual_arglist *arg;
2407 : 16002 : gfc_actual_arglist *arg2;
2408 : 16002 : tree desc;
2409 : 16002 : tree type;
2410 : 16002 : tree bound;
2411 : 16002 : tree tmp;
2412 : 16002 : tree cond, cond1;
2413 : 16002 : tree ubound;
2414 : 16002 : tree lbound;
2415 : 16002 : tree size;
2416 : 16002 : gfc_se argse;
2417 : 16002 : gfc_array_spec * as;
2418 : 16002 : bool assumed_rank_lb_one;
2419 : :
2420 : 16002 : arg = expr->value.function.actual;
2421 : 16002 : arg2 = arg->next;
2422 : :
2423 : 16002 : if (se->ss)
2424 : : {
2425 : : /* Create an implicit second parameter from the loop variable. */
2426 : 7827 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2427 : 7827 : gcc_assert (se->loop->dimen == 1);
2428 : 7827 : gcc_assert (se->ss->info->expr == expr);
2429 : 7827 : gfc_advance_se_ss_chain (se);
2430 : 7827 : bound = se->loop->loopvar[0];
2431 : 7827 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2432 : : gfc_array_index_type, bound,
2433 : : se->loop->from[0]);
2434 : : }
2435 : : else
2436 : : {
2437 : : /* use the passed argument. */
2438 : 8175 : gcc_assert (arg2->expr);
2439 : 8175 : gfc_init_se (&argse, NULL);
2440 : 8175 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2441 : 8175 : gfc_add_block_to_block (&se->pre, &argse.pre);
2442 : 8175 : bound = argse.expr;
2443 : : /* Convert from one based to zero based. */
2444 : 8175 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2445 : : gfc_array_index_type, bound,
2446 : : gfc_index_one_node);
2447 : : }
2448 : :
2449 : : /* TODO: don't re-evaluate the descriptor on each iteration. */
2450 : : /* Get a descriptor for the first parameter. */
2451 : 16002 : gfc_init_se (&argse, NULL);
2452 : 16002 : gfc_conv_expr_descriptor (&argse, arg->expr);
2453 : 16002 : gfc_add_block_to_block (&se->pre, &argse.pre);
2454 : 16002 : gfc_add_block_to_block (&se->post, &argse.post);
2455 : :
2456 : 16002 : desc = argse.expr;
2457 : :
2458 : 16002 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2459 : :
2460 : 16002 : if (INTEGER_CST_P (bound))
2461 : : {
2462 : 8055 : gcc_assert (op != GFC_ISYM_SHAPE);
2463 : 7818 : if (((!as || as->type != AS_ASSUMED_RANK)
2464 : 7195 : && wi::geu_p (wi::to_wide (bound),
2465 : 7195 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2466 : 16110 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2467 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2468 : : "dimension index",
2469 : : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2470 : : &expr->where);
2471 : : }
2472 : :
2473 : 16002 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2474 : : {
2475 : 8807 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2476 : : {
2477 : 651 : bound = gfc_evaluate_now (bound, &se->pre);
2478 : 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2479 : 651 : bound, build_int_cst (TREE_TYPE (bound), 0));
2480 : 651 : if (as && as->type == AS_ASSUMED_RANK)
2481 : 546 : tmp = gfc_conv_descriptor_rank (desc);
2482 : : else
2483 : 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2484 : 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2485 : 651 : bound, fold_convert(TREE_TYPE (bound), tmp));
2486 : 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2487 : : logical_type_node, cond, tmp);
2488 : 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2489 : : gfc_msg_fault);
2490 : : }
2491 : : }
2492 : :
2493 : : /* Take care of the lbound shift for assumed-rank arrays that are
2494 : : nonallocatable and nonpointers. Those have a lbound of 1. */
2495 : 15514 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2496 : 10926 : && ((arg->expr->ts.type != BT_CLASS
2497 : 1945 : && !arg->expr->symtree->n.sym->attr.allocatable
2498 : 1602 : && !arg->expr->symtree->n.sym->attr.pointer)
2499 : 896 : || (arg->expr->ts.type == BT_CLASS
2500 : 174 : && !CLASS_DATA (arg->expr)->attr.allocatable
2501 : 138 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2502 : :
2503 : 16002 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2504 : 16002 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2505 : 16002 : size = fold_build2_loc (input_location, MINUS_EXPR,
2506 : : gfc_array_index_type, ubound, lbound);
2507 : 16002 : size = fold_build2_loc (input_location, PLUS_EXPR,
2508 : : gfc_array_index_type, size, gfc_index_one_node);
2509 : :
2510 : : /* 13.14.53: Result value for LBOUND
2511 : :
2512 : : Case (i): For an array section or for an array expression other than a
2513 : : whole array or array structure component, LBOUND(ARRAY, DIM)
2514 : : has the value 1. For a whole array or array structure
2515 : : component, LBOUND(ARRAY, DIM) has the value:
2516 : : (a) equal to the lower bound for subscript DIM of ARRAY if
2517 : : dimension DIM of ARRAY does not have extent zero
2518 : : or if ARRAY is an assumed-size array of rank DIM,
2519 : : or (b) 1 otherwise.
2520 : :
2521 : : 13.14.113: Result value for UBOUND
2522 : :
2523 : : Case (i): For an array section or for an array expression other than a
2524 : : whole array or array structure component, UBOUND(ARRAY, DIM)
2525 : : has the value equal to the number of elements in the given
2526 : : dimension; otherwise, it has a value equal to the upper bound
2527 : : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2528 : : not have size zero and has value zero if dimension DIM has
2529 : : size zero. */
2530 : :
2531 : 16002 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2532 : 532 : se->expr = gfc_index_one_node;
2533 : 15470 : else if (as)
2534 : : {
2535 : 14982 : if (op == GFC_ISYM_UBOUND)
2536 : : {
2537 : 5338 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2538 : : size, gfc_index_zero_node);
2539 : 10072 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2540 : : gfc_array_index_type, cond,
2541 : : (assumed_rank_lb_one ? size : ubound),
2542 : : gfc_index_zero_node);
2543 : : }
2544 : 9644 : else if (op == GFC_ISYM_LBOUND)
2545 : : {
2546 : 4866 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2547 : : size, gfc_index_zero_node);
2548 : 4866 : if (as->type == AS_ASSUMED_SIZE)
2549 : : {
2550 : 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2551 : : logical_type_node, bound,
2552 : 98 : build_int_cst (TREE_TYPE (bound),
2553 : 98 : arg->expr->rank - 1));
2554 : 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2555 : : logical_type_node, cond, cond1);
2556 : : }
2557 : 4866 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2558 : : gfc_array_index_type, cond,
2559 : : lbound, gfc_index_one_node);
2560 : : }
2561 : 4778 : else if (op == GFC_ISYM_SHAPE)
2562 : 4778 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2563 : : gfc_array_index_type, size,
2564 : : gfc_index_zero_node);
2565 : : else
2566 : 0 : gcc_unreachable ();
2567 : :
2568 : : /* According to F2018 16.9.172, para 5, an assumed rank object,
2569 : : argument associated with and assumed size array, has the ubound
2570 : : of the final dimension set to -1 and UBOUND must return this.
2571 : : Similarly for the SHAPE intrinsic. */
2572 : 14982 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2573 : : {
2574 : 793 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2575 : 793 : tree rank = fold_convert (gfc_array_index_type,
2576 : : gfc_conv_descriptor_rank (desc));
2577 : 793 : rank = fold_build2_loc (input_location, PLUS_EXPR,
2578 : : gfc_array_index_type, rank, minus_one);
2579 : :
2580 : : /* Fix the expression to stop it from becoming even more
2581 : : complicated. */
2582 : 793 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2583 : :
2584 : : /* Descriptors for assumed-size arrays have ubound = -1
2585 : : in the last dimension. */
2586 : 793 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2587 : : logical_type_node, ubound, minus_one);
2588 : 793 : cond = fold_build2_loc (input_location, EQ_EXPR,
2589 : : logical_type_node, bound, rank);
2590 : 793 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2591 : : logical_type_node, cond, cond1);
2592 : 793 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2593 : : gfc_array_index_type, cond,
2594 : : minus_one, se->expr);
2595 : : }
2596 : : }
2597 : : else /* as is null; this is an old-fashioned 1-based array. */
2598 : : {
2599 : 488 : if (op != GFC_ISYM_LBOUND)
2600 : : {
2601 : 386 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2602 : : gfc_array_index_type, size,
2603 : : gfc_index_zero_node);
2604 : : }
2605 : : else
2606 : 102 : se->expr = gfc_index_one_node;
2607 : : }
2608 : :
2609 : :
2610 : 16002 : type = gfc_typenode_for_spec (&expr->ts);
2611 : 16002 : se->expr = convert (type, se->expr);
2612 : 16002 : }
2613 : :
2614 : :
2615 : : static void
2616 : 577 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2617 : : {
2618 : 577 : gfc_actual_arglist *arg;
2619 : 577 : gfc_actual_arglist *arg2;
2620 : 577 : gfc_se argse;
2621 : 577 : tree bound, resbound, resbound2, desc, cond, tmp;
2622 : 577 : tree type;
2623 : 577 : int corank;
2624 : :
2625 : 577 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2626 : : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2627 : : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2628 : :
2629 : 577 : arg = expr->value.function.actual;
2630 : 577 : arg2 = arg->next;
2631 : :
2632 : 577 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2633 : 577 : corank = arg->expr->corank;
2634 : :
2635 : 577 : gfc_init_se (&argse, NULL);
2636 : 577 : argse.want_coarray = 1;
2637 : :
2638 : 577 : gfc_conv_expr_descriptor (&argse, arg->expr);
2639 : 577 : gfc_add_block_to_block (&se->pre, &argse.pre);
2640 : 577 : gfc_add_block_to_block (&se->post, &argse.post);
2641 : 577 : desc = argse.expr;
2642 : :
2643 : 577 : if (se->ss)
2644 : : {
2645 : : /* Create an implicit second parameter from the loop variable. */
2646 : 184 : gcc_assert (!arg2->expr);
2647 : 184 : gcc_assert (corank > 0);
2648 : 184 : gcc_assert (se->loop->dimen == 1);
2649 : 184 : gcc_assert (se->ss->info->expr == expr);
2650 : :
2651 : 184 : bound = se->loop->loopvar[0];
2652 : 368 : bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2653 : 184 : bound, gfc_rank_cst[arg->expr->rank]);
2654 : 184 : gfc_advance_se_ss_chain (se);
2655 : : }
2656 : : else
2657 : : {
2658 : : /* use the passed argument. */
2659 : 393 : gcc_assert (arg2->expr);
2660 : 393 : gfc_init_se (&argse, NULL);
2661 : 393 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2662 : 393 : gfc_add_block_to_block (&se->pre, &argse.pre);
2663 : 393 : bound = argse.expr;
2664 : :
2665 : 393 : if (INTEGER_CST_P (bound))
2666 : : {
2667 : 299 : if (wi::ltu_p (wi::to_wide (bound), 1)
2668 : 598 : || wi::gtu_p (wi::to_wide (bound),
2669 : 299 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2670 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2671 : 0 : "dimension index", expr->value.function.isym->name,
2672 : : &expr->where);
2673 : : }
2674 : 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2675 : : {
2676 : 36 : bound = gfc_evaluate_now (bound, &se->pre);
2677 : 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2678 : 36 : bound, build_int_cst (TREE_TYPE (bound), 1));
2679 : 36 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2680 : 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2681 : : bound, tmp);
2682 : 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2683 : : logical_type_node, cond, tmp);
2684 : 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2685 : : gfc_msg_fault);
2686 : : }
2687 : :
2688 : :
2689 : : /* Subtract 1 to get to zero based and add dimensions. */
2690 : 393 : switch (arg->expr->rank)
2691 : : {
2692 : 51 : case 0:
2693 : 51 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2694 : : gfc_array_index_type, bound,
2695 : : gfc_index_one_node);
2696 : : case 1:
2697 : : break;
2698 : 36 : default:
2699 : 36 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2700 : : gfc_array_index_type, bound,
2701 : 36 : gfc_rank_cst[arg->expr->rank - 1]);
2702 : : }
2703 : : }
2704 : :
2705 : 577 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2706 : :
2707 : : /* Handle UCOBOUND with special handling of the last codimension. */
2708 : 577 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
2709 : : {
2710 : : /* Last codimension: For -fcoarray=single just return
2711 : : the lcobound - otherwise add
2712 : : ceiling (real (num_images ()) / real (size)) - 1
2713 : : = (num_images () + size - 1) / size - 1
2714 : : = (num_images - 1) / size(),
2715 : : where size is the product of the extent of all but the last
2716 : : codimension. */
2717 : :
2718 : 191 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2719 : : {
2720 : 30 : tree cosize;
2721 : :
2722 : 30 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2723 : 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2724 : : 2, null_pointer_node, null_pointer_node);
2725 : 30 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2726 : : gfc_array_index_type,
2727 : : fold_convert (gfc_array_index_type, tmp),
2728 : : build_int_cst (gfc_array_index_type, 1));
2729 : 30 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2730 : : gfc_array_index_type, tmp,
2731 : : fold_convert (gfc_array_index_type, cosize));
2732 : 30 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2733 : : gfc_array_index_type, resbound, tmp);
2734 : 30 : }
2735 : 161 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2736 : : {
2737 : : /* ubound = lbound + num_images() - 1. */
2738 : 21 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2739 : : 2, null_pointer_node, null_pointer_node);
2740 : 21 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2741 : : gfc_array_index_type,
2742 : : fold_convert (gfc_array_index_type, tmp),
2743 : : build_int_cst (gfc_array_index_type, 1));
2744 : 21 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2745 : : gfc_array_index_type, resbound, tmp);
2746 : : }
2747 : :
2748 : 191 : if (corank > 1)
2749 : : {
2750 : 137 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2751 : : bound,
2752 : 137 : build_int_cst (TREE_TYPE (bound),
2753 : 137 : arg->expr->rank + corank - 1));
2754 : :
2755 : 137 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2756 : 137 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2757 : : gfc_array_index_type, cond,
2758 : : resbound, resbound2);
2759 : : }
2760 : : else
2761 : 54 : se->expr = resbound;
2762 : : }
2763 : : else
2764 : 386 : se->expr = resbound;
2765 : :
2766 : 577 : type = gfc_typenode_for_spec (&expr->ts);
2767 : 577 : se->expr = convert (type, se->expr);
2768 : 577 : }
2769 : :
2770 : :
2771 : : static void
2772 : 1966 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2773 : : {
2774 : 1966 : gfc_actual_arglist *array_arg;
2775 : 1966 : gfc_actual_arglist *dim_arg;
2776 : 1966 : gfc_se argse;
2777 : 1966 : tree desc, tmp;
2778 : :
2779 : 1966 : array_arg = expr->value.function.actual;
2780 : 1966 : dim_arg = array_arg->next;
2781 : :
2782 : 1966 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2783 : :
2784 : 1966 : gfc_init_se (&argse, NULL);
2785 : 1966 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2786 : 1966 : gfc_add_block_to_block (&se->pre, &argse.pre);
2787 : 1966 : gfc_add_block_to_block (&se->post, &argse.post);
2788 : 1966 : desc = argse.expr;
2789 : :
2790 : 1966 : gcc_assert (dim_arg->expr);
2791 : 1966 : gfc_init_se (&argse, NULL);
2792 : 1966 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2793 : 1966 : gfc_add_block_to_block (&se->pre, &argse.pre);
2794 : 1966 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2795 : : argse.expr, gfc_index_one_node);
2796 : 1966 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2797 : 1966 : }
2798 : :
2799 : : static void
2800 : 7747 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2801 : : {
2802 : 7747 : tree arg, cabs;
2803 : :
2804 : 7747 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2805 : :
2806 : 7747 : switch (expr->value.function.actual->expr->ts.type)
2807 : : {
2808 : 6771 : case BT_INTEGER:
2809 : 6771 : case BT_REAL:
2810 : 6771 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2811 : : arg);
2812 : 6771 : break;
2813 : :
2814 : 976 : case BT_COMPLEX:
2815 : 976 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2816 : 976 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2817 : 976 : break;
2818 : :
2819 : 0 : default:
2820 : 0 : gcc_unreachable ();
2821 : : }
2822 : 7747 : }
2823 : :
2824 : :
2825 : : /* Create a complex value from one or two real components. */
2826 : :
2827 : : static void
2828 : 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2829 : : {
2830 : 491 : tree real;
2831 : 491 : tree imag;
2832 : 491 : tree type;
2833 : 491 : tree *args;
2834 : 491 : unsigned int num_args;
2835 : :
2836 : 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2837 : 491 : args = XALLOCAVEC (tree, num_args);
2838 : :
2839 : 491 : type = gfc_typenode_for_spec (&expr->ts);
2840 : 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2841 : 491 : real = convert (TREE_TYPE (type), args[0]);
2842 : 491 : if (both)
2843 : 447 : imag = convert (TREE_TYPE (type), args[1]);
2844 : 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2845 : : {
2846 : 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2847 : 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2848 : 30 : imag = convert (TREE_TYPE (type), imag);
2849 : : }
2850 : : else
2851 : 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2852 : :
2853 : 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2854 : 491 : }
2855 : :
2856 : :
2857 : : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2858 : : MODULO(A, P) = A - FLOOR (A / P) * P
2859 : :
2860 : : The obvious algorithms above are numerically instable for large
2861 : : arguments, hence these intrinsics are instead implemented via calls
2862 : : to the fmod family of functions. It is the responsibility of the
2863 : : user to ensure that the second argument is non-zero. */
2864 : :
2865 : : static void
2866 : 3258 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2867 : : {
2868 : 3258 : tree type;
2869 : 3258 : tree tmp;
2870 : 3258 : tree test;
2871 : 3258 : tree test2;
2872 : 3258 : tree fmod;
2873 : 3258 : tree zero;
2874 : 3258 : tree args[2];
2875 : :
2876 : 3258 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2877 : :
2878 : 3258 : switch (expr->ts.type)
2879 : : {
2880 : 3105 : case BT_INTEGER:
2881 : : /* Integer case is easy, we've got a builtin op. */
2882 : 3105 : type = TREE_TYPE (args[0]);
2883 : :
2884 : 3105 : if (modulo)
2885 : 403 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2886 : : args[0], args[1]);
2887 : : else
2888 : 2702 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2889 : : args[0], args[1]);
2890 : : break;
2891 : :
2892 : 30 : case BT_UNSIGNED:
2893 : : /* Even easier, we only need one. */
2894 : 30 : type = TREE_TYPE (args[0]);
2895 : 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2896 : : args[0], args[1]);
2897 : 30 : break;
2898 : :
2899 : 123 : case BT_REAL:
2900 : 123 : fmod = NULL_TREE;
2901 : : /* Check if we have a builtin fmod. */
2902 : 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2903 : :
2904 : : /* The builtin should always be available. */
2905 : 123 : gcc_assert (fmod != NULL_TREE);
2906 : :
2907 : 123 : tmp = build_addr (fmod);
2908 : 123 : se->expr = build_call_array_loc (input_location,
2909 : 123 : TREE_TYPE (TREE_TYPE (fmod)),
2910 : : tmp, 2, args);
2911 : 123 : if (modulo == 0)
2912 : 123 : return;
2913 : :
2914 : 25 : type = TREE_TYPE (args[0]);
2915 : :
2916 : 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2917 : 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2918 : :
2919 : : /* Definition:
2920 : : modulo = arg - floor (arg/arg2) * arg2
2921 : :
2922 : : In order to calculate the result accurately, we use the fmod
2923 : : function as follows.
2924 : :
2925 : : res = fmod (arg, arg2);
2926 : : if (res)
2927 : : {
2928 : : if ((arg < 0) xor (arg2 < 0))
2929 : : res += arg2;
2930 : : }
2931 : : else
2932 : : res = copysign (0., arg2);
2933 : :
2934 : : => As two nested ternary exprs:
2935 : :
2936 : : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2937 : : : copysign (0., arg2);
2938 : :
2939 : : */
2940 : :
2941 : 25 : zero = gfc_build_const (type, integer_zero_node);
2942 : 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2943 : 25 : if (!flag_signed_zeros)
2944 : : {
2945 : 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2946 : : args[0], zero);
2947 : 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2948 : : args[1], zero);
2949 : 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2950 : : logical_type_node, test, test2);
2951 : 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2952 : : tmp, zero);
2953 : 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2954 : : logical_type_node, test, test2);
2955 : 1 : test = gfc_evaluate_now (test, &se->pre);
2956 : 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2957 : : fold_build2_loc (input_location,
2958 : : PLUS_EXPR,
2959 : : type, tmp, args[1]),
2960 : : tmp);
2961 : : }
2962 : : else
2963 : : {
2964 : 24 : tree expr1, copysign, cscall;
2965 : 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
2966 : : expr->ts.kind);
2967 : 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2968 : : args[0], zero);
2969 : 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2970 : : args[1], zero);
2971 : 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2972 : : logical_type_node, test, test2);
2973 : 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
2974 : : fold_build2_loc (input_location,
2975 : : PLUS_EXPR,
2976 : : type, tmp, args[1]),
2977 : : tmp);
2978 : 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2979 : : tmp, zero);
2980 : 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
2981 : : args[1]);
2982 : 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2983 : : expr1, cscall);
2984 : : }
2985 : : return;
2986 : :
2987 : 0 : default:
2988 : 0 : gcc_unreachable ();
2989 : : }
2990 : : }
2991 : :
2992 : : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
2993 : : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
2994 : : where the right shifts are logical (i.e. 0's are shifted in).
2995 : : Because SHIFT_EXPR's want shifts strictly smaller than the integral
2996 : : type width, we have to special-case both S == 0 and S == BITSIZE(J):
2997 : : DSHIFTL(I,J,0) = I
2998 : : DSHIFTL(I,J,BITSIZE) = J
2999 : : DSHIFTR(I,J,0) = J
3000 : : DSHIFTR(I,J,BITSIZE) = I. */
3001 : :
3002 : : static void
3003 : 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3004 : : {
3005 : 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3006 : 132 : tree args[3], cond, tmp;
3007 : 132 : int bitsize;
3008 : :
3009 : 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3010 : :
3011 : 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3012 : 132 : type = TREE_TYPE (args[0]);
3013 : 132 : bitsize = TYPE_PRECISION (type);
3014 : 132 : utype = unsigned_type_for (type);
3015 : 132 : stype = TREE_TYPE (args[2]);
3016 : :
3017 : 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3018 : 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3019 : 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3020 : :
3021 : : /* The generic case. */
3022 : 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3023 : 132 : build_int_cst (stype, bitsize), shift);
3024 : 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3025 : : arg1, dshiftl ? shift : tmp);
3026 : :
3027 : 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3028 : : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3029 : 132 : right = fold_convert (type, right);
3030 : :
3031 : 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3032 : :
3033 : : /* Special cases. */
3034 : 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3035 : : build_int_cst (stype, 0));
3036 : 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3037 : : dshiftl ? arg1 : arg2, res);
3038 : :
3039 : 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3040 : 132 : build_int_cst (stype, bitsize));
3041 : 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3042 : : dshiftl ? arg2 : arg1, res);
3043 : :
3044 : 132 : se->expr = res;
3045 : 132 : }
3046 : :
3047 : :
3048 : : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3049 : :
3050 : : static void
3051 : 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3052 : : {
3053 : 96 : tree val;
3054 : 96 : tree tmp;
3055 : 96 : tree type;
3056 : 96 : tree zero;
3057 : 96 : tree args[2];
3058 : :
3059 : 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3060 : 96 : type = TREE_TYPE (args[0]);
3061 : :
3062 : 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3063 : 96 : val = gfc_evaluate_now (val, &se->pre);
3064 : :
3065 : 96 : zero = gfc_build_const (type, integer_zero_node);
3066 : 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3067 : 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3068 : 96 : }
3069 : :
3070 : :
3071 : : /* SIGN(A, B) is absolute value of A times sign of B.
3072 : : The real value versions use library functions to ensure the correct
3073 : : handling of negative zero. Integer case implemented as:
3074 : : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3075 : : */
3076 : :
3077 : : static void
3078 : 424 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3079 : : {
3080 : 424 : tree tmp;
3081 : 424 : tree type;
3082 : 424 : tree args[2];
3083 : :
3084 : 424 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3085 : 424 : if (expr->ts.type == BT_REAL)
3086 : : {
3087 : 162 : tree abs;
3088 : :
3089 : 162 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3090 : 162 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3091 : :
3092 : : /* We explicitly have to ignore the minus sign. We do so by using
3093 : : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3094 : 162 : if (!flag_sign_zero
3095 : 198 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3096 : : {
3097 : 12 : tree cond, zero;
3098 : 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3099 : 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3100 : : args[1], zero);
3101 : 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3102 : 12 : TREE_TYPE (args[0]), cond,
3103 : : build_call_expr_loc (input_location, abs, 1,
3104 : : args[0]),
3105 : : build_call_expr_loc (input_location, tmp, 2,
3106 : : args[0], args[1]));
3107 : : }
3108 : : else
3109 : 150 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3110 : : args[0], args[1]);
3111 : 162 : return;
3112 : : }
3113 : :
3114 : : /* Having excluded floating point types, we know we are now dealing
3115 : : with signed integer types. */
3116 : 262 : type = TREE_TYPE (args[0]);
3117 : :
3118 : : /* Args[0] is used multiple times below. */
3119 : 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3120 : :
3121 : : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3122 : : the signs of A and B are the same, and of all ones if they differ. */
3123 : 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3124 : 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3125 : 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3126 : 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3127 : :
3128 : : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3129 : : is all ones (i.e. -1). */
3130 : 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3131 : : fold_build2_loc (input_location, PLUS_EXPR,
3132 : : type, args[0], tmp), tmp);
3133 : : }
3134 : :
3135 : :
3136 : : /* Test for the presence of an optional argument. */
3137 : :
3138 : : static void
3139 : 5070 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3140 : : {
3141 : 5070 : gfc_expr *arg;
3142 : :
3143 : 5070 : arg = expr->value.function.actual->expr;
3144 : 5070 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3145 : 5070 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3146 : 5070 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3147 : 5070 : }
3148 : :
3149 : :
3150 : : /* Calculate the double precision product of two single precision values. */
3151 : :
3152 : : static void
3153 : 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3154 : : {
3155 : 13 : tree type;
3156 : 13 : tree args[2];
3157 : :
3158 : 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3159 : :
3160 : : /* Convert the args to double precision before multiplying. */
3161 : 13 : type = gfc_typenode_for_spec (&expr->ts);
3162 : 13 : args[0] = convert (type, args[0]);
3163 : 13 : args[1] = convert (type, args[1]);
3164 : 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3165 : : args[1]);
3166 : 13 : }
3167 : :
3168 : :
3169 : : /* Return a length one character string containing an ascii character. */
3170 : :
3171 : : static void
3172 : 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3173 : : {
3174 : 2020 : tree arg[2];
3175 : 2020 : tree var;
3176 : 2020 : tree type;
3177 : 2020 : unsigned int num_args;
3178 : :
3179 : 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3180 : 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3181 : :
3182 : 2020 : type = gfc_get_char_type (expr->ts.kind);
3183 : 2020 : var = gfc_create_var (type, "char");
3184 : :
3185 : 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3186 : 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3187 : 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3188 : 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3189 : 2020 : }
3190 : :
3191 : :
3192 : : static void
3193 : 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3194 : : {
3195 : 0 : tree var;
3196 : 0 : tree len;
3197 : 0 : tree tmp;
3198 : 0 : tree cond;
3199 : 0 : tree fndecl;
3200 : 0 : tree *args;
3201 : 0 : unsigned int num_args;
3202 : :
3203 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3204 : 0 : args = XALLOCAVEC (tree, num_args);
3205 : :
3206 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
3207 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3208 : :
3209 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3210 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3211 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3212 : :
3213 : 0 : fndecl = build_addr (gfor_fndecl_ctime);
3214 : 0 : tmp = build_call_array_loc (input_location,
3215 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3216 : : fndecl, num_args, args);
3217 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
3218 : :
3219 : : /* Free the temporary afterwards, if necessary. */
3220 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3221 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
3222 : 0 : tmp = gfc_call_free (var);
3223 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3224 : 0 : gfc_add_expr_to_block (&se->post, tmp);
3225 : :
3226 : 0 : se->expr = var;
3227 : 0 : se->string_length = len;
3228 : 0 : }
3229 : :
3230 : :
3231 : : static void
3232 : 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3233 : : {
3234 : 0 : tree var;
3235 : 0 : tree len;
3236 : 0 : tree tmp;
3237 : 0 : tree cond;
3238 : 0 : tree fndecl;
3239 : 0 : tree *args;
3240 : 0 : unsigned int num_args;
3241 : :
3242 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3243 : 0 : args = XALLOCAVEC (tree, num_args);
3244 : :
3245 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
3246 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3247 : :
3248 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3249 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3250 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3251 : :
3252 : 0 : fndecl = build_addr (gfor_fndecl_fdate);
3253 : 0 : tmp = build_call_array_loc (input_location,
3254 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3255 : : fndecl, num_args, args);
3256 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
3257 : :
3258 : : /* Free the temporary afterwards, if necessary. */
3259 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3260 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
3261 : 0 : tmp = gfc_call_free (var);
3262 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3263 : 0 : gfc_add_expr_to_block (&se->post, tmp);
3264 : :
3265 : 0 : se->expr = var;
3266 : 0 : se->string_length = len;
3267 : 0 : }
3268 : :
3269 : :
3270 : : /* Generate a direct call to free() for the FREE subroutine. */
3271 : :
3272 : : static tree
3273 : 10 : conv_intrinsic_free (gfc_code *code)
3274 : : {
3275 : 10 : stmtblock_t block;
3276 : 10 : gfc_se argse;
3277 : 10 : tree arg, call;
3278 : :
3279 : 10 : gfc_init_se (&argse, NULL);
3280 : 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3281 : 10 : arg = fold_convert (ptr_type_node, argse.expr);
3282 : :
3283 : 10 : gfc_init_block (&block);
3284 : 10 : call = build_call_expr_loc (input_location,
3285 : : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3286 : 10 : gfc_add_expr_to_block (&block, call);
3287 : 10 : return gfc_finish_block (&block);
3288 : : }
3289 : :
3290 : :
3291 : : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3292 : : handling seeding on coarray images. */
3293 : :
3294 : : static tree
3295 : 90 : conv_intrinsic_random_init (gfc_code *code)
3296 : : {
3297 : 90 : stmtblock_t block;
3298 : 90 : gfc_se se;
3299 : 90 : tree arg1, arg2, tmp;
3300 : : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3301 : 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3302 : 90 : ? logical_type_node
3303 : 90 : : gfc_get_logical_type (4);
3304 : :
3305 : : /* Make the function call. */
3306 : 90 : gfc_init_block (&block);
3307 : 90 : gfc_init_se (&se, NULL);
3308 : :
3309 : : /* Convert REPEATABLE to the desired LOGICAL entity. */
3310 : 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3311 : 90 : gfc_add_block_to_block (&block, &se.pre);
3312 : 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3313 : 90 : gfc_add_block_to_block (&block, &se.post);
3314 : :
3315 : : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3316 : 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3317 : 90 : gfc_add_block_to_block (&block, &se.pre);
3318 : 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3319 : 90 : gfc_add_block_to_block (&block, &se.post);
3320 : :
3321 : 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3322 : : {
3323 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3324 : : 2, arg1, arg2);
3325 : : }
3326 : : else
3327 : : {
3328 : : /* The ABI for libgfortran needs to be maintained, so a hidden
3329 : : argument must be include if code is compiled with -fcoarray=single
3330 : : or without the option. Set to 0. */
3331 : 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3332 : 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3333 : : 3, arg1, arg2, arg3);
3334 : : }
3335 : :
3336 : 90 : gfc_add_expr_to_block (&block, tmp);
3337 : :
3338 : 90 : return gfc_finish_block (&block);
3339 : : }
3340 : :
3341 : :
3342 : : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3343 : : conversions. */
3344 : :
3345 : : static tree
3346 : 194 : conv_intrinsic_system_clock (gfc_code *code)
3347 : : {
3348 : 194 : stmtblock_t block;
3349 : 194 : gfc_se count_se, count_rate_se, count_max_se;
3350 : 194 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3351 : 194 : tree tmp;
3352 : 194 : int least;
3353 : :
3354 : 194 : gfc_expr *count = code->ext.actual->expr;
3355 : 194 : gfc_expr *count_rate = code->ext.actual->next->expr;
3356 : 194 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3357 : :
3358 : : /* Evaluate our arguments. */
3359 : 194 : if (count)
3360 : : {
3361 : 194 : gfc_init_se (&count_se, NULL);
3362 : 194 : gfc_conv_expr (&count_se, count);
3363 : : }
3364 : :
3365 : 194 : if (count_rate)
3366 : : {
3367 : 181 : gfc_init_se (&count_rate_se, NULL);
3368 : 181 : gfc_conv_expr (&count_rate_se, count_rate);
3369 : : }
3370 : :
3371 : 194 : if (count_max)
3372 : : {
3373 : 180 : gfc_init_se (&count_max_se, NULL);
3374 : 180 : gfc_conv_expr (&count_max_se, count_max);
3375 : : }
3376 : :
3377 : : /* Find the smallest kind found of the arguments. */
3378 : 194 : least = 16;
3379 : 194 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3380 : 194 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3381 : : : least;
3382 : 194 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3383 : : : least;
3384 : :
3385 : : /* Prepare temporary variables. */
3386 : :
3387 : 194 : if (count)
3388 : : {
3389 : 194 : if (least >= 8)
3390 : 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3391 : 176 : else if (least == 4)
3392 : 152 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3393 : 24 : else if (count->ts.kind == 1)
3394 : 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3395 : : count->ts.kind);
3396 : : else
3397 : 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3398 : : count->ts.kind);
3399 : : }
3400 : :
3401 : 194 : if (count_rate)
3402 : : {
3403 : 181 : if (least >= 8)
3404 : 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3405 : 163 : else if (least == 4)
3406 : 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3407 : : else
3408 : 24 : arg2 = integer_zero_node;
3409 : : }
3410 : :
3411 : 194 : if (count_max)
3412 : : {
3413 : 180 : if (least >= 8)
3414 : 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3415 : 162 : else if (least == 4)
3416 : 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3417 : : else
3418 : 24 : arg3 = integer_zero_node;
3419 : : }
3420 : :
3421 : : /* Make the function call. */
3422 : 194 : gfc_init_block (&block);
3423 : :
3424 : 194 : if (least <= 2)
3425 : : {
3426 : 24 : if (least == 1)
3427 : : {
3428 : 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3429 : : : null_pointer_node;
3430 : 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3431 : : : null_pointer_node;
3432 : 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3433 : : : null_pointer_node;
3434 : : }
3435 : :
3436 : 24 : if (least == 2)
3437 : : {
3438 : 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3439 : : : null_pointer_node;
3440 : 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3441 : : : null_pointer_node;
3442 : 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3443 : : : null_pointer_node;
3444 : : }
3445 : : }
3446 : : else
3447 : : {
3448 : 170 : if (least == 4)
3449 : : {
3450 : 581 : tmp = build_call_expr_loc (input_location,
3451 : : gfor_fndecl_system_clock4, 3,
3452 : 152 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3453 : : : null_pointer_node,
3454 : 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3455 : : : null_pointer_node,
3456 : 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3457 : : : null_pointer_node);
3458 : 152 : gfc_add_expr_to_block (&block, tmp);
3459 : : }
3460 : : /* Handle kind>=8, 10, or 16 arguments */
3461 : 170 : if (least >= 8)
3462 : : {
3463 : 72 : tmp = build_call_expr_loc (input_location,
3464 : : gfor_fndecl_system_clock8, 3,
3465 : 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3466 : : : null_pointer_node,
3467 : 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3468 : : : null_pointer_node,
3469 : 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3470 : : : null_pointer_node);
3471 : 18 : gfc_add_expr_to_block (&block, tmp);
3472 : : }
3473 : : }
3474 : :
3475 : : /* And store values back if needed. */
3476 : 194 : if (arg1 && arg1 != count_se.expr)
3477 : 194 : gfc_add_modify (&block, count_se.expr,
3478 : 194 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3479 : 194 : if (arg2 && arg2 != count_rate_se.expr)
3480 : 181 : gfc_add_modify (&block, count_rate_se.expr,
3481 : 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3482 : 194 : if (arg3 && arg3 != count_max_se.expr)
3483 : 180 : gfc_add_modify (&block, count_max_se.expr,
3484 : 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3485 : :
3486 : 194 : return gfc_finish_block (&block);
3487 : : }
3488 : :
3489 : : static tree
3490 : 102 : conv_intrinsic_split (gfc_code *code)
3491 : : {
3492 : 102 : stmtblock_t block, post_block;
3493 : 102 : gfc_se se;
3494 : 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3495 : 102 : tree string, string_len;
3496 : 102 : tree set, set_len;
3497 : 102 : tree pos, pos_for_call;
3498 : 102 : tree back;
3499 : 102 : tree fndecl, call;
3500 : :
3501 : 102 : string_expr = code->ext.actual->expr;
3502 : 102 : set_expr = code->ext.actual->next->expr;
3503 : 102 : pos_expr = code->ext.actual->next->next->expr;
3504 : 102 : back_expr = code->ext.actual->next->next->next->expr;
3505 : :
3506 : 102 : gfc_start_block (&block);
3507 : 102 : gfc_init_block (&post_block);
3508 : :
3509 : 102 : gfc_init_se (&se, NULL);
3510 : 102 : gfc_conv_expr (&se, string_expr);
3511 : 102 : gfc_conv_string_parameter (&se);
3512 : 102 : gfc_add_block_to_block (&block, &se.pre);
3513 : 102 : gfc_add_block_to_block (&post_block, &se.post);
3514 : 102 : string = se.expr;
3515 : 102 : string_len = se.string_length;
3516 : :
3517 : 102 : gfc_init_se (&se, NULL);
3518 : 102 : gfc_conv_expr (&se, set_expr);
3519 : 102 : gfc_conv_string_parameter (&se);
3520 : 102 : gfc_add_block_to_block (&block, &se.pre);
3521 : 102 : gfc_add_block_to_block (&post_block, &se.post);
3522 : 102 : set = se.expr;
3523 : 102 : set_len = se.string_length;
3524 : :
3525 : 102 : gfc_init_se (&se, NULL);
3526 : 102 : gfc_conv_expr (&se, pos_expr);
3527 : 102 : gfc_add_block_to_block (&block, &se.pre);
3528 : 102 : gfc_add_block_to_block (&post_block, &se.post);
3529 : 102 : pos = se.expr;
3530 : 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3531 : :
3532 : 102 : if (back_expr)
3533 : : {
3534 : 48 : gfc_init_se (&se, NULL);
3535 : 48 : gfc_conv_expr (&se, back_expr);
3536 : 48 : gfc_add_block_to_block (&block, &se.pre);
3537 : 48 : gfc_add_block_to_block (&post_block, &se.post);
3538 : 48 : back = se.expr;
3539 : : }
3540 : : else
3541 : 54 : back = logical_false_node;
3542 : :
3543 : 102 : if (string_expr->ts.kind == 1)
3544 : 66 : fndecl = gfor_fndecl_string_split;
3545 : 36 : else if (string_expr->ts.kind == 4)
3546 : 36 : fndecl = gfor_fndecl_string_split_char4;
3547 : : else
3548 : 0 : gcc_unreachable ();
3549 : :
3550 : 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3551 : : set_len, set, pos_for_call, back);
3552 : 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3553 : :
3554 : 102 : gfc_add_block_to_block (&block, &post_block);
3555 : 102 : return gfc_finish_block (&block);
3556 : : }
3557 : :
3558 : : /* Return a character string containing the tty name. */
3559 : :
3560 : : static void
3561 : 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3562 : : {
3563 : 0 : tree var;
3564 : 0 : tree len;
3565 : 0 : tree tmp;
3566 : 0 : tree cond;
3567 : 0 : tree fndecl;
3568 : 0 : tree *args;
3569 : 0 : unsigned int num_args;
3570 : :
3571 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3572 : 0 : args = XALLOCAVEC (tree, num_args);
3573 : :
3574 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
3575 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3576 : :
3577 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3578 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3579 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3580 : :
3581 : 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3582 : 0 : tmp = build_call_array_loc (input_location,
3583 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3584 : : fndecl, num_args, args);
3585 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
3586 : :
3587 : : /* Free the temporary afterwards, if necessary. */
3588 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3589 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
3590 : 0 : tmp = gfc_call_free (var);
3591 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3592 : 0 : gfc_add_expr_to_block (&se->post, tmp);
3593 : :
3594 : 0 : se->expr = var;
3595 : 0 : se->string_length = len;
3596 : 0 : }
3597 : :
3598 : :
3599 : : /* Get the minimum/maximum value of all the parameters.
3600 : : minmax (a1, a2, a3, ...)
3601 : : {
3602 : : mvar = a1;
3603 : : mvar = COMP (mvar, a2)
3604 : : mvar = COMP (mvar, a3)
3605 : : ...
3606 : : return mvar;
3607 : : }
3608 : : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3609 : : care about NaNs, or IFN_FMIN/MAX when the target has support for
3610 : : fast NaN-honouring min/max. When neither holds expand a sequence
3611 : : of explicit comparisons. */
3612 : :
3613 : : /* TODO: Mismatching types can occur when specific names are used.
3614 : : These should be handled during resolution. */
3615 : : static void
3616 : 1320 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3617 : : {
3618 : 1320 : tree tmp;
3619 : 1320 : tree mvar;
3620 : 1320 : tree val;
3621 : 1320 : tree *args;
3622 : 1320 : tree type;
3623 : 1320 : tree argtype;
3624 : 1320 : gfc_actual_arglist *argexpr;
3625 : 1320 : unsigned int i, nargs;
3626 : :
3627 : 1320 : nargs = gfc_intrinsic_argument_list_length (expr);
3628 : 1320 : args = XALLOCAVEC (tree, nargs);
3629 : :
3630 : 1320 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3631 : 1320 : type = gfc_typenode_for_spec (&expr->ts);
3632 : :
3633 : : /* Only evaluate the argument once. */
3634 : 1320 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3635 : 321 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3636 : :
3637 : : /* Determine suitable type of temporary, as a GNU extension allows
3638 : : different argument kinds. */
3639 : 1320 : argtype = TREE_TYPE (args[0]);
3640 : 1320 : argexpr = expr->value.function.actual;
3641 : 2859 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3642 : : {
3643 : 1539 : tree tmptype = TREE_TYPE (args[i]);
3644 : 1539 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3645 : 1 : argtype = tmptype;
3646 : : }
3647 : 1320 : mvar = gfc_create_var (argtype, "M");
3648 : 1320 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3649 : :
3650 : 1320 : argexpr = expr->value.function.actual;
3651 : 2859 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3652 : : {
3653 : 1539 : tree cond = NULL_TREE;
3654 : 1539 : val = args[i];
3655 : :
3656 : : /* Handle absent optional arguments by ignoring the comparison. */
3657 : 1539 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3658 : 920 : && argexpr->expr->symtree->n.sym->attr.optional
3659 : 45 : && INDIRECT_REF_P (val))
3660 : : {
3661 : 84 : cond = fold_build2_loc (input_location,
3662 : : NE_EXPR, logical_type_node,
3663 : 42 : TREE_OPERAND (val, 0),
3664 : 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3665 : : }
3666 : 1497 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3667 : : /* Only evaluate the argument once. */
3668 : 591 : val = gfc_evaluate_now (val, &se->pre);
3669 : :
3670 : 1539 : tree calc;
3671 : : /* For floating point types, the question is what MAX(a, NaN) or
3672 : : MIN(a, NaN) should return (where "a" is a normal number).
3673 : : There are valid use case for returning either one, but the
3674 : : Fortran standard doesn't specify which one should be chosen.
3675 : : Also, there is no consensus among other tested compilers. In
3676 : : short, it's a mess. So lets just do whatever is fastest. */
3677 : 1539 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3678 : 1539 : calc = fold_build2_loc (input_location, code, argtype,
3679 : : convert (argtype, val), mvar);
3680 : 1539 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3681 : :
3682 : 1539 : if (cond != NULL_TREE)
3683 : 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3684 : : build_empty_stmt (input_location));
3685 : 1539 : gfc_add_expr_to_block (&se->pre, tmp);
3686 : : }
3687 : 1320 : se->expr = convert (type, mvar);
3688 : 1320 : }
3689 : :
3690 : :
3691 : : /* Generate library calls for MIN and MAX intrinsics for character
3692 : : variables. */
3693 : : static void
3694 : 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3695 : : {
3696 : 282 : tree *args;
3697 : 282 : tree var, len, fndecl, tmp, cond, function;
3698 : 282 : unsigned int nargs;
3699 : :
3700 : 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3701 : 282 : args = XALLOCAVEC (tree, nargs + 4);
3702 : 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3703 : :
3704 : : /* Create the result variables. */
3705 : 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3706 : 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3707 : 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3708 : 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3709 : 282 : args[2] = build_int_cst (integer_type_node, op);
3710 : 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3711 : :
3712 : 282 : if (expr->ts.kind == 1)
3713 : 210 : function = gfor_fndecl_string_minmax;
3714 : 72 : else if (expr->ts.kind == 4)
3715 : 72 : function = gfor_fndecl_string_minmax_char4;
3716 : : else
3717 : 0 : gcc_unreachable ();
3718 : :
3719 : : /* Make the function call. */
3720 : 282 : fndecl = build_addr (function);
3721 : 282 : tmp = build_call_array_loc (input_location,
3722 : 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3723 : : nargs + 4, args);
3724 : 282 : gfc_add_expr_to_block (&se->pre, tmp);
3725 : :
3726 : : /* Free the temporary afterwards, if necessary. */
3727 : 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3728 : 282 : len, build_int_cst (TREE_TYPE (len), 0));
3729 : 282 : tmp = gfc_call_free (var);
3730 : 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3731 : 282 : gfc_add_expr_to_block (&se->post, tmp);
3732 : :
3733 : 282 : se->expr = var;
3734 : 282 : se->string_length = len;
3735 : 282 : }
3736 : :
3737 : :
3738 : : /* Create a symbol node for this intrinsic. The symbol from the frontend
3739 : : has the generic name. */
3740 : :
3741 : : static gfc_symbol *
3742 : 11345 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3743 : : {
3744 : 11345 : gfc_symbol *sym;
3745 : :
3746 : : /* TODO: Add symbols for intrinsic function to the global namespace. */
3747 : 11345 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3748 : 11345 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3749 : :
3750 : 11345 : sym->ts = expr->ts;
3751 : 11345 : if (sym->ts.type == BT_CHARACTER)
3752 : 1781 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3753 : 11345 : sym->attr.external = 1;
3754 : 11345 : sym->attr.function = 1;
3755 : 11345 : sym->attr.always_explicit = 1;
3756 : 11345 : sym->attr.proc = PROC_INTRINSIC;
3757 : 11345 : sym->attr.flavor = FL_PROCEDURE;
3758 : 11345 : sym->result = sym;
3759 : 11345 : if (expr->rank > 0)
3760 : : {
3761 : 9973 : sym->attr.dimension = 1;
3762 : 9973 : sym->as = gfc_get_array_spec ();
3763 : 9973 : sym->as->type = AS_ASSUMED_SHAPE;
3764 : 9973 : sym->as->rank = expr->rank;
3765 : : }
3766 : :
3767 : 11345 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3768 : : ignore_optional ? expr->value.function.actual
3769 : : : NULL);
3770 : :
3771 : 11345 : return sym;
3772 : : }
3773 : :
3774 : : /* Remove empty actual arguments. */
3775 : :
3776 : : static void
3777 : 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3778 : : {
3779 : 44456 : while (*ap)
3780 : : {
3781 : 36179 : if ((*ap)->expr == NULL)
3782 : : {
3783 : 11076 : gfc_actual_arglist *r = *ap;
3784 : 11076 : *ap = r->next;
3785 : 11076 : r->next = NULL;
3786 : 11076 : gfc_free_actual_arglist (r);
3787 : : }
3788 : : else
3789 : 25103 : ap = &((*ap)->next);
3790 : : }
3791 : 8277 : }
3792 : :
3793 : : #define MAX_SPEC_ARG 12
3794 : :
3795 : : /* Make up an fn spec that's right for intrinsic functions that we
3796 : : want to call. */
3797 : :
3798 : : static char *
3799 : 1939 : intrinsic_fnspec (gfc_expr *expr)
3800 : : {
3801 : 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3802 : 1939 : char *fp;
3803 : 1939 : int i;
3804 : 1939 : int num_char_args;
3805 : :
3806 : : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3807 : :
3808 : : /* Set the fndecl. */
3809 : 1939 : fp = fnspec_buf;
3810 : : /* Function return value. FIXME: Check if the second letter could
3811 : : be something other than a space, for further optimization. */
3812 : 1939 : ADD_CHAR ('.');
3813 : 1939 : if (expr->rank == 0)
3814 : : {
3815 : 238 : if (expr->ts.type == BT_CHARACTER)
3816 : : {
3817 : 84 : ADD_CHAR ('w'); /* Address of character. */
3818 : 84 : ADD_CHAR ('.'); /* Length of character. */
3819 : : }
3820 : : }
3821 : : else
3822 : 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3823 : :
3824 : 1939 : num_char_args = 0;
3825 : 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3826 : : {
3827 : 8285 : if (a->expr == NULL)
3828 : 2565 : continue;
3829 : :
3830 : 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3831 : 1300 : ADD_CHAR ('.');
3832 : : else
3833 : : {
3834 : 4420 : if (a->expr->rank > 0)
3835 : 2575 : ADD_CHAR ('r');
3836 : : else
3837 : 1845 : ADD_CHAR ('R');
3838 : : }
3839 : 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3840 : 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3841 : : }
3842 : :
3843 : 2743 : for (i = 0; i < num_char_args; i++)
3844 : 804 : ADD_CHAR ('.');
3845 : :
3846 : 1939 : *fp = '\0';
3847 : 1939 : return fnspec_buf;
3848 : : }
3849 : :
3850 : : #undef MAX_SPEC_ARG
3851 : : #undef ADD_CHAR
3852 : :
3853 : : /* Generate the right symbol for the specific intrinsic function and
3854 : : modify the expr accordingly. This assumes that absent optional
3855 : : arguments should be removed. */
3856 : :
3857 : : gfc_symbol *
3858 : 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3859 : : {
3860 : 8277 : gfc_symbol *sym;
3861 : :
3862 : 8277 : sym = gfc_find_intrinsic_symbol (expr);
3863 : 8277 : if (sym == NULL)
3864 : : {
3865 : 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3866 : 1939 : sym->ts = expr->ts;
3867 : 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3868 : 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3869 : :
3870 : 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3871 : : expr->value.function.actual, true);
3872 : 1939 : sym->backend_decl
3873 : 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3874 : 1939 : intrinsic_fnspec (expr));
3875 : : }
3876 : :
3877 : 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3878 : :
3879 : 8277 : return sym;
3880 : : }
3881 : :
3882 : : /* Generate a call to an external intrinsic function. FIXME: So far,
3883 : : this only works for functions which are called with well-defined
3884 : : types; CSHIFT and friends will come later. */
3885 : :
3886 : : static void
3887 : 13536 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3888 : : {
3889 : 13536 : gfc_symbol *sym;
3890 : 13536 : vec<tree, va_gc> *append_args;
3891 : 13536 : bool specific_symbol;
3892 : :
3893 : 13536 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3894 : :
3895 : 13536 : if (se->ss)
3896 : 11602 : gcc_assert (expr->rank > 0);
3897 : : else
3898 : 1934 : gcc_assert (expr->rank == 0);
3899 : :
3900 : 13536 : switch (expr->value.function.isym->id)
3901 : : {
3902 : : case GFC_ISYM_ANY:
3903 : : case GFC_ISYM_ALL:
3904 : : case GFC_ISYM_FINDLOC:
3905 : : case GFC_ISYM_MAXLOC:
3906 : : case GFC_ISYM_MINLOC:
3907 : : case GFC_ISYM_MAXVAL:
3908 : : case GFC_ISYM_MINVAL:
3909 : : case GFC_ISYM_NORM2:
3910 : : case GFC_ISYM_PRODUCT:
3911 : : case GFC_ISYM_SUM:
3912 : : specific_symbol = true;
3913 : : break;
3914 : 5259 : default:
3915 : 5259 : specific_symbol = false;
3916 : : }
3917 : :
3918 : 13536 : if (specific_symbol)
3919 : : {
3920 : : /* Need to copy here because specific_intrinsic_symbol modifies
3921 : : expr to omit the absent optional arguments. */
3922 : 8277 : expr = gfc_copy_expr (expr);
3923 : 8277 : sym = specific_intrinsic_symbol (expr);
3924 : : }
3925 : : else
3926 : 5259 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3927 : :
3928 : : /* Calls to libgfortran_matmul need to be appended special arguments,
3929 : : to be able to call the BLAS ?gemm functions if required and possible. */
3930 : 13536 : append_args = NULL;
3931 : 13536 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3932 : 863 : && !expr->external_blas
3933 : 825 : && sym->ts.type != BT_LOGICAL)
3934 : : {
3935 : 809 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3936 : :
3937 : 809 : if (flag_external_blas
3938 : 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3939 : 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3940 : : {
3941 : 0 : tree gemm_fndecl;
3942 : :
3943 : 0 : if (sym->ts.type == BT_REAL)
3944 : : {
3945 : 0 : if (sym->ts.kind == 4)
3946 : 0 : gemm_fndecl = gfor_fndecl_sgemm;
3947 : : else
3948 : 0 : gemm_fndecl = gfor_fndecl_dgemm;
3949 : : }
3950 : : else
3951 : : {
3952 : 0 : if (sym->ts.kind == 4)
3953 : 0 : gemm_fndecl = gfor_fndecl_cgemm;
3954 : : else
3955 : 0 : gemm_fndecl = gfor_fndecl_zgemm;
3956 : : }
3957 : :
3958 : 0 : vec_alloc (append_args, 3);
3959 : 0 : append_args->quick_push (build_int_cst (cint, 1));
3960 : 0 : append_args->quick_push (build_int_cst (cint,
3961 : 0 : flag_blas_matmul_limit));
3962 : 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3963 : : gemm_fndecl));
3964 : 0 : }
3965 : : else
3966 : : {
3967 : 809 : vec_alloc (append_args, 3);
3968 : 809 : append_args->quick_push (build_int_cst (cint, 0));
3969 : 809 : append_args->quick_push (build_int_cst (cint, 0));
3970 : 809 : append_args->quick_push (null_pointer_node);
3971 : : }
3972 : : }
3973 : : /* Non-character scalar reduce returns a pointer to a result of size set by
3974 : : the element size of 'array'. Setting 'sym' allocatable ensures that the
3975 : : result is deallocated at the appropriate time. */
3976 : 12727 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
3977 : 102 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
3978 : 96 : sym->attr.allocatable = 1;
3979 : :
3980 : :
3981 : 13536 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3982 : : append_args);
3983 : :
3984 : 13536 : if (specific_symbol)
3985 : 8277 : gfc_free_expr (expr);
3986 : : else
3987 : 5259 : gfc_free_symbol (sym);
3988 : 13536 : }
3989 : :
3990 : : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3991 : : Implemented as
3992 : : any(a)
3993 : : {
3994 : : forall (i=...)
3995 : : if (a[i] != 0)
3996 : : return 1
3997 : : end forall
3998 : : return 0
3999 : : }
4000 : : all(a)
4001 : : {
4002 : : forall (i=...)
4003 : : if (a[i] == 0)
4004 : : return 0
4005 : : end forall
4006 : : return 1
4007 : : }
4008 : : */
4009 : : static void
4010 : 37299 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4011 : : {
4012 : 37299 : tree resvar;
4013 : 37299 : stmtblock_t block;
4014 : 37299 : stmtblock_t body;
4015 : 37299 : tree type;
4016 : 37299 : tree tmp;
4017 : 37299 : tree found;
4018 : 37299 : gfc_loopinfo loop;
4019 : 37299 : gfc_actual_arglist *actual;
4020 : 37299 : gfc_ss *arrayss;
4021 : 37299 : gfc_se arrayse;
4022 : 37299 : tree exit_label;
4023 : :
4024 : 37299 : if (se->ss)
4025 : : {
4026 : 0 : gfc_conv_intrinsic_funcall (se, expr);
4027 : 0 : return;
4028 : : }
4029 : :
4030 : 37299 : actual = expr->value.function.actual;
4031 : 37299 : type = gfc_typenode_for_spec (&expr->ts);
4032 : : /* Initialize the result. */
4033 : 37299 : resvar = gfc_create_var (type, "test");
4034 : 37299 : if (op == EQ_EXPR)
4035 : 419 : tmp = convert (type, boolean_true_node);
4036 : : else
4037 : 36880 : tmp = convert (type, boolean_false_node);
4038 : 37299 : gfc_add_modify (&se->pre, resvar, tmp);
4039 : :
4040 : : /* Walk the arguments. */
4041 : 37299 : arrayss = gfc_walk_expr (actual->expr);
4042 : 37299 : gcc_assert (arrayss != gfc_ss_terminator);
4043 : :
4044 : : /* Initialize the scalarizer. */
4045 : 37299 : gfc_init_loopinfo (&loop);
4046 : 37299 : exit_label = gfc_build_label_decl (NULL_TREE);
4047 : 37299 : TREE_USED (exit_label) = 1;
4048 : 37299 : gfc_add_ss_to_loop (&loop, arrayss);
4049 : :
4050 : : /* Initialize the loop. */
4051 : 37299 : gfc_conv_ss_startstride (&loop);
4052 : 37299 : gfc_conv_loop_setup (&loop, &expr->where);
4053 : :
4054 : 37299 : gfc_mark_ss_chain_used (arrayss, 1);
4055 : : /* Generate the loop body. */
4056 : 37299 : gfc_start_scalarized_body (&loop, &body);
4057 : :
4058 : : /* If the condition matches then set the return value. */
4059 : 37299 : gfc_start_block (&block);
4060 : 37299 : if (op == EQ_EXPR)
4061 : 419 : tmp = convert (type, boolean_false_node);
4062 : : else
4063 : 36880 : tmp = convert (type, boolean_true_node);
4064 : 37299 : gfc_add_modify (&block, resvar, tmp);
4065 : :
4066 : : /* And break out of the loop. */
4067 : 37299 : tmp = build1_v (GOTO_EXPR, exit_label);
4068 : 37299 : gfc_add_expr_to_block (&block, tmp);
4069 : :
4070 : 37299 : found = gfc_finish_block (&block);
4071 : :
4072 : : /* Check this element. */
4073 : 37299 : gfc_init_se (&arrayse, NULL);
4074 : 37299 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4075 : 37299 : arrayse.ss = arrayss;
4076 : 37299 : gfc_conv_expr_val (&arrayse, actual->expr);
4077 : :
4078 : 37299 : gfc_add_block_to_block (&body, &arrayse.pre);
4079 : 37299 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4080 : 37299 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4081 : 37299 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4082 : 37299 : gfc_add_expr_to_block (&body, tmp);
4083 : 37299 : gfc_add_block_to_block (&body, &arrayse.post);
4084 : :
4085 : 37299 : gfc_trans_scalarizing_loops (&loop, &body);
4086 : :
4087 : : /* Add the exit label. */
4088 : 37299 : tmp = build1_v (LABEL_EXPR, exit_label);
4089 : 37299 : gfc_add_expr_to_block (&loop.pre, tmp);
4090 : :
4091 : 37299 : gfc_add_block_to_block (&se->pre, &loop.pre);
4092 : 37299 : gfc_add_block_to_block (&se->pre, &loop.post);
4093 : 37299 : gfc_cleanup_loop (&loop);
4094 : :
4095 : 37299 : se->expr = resvar;
4096 : : }
4097 : :
4098 : :
4099 : : /* Generate the constant 180 / pi, which is used in the conversion
4100 : : of acosd(), asind(), atand(), atan2d(). */
4101 : :
4102 : : static tree
4103 : 336 : rad2deg (int kind)
4104 : : {
4105 : 336 : tree retval;
4106 : 336 : mpfr_t pi, t0;
4107 : :
4108 : 336 : gfc_set_model_kind (kind);
4109 : 336 : mpfr_init (pi);
4110 : 336 : mpfr_init (t0);
4111 : 336 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4112 : 336 : mpfr_const_pi (pi, GFC_RND_MODE);
4113 : 336 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4114 : 336 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4115 : 336 : mpfr_clear (t0);
4116 : 336 : mpfr_clear (pi);
4117 : 336 : return retval;
4118 : : }
4119 : :
4120 : :
4121 : : static gfc_intrinsic_map_t *
4122 : 546 : gfc_lookup_intrinsic (gfc_isym_id id)
4123 : : {
4124 : 546 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4125 : 11154 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4126 : 11154 : if (id == m->id)
4127 : : break;
4128 : 546 : gcc_assert (id == m->id);
4129 : 546 : return m;
4130 : : }
4131 : :
4132 : :
4133 : : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4134 : : ASIND(x) is translated into ASIN(x) * 180 / pi.
4135 : : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4136 : :
4137 : : static void
4138 : 216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4139 : : {
4140 : 216 : tree arg;
4141 : 216 : tree atrigd;
4142 : 216 : tree type;
4143 : 216 : gfc_intrinsic_map_t *m;
4144 : :
4145 : 216 : type = gfc_typenode_for_spec (&expr->ts);
4146 : :
4147 : 216 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4148 : :
4149 : 216 : switch (id)
4150 : : {
4151 : 72 : case GFC_ISYM_ACOSD:
4152 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4153 : 72 : break;
4154 : 72 : case GFC_ISYM_ASIND:
4155 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4156 : 72 : break;
4157 : 72 : case GFC_ISYM_ATAND:
4158 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4159 : 72 : break;
4160 : 0 : default:
4161 : 0 : gcc_unreachable ();
4162 : : }
4163 : 216 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4164 : 216 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4165 : :
4166 : 216 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4167 : : fold_convert (type, rad2deg (expr->ts.kind)));
4168 : 216 : }
4169 : :
4170 : :
4171 : : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4172 : : COS(X) / SIN(X) for COMPLEX argument. */
4173 : :
4174 : : static void
4175 : 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4176 : : {
4177 : 102 : gfc_intrinsic_map_t *m;
4178 : 102 : tree arg;
4179 : 102 : tree type;
4180 : :
4181 : 102 : type = gfc_typenode_for_spec (&expr->ts);
4182 : 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4183 : :
4184 : 102 : if (expr->ts.type == BT_REAL)
4185 : : {
4186 : 102 : tree tan;
4187 : 102 : tree tmp;
4188 : 102 : mpfr_t pio2;
4189 : :
4190 : : /* Create pi/2. */
4191 : 102 : gfc_set_model_kind (expr->ts.kind);
4192 : 102 : mpfr_init (pio2);
4193 : 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4194 : 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4195 : 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4196 : 102 : mpfr_clear (pio2);
4197 : :
4198 : : /* Find tan builtin function. */
4199 : 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4200 : 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4201 : 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4202 : 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4203 : 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4204 : : }
4205 : : else
4206 : : {
4207 : 0 : tree sin;
4208 : 0 : tree cos;
4209 : :
4210 : : /* Find cos builtin function. */
4211 : 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4212 : 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4213 : 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4214 : :
4215 : : /* Find sin builtin function. */
4216 : 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4217 : 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4218 : 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4219 : :
4220 : : /* Divide cos by sin. */
4221 : 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4222 : : }
4223 : 102 : }
4224 : :
4225 : :
4226 : : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4227 : :
4228 : : static void
4229 : 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4230 : : {
4231 : 108 : tree arg;
4232 : 108 : tree type;
4233 : 108 : tree ninety_tree;
4234 : 108 : mpfr_t ninety;
4235 : :
4236 : 108 : type = gfc_typenode_for_spec (&expr->ts);
4237 : 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4238 : :
4239 : 108 : gfc_set_model_kind (expr->ts.kind);
4240 : :
4241 : : /* Build the tree for x + 90. */
4242 : 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4243 : 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4244 : 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4245 : 108 : mpfr_clear (ninety);
4246 : :
4247 : : /* Find tand. */
4248 : 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4249 : 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4250 : 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4251 : :
4252 : 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4253 : 108 : }
4254 : :
4255 : :
4256 : : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4257 : :
4258 : : static void
4259 : 120 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4260 : : {
4261 : 120 : tree args[2];
4262 : 120 : tree atan2d;
4263 : 120 : tree type;
4264 : :
4265 : 120 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4266 : 120 : type = TREE_TYPE (args[0]);
4267 : :
4268 : 120 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4269 : 120 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4270 : 120 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4271 : :
4272 : 120 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4273 : : rad2deg (expr->ts.kind));
4274 : 120 : }
4275 : :
4276 : :
4277 : : /* COUNT(A) = Number of true elements in A. */
4278 : : static void
4279 : 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4280 : : {
4281 : 143 : tree resvar;
4282 : 143 : tree type;
4283 : 143 : stmtblock_t body;
4284 : 143 : tree tmp;
4285 : 143 : gfc_loopinfo loop;
4286 : 143 : gfc_actual_arglist *actual;
4287 : 143 : gfc_ss *arrayss;
4288 : 143 : gfc_se arrayse;
4289 : :
4290 : 143 : if (se->ss)
4291 : : {
4292 : 0 : gfc_conv_intrinsic_funcall (se, expr);
4293 : 0 : return;
4294 : : }
4295 : :
4296 : 143 : actual = expr->value.function.actual;
4297 : :
4298 : 143 : type = gfc_typenode_for_spec (&expr->ts);
4299 : : /* Initialize the result. */
4300 : 143 : resvar = gfc_create_var (type, "count");
4301 : 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4302 : :
4303 : : /* Walk the arguments. */
4304 : 143 : arrayss = gfc_walk_expr (actual->expr);
4305 : 143 : gcc_assert (arrayss != gfc_ss_terminator);
4306 : :
4307 : : /* Initialize the scalarizer. */
4308 : 143 : gfc_init_loopinfo (&loop);
4309 : 143 : gfc_add_ss_to_loop (&loop, arrayss);
4310 : :
4311 : : /* Initialize the loop. */
4312 : 143 : gfc_conv_ss_startstride (&loop);
4313 : 143 : gfc_conv_loop_setup (&loop, &expr->where);
4314 : :
4315 : 143 : gfc_mark_ss_chain_used (arrayss, 1);
4316 : : /* Generate the loop body. */
4317 : 143 : gfc_start_scalarized_body (&loop, &body);
4318 : :
4319 : 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4320 : 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4321 : 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4322 : :
4323 : 143 : gfc_init_se (&arrayse, NULL);
4324 : 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4325 : 143 : arrayse.ss = arrayss;
4326 : 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4327 : 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4328 : : build_empty_stmt (input_location));
4329 : :
4330 : 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4331 : 143 : gfc_add_expr_to_block (&body, tmp);
4332 : 143 : gfc_add_block_to_block (&body, &arrayse.post);
4333 : :
4334 : 143 : gfc_trans_scalarizing_loops (&loop, &body);
4335 : :
4336 : 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4337 : 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4338 : 143 : gfc_cleanup_loop (&loop);
4339 : :
4340 : 143 : se->expr = resvar;
4341 : : }
4342 : :
4343 : :
4344 : : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4345 : : struct and return the corresponding loopinfo. */
4346 : :
4347 : : static gfc_loopinfo *
4348 : 3374 : enter_nested_loop (gfc_se *se)
4349 : : {
4350 : 3374 : se->ss = se->ss->nested_ss;
4351 : 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4352 : :
4353 : 3374 : return se->ss->loop;
4354 : : }
4355 : :
4356 : : /* Build the condition for a mask, which may be optional. */
4357 : :
4358 : : static tree
4359 : 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4360 : : bool optional_mask)
4361 : : {
4362 : 12763 : tree present;
4363 : 12763 : tree type;
4364 : :
4365 : 12763 : if (optional_mask)
4366 : : {
4367 : 206 : type = TREE_TYPE (maskse->expr);
4368 : 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4369 : 206 : present = convert (type, present);
4370 : 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4371 : : present);
4372 : 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4373 : 206 : type, present, maskse->expr);
4374 : : }
4375 : : else
4376 : 12557 : return maskse->expr;
4377 : : }
4378 : :
4379 : : /* Inline implementation of the sum and product intrinsics. */
4380 : : static void
4381 : 2499 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4382 : : bool norm2)
4383 : : {
4384 : 2499 : tree resvar;
4385 : 2499 : tree scale = NULL_TREE;
4386 : 2499 : tree type;
4387 : 2499 : stmtblock_t body;
4388 : 2499 : stmtblock_t block;
4389 : 2499 : tree tmp;
4390 : 2499 : gfc_loopinfo loop, *ploop;
4391 : 2499 : gfc_actual_arglist *arg_array, *arg_mask;
4392 : 2499 : gfc_ss *arrayss = NULL;
4393 : 2499 : gfc_ss *maskss = NULL;
4394 : 2499 : gfc_se arrayse;
4395 : 2499 : gfc_se maskse;
4396 : 2499 : gfc_se *parent_se;
4397 : 2499 : gfc_expr *arrayexpr;
4398 : 2499 : gfc_expr *maskexpr;
4399 : 2499 : bool optional_mask;
4400 : :
4401 : 2499 : if (expr->rank > 0)
4402 : : {
4403 : 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4404 : : parent_se = se;
4405 : : }
4406 : : else
4407 : : parent_se = NULL;
4408 : :
4409 : 2499 : type = gfc_typenode_for_spec (&expr->ts);
4410 : : /* Initialize the result. */
4411 : 2499 : resvar = gfc_create_var (type, "val");
4412 : 2499 : if (norm2)
4413 : : {
4414 : : /* result = 0.0;
4415 : : scale = 1.0. */
4416 : 68 : scale = gfc_create_var (type, "scale");
4417 : 68 : gfc_add_modify (&se->pre, scale,
4418 : : gfc_build_const (type, integer_one_node));
4419 : 68 : tmp = gfc_build_const (type, integer_zero_node);
4420 : : }
4421 : 2431 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4422 : 2027 : tmp = gfc_build_const (type, integer_zero_node);
4423 : 404 : else if (op == NE_EXPR)
4424 : : /* PARITY. */
4425 : 36 : tmp = convert (type, boolean_false_node);
4426 : 368 : else if (op == BIT_AND_EXPR)
4427 : 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4428 : : type, integer_one_node));
4429 : : else
4430 : 344 : tmp = gfc_build_const (type, integer_one_node);
4431 : :
4432 : 2499 : gfc_add_modify (&se->pre, resvar, tmp);
4433 : :
4434 : 2499 : arg_array = expr->value.function.actual;
4435 : :
4436 : 2499 : arrayexpr = arg_array->expr;
4437 : :
4438 : 2499 : if (op == NE_EXPR || norm2)
4439 : : {
4440 : : /* PARITY and NORM2. */
4441 : : maskexpr = NULL;
4442 : : optional_mask = false;
4443 : : }
4444 : : else
4445 : : {
4446 : 2395 : arg_mask = arg_array->next->next;
4447 : 2395 : gcc_assert (arg_mask != NULL);
4448 : 2395 : maskexpr = arg_mask->expr;
4449 : 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4450 : 266 : && maskexpr->symtree->n.sym->attr.dummy
4451 : 2413 : && maskexpr->symtree->n.sym->attr.optional;
4452 : : }
4453 : :
4454 : 2499 : if (expr->rank == 0)
4455 : : {
4456 : : /* Walk the arguments. */
4457 : 1921 : arrayss = gfc_walk_expr (arrayexpr);
4458 : 1921 : gcc_assert (arrayss != gfc_ss_terminator);
4459 : :
4460 : 1921 : if (maskexpr && maskexpr->rank > 0)
4461 : : {
4462 : 223 : maskss = gfc_walk_expr (maskexpr);
4463 : 223 : gcc_assert (maskss != gfc_ss_terminator);
4464 : : }
4465 : : else
4466 : : maskss = NULL;
4467 : :
4468 : : /* Initialize the scalarizer. */
4469 : 1921 : gfc_init_loopinfo (&loop);
4470 : :
4471 : : /* We add the mask first because the number of iterations is
4472 : : taken from the last ss, and this breaks if an absent
4473 : : optional argument is used for mask. */
4474 : :
4475 : 1921 : if (maskexpr && maskexpr->rank > 0)
4476 : 223 : gfc_add_ss_to_loop (&loop, maskss);
4477 : 1921 : gfc_add_ss_to_loop (&loop, arrayss);
4478 : :
4479 : : /* Initialize the loop. */
4480 : 1921 : gfc_conv_ss_startstride (&loop);
4481 : 1921 : gfc_conv_loop_setup (&loop, &expr->where);
4482 : :
4483 : 1921 : if (maskexpr && maskexpr->rank > 0)
4484 : 223 : gfc_mark_ss_chain_used (maskss, 1);
4485 : 1921 : gfc_mark_ss_chain_used (arrayss, 1);
4486 : :
4487 : 1921 : ploop = &loop;
4488 : : }
4489 : : else
4490 : : /* All the work has been done in the parent loops. */
4491 : 578 : ploop = enter_nested_loop (se);
4492 : :
4493 : 2499 : gcc_assert (ploop);
4494 : :
4495 : : /* Generate the loop body. */
4496 : 2499 : gfc_start_scalarized_body (ploop, &body);
4497 : :
4498 : : /* If we have a mask, only add this element if the mask is set. */
4499 : 2499 : if (maskexpr && maskexpr->rank > 0)
4500 : : {
4501 : 307 : gfc_init_se (&maskse, parent_se);
4502 : 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4503 : 307 : if (expr->rank == 0)
4504 : 223 : maskse.ss = maskss;
4505 : 307 : gfc_conv_expr_val (&maskse, maskexpr);
4506 : 307 : gfc_add_block_to_block (&body, &maskse.pre);
4507 : :
4508 : 307 : gfc_start_block (&block);
4509 : : }
4510 : : else
4511 : 2192 : gfc_init_block (&block);
4512 : :
4513 : : /* Do the actual summation/product. */
4514 : 2499 : gfc_init_se (&arrayse, parent_se);
4515 : 2499 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4516 : 2499 : if (expr->rank == 0)
4517 : 1921 : arrayse.ss = arrayss;
4518 : 2499 : gfc_conv_expr_val (&arrayse, arrayexpr);
4519 : 2499 : gfc_add_block_to_block (&block, &arrayse.pre);
4520 : :
4521 : 2499 : if (norm2)
4522 : : {
4523 : : /* if (x (i) != 0.0)
4524 : : {
4525 : : absX = abs(x(i))
4526 : : if (absX > scale)
4527 : : {
4528 : : val = scale/absX;
4529 : : result = 1.0 + result * val * val;
4530 : : scale = absX;
4531 : : }
4532 : : else
4533 : : {
4534 : : val = absX/scale;
4535 : : result += val * val;
4536 : : }
4537 : : } */
4538 : 68 : tree res1, res2, cond, absX, val;
4539 : 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4540 : :
4541 : 68 : gfc_init_block (&ifblock1);
4542 : :
4543 : 68 : absX = gfc_create_var (type, "absX");
4544 : 68 : gfc_add_modify (&ifblock1, absX,
4545 : : fold_build1_loc (input_location, ABS_EXPR, type,
4546 : : arrayse.expr));
4547 : 68 : val = gfc_create_var (type, "val");
4548 : 68 : gfc_add_expr_to_block (&ifblock1, val);
4549 : :
4550 : 68 : gfc_init_block (&ifblock2);
4551 : 68 : gfc_add_modify (&ifblock2, val,
4552 : : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4553 : : absX));
4554 : 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4555 : 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4556 : 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4557 : : gfc_build_const (type, integer_one_node));
4558 : 68 : gfc_add_modify (&ifblock2, resvar, res1);
4559 : 68 : gfc_add_modify (&ifblock2, scale, absX);
4560 : 68 : res1 = gfc_finish_block (&ifblock2);
4561 : :
4562 : 68 : gfc_init_block (&ifblock3);
4563 : 68 : gfc_add_modify (&ifblock3, val,
4564 : : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4565 : : scale));
4566 : 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4567 : 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4568 : 68 : gfc_add_modify (&ifblock3, resvar, res2);
4569 : 68 : res2 = gfc_finish_block (&ifblock3);
4570 : :
4571 : 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4572 : : absX, scale);
4573 : 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4574 : 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4575 : 68 : tmp = gfc_finish_block (&ifblock1);
4576 : :
4577 : 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4578 : : arrayse.expr,
4579 : : gfc_build_const (type, integer_zero_node));
4580 : :
4581 : 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4582 : 68 : gfc_add_expr_to_block (&block, tmp);
4583 : : }
4584 : : else
4585 : : {
4586 : 2431 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4587 : 2431 : gfc_add_modify (&block, resvar, tmp);
4588 : : }
4589 : :
4590 : 2499 : gfc_add_block_to_block (&block, &arrayse.post);
4591 : :
4592 : 2499 : if (maskexpr && maskexpr->rank > 0)
4593 : : {
4594 : : /* We enclose the above in if (mask) {...} . If the mask is an
4595 : : optional argument, generate
4596 : : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4597 : 307 : tree ifmask;
4598 : 307 : tmp = gfc_finish_block (&block);
4599 : 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4600 : 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4601 : : build_empty_stmt (input_location));
4602 : 307 : }
4603 : : else
4604 : 2192 : tmp = gfc_finish_block (&block);
4605 : 2499 : gfc_add_expr_to_block (&body, tmp);
4606 : :
4607 : 2499 : gfc_trans_scalarizing_loops (ploop, &body);
4608 : :
4609 : : /* For a scalar mask, enclose the loop in an if statement. */
4610 : 2499 : if (maskexpr && maskexpr->rank == 0)
4611 : : {
4612 : 64 : gfc_init_block (&block);
4613 : 64 : gfc_add_block_to_block (&block, &ploop->pre);
4614 : 64 : gfc_add_block_to_block (&block, &ploop->post);
4615 : 64 : tmp = gfc_finish_block (&block);
4616 : :
4617 : 64 : if (expr->rank > 0)
4618 : : {
4619 : 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4620 : : build_empty_stmt (input_location));
4621 : 34 : gfc_advance_se_ss_chain (se);
4622 : : }
4623 : : else
4624 : : {
4625 : 30 : tree ifmask;
4626 : :
4627 : 30 : gcc_assert (expr->rank == 0);
4628 : 30 : gfc_init_se (&maskse, NULL);
4629 : 30 : gfc_conv_expr_val (&maskse, maskexpr);
4630 : 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4631 : 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4632 : : build_empty_stmt (input_location));
4633 : : }
4634 : :
4635 : 64 : gfc_add_expr_to_block (&block, tmp);
4636 : 64 : gfc_add_block_to_block (&se->pre, &block);
4637 : 64 : gcc_assert (se->post.head == NULL);
4638 : : }
4639 : : else
4640 : : {
4641 : 2435 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4642 : 2435 : gfc_add_block_to_block (&se->pre, &ploop->post);
4643 : : }
4644 : :
4645 : 2499 : if (expr->rank == 0)
4646 : 1921 : gfc_cleanup_loop (ploop);
4647 : :
4648 : 2499 : if (norm2)
4649 : : {
4650 : : /* result = scale * sqrt(result). */
4651 : 68 : tree sqrt;
4652 : 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4653 : 68 : resvar = build_call_expr_loc (input_location,
4654 : : sqrt, 1, resvar);
4655 : 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4656 : : }
4657 : :
4658 : 2499 : se->expr = resvar;
4659 : 2499 : }
4660 : :
4661 : :
4662 : : /* Inline implementation of the dot_product intrinsic. This function
4663 : : is based on gfc_conv_intrinsic_arith (the previous function). */
4664 : : static void
4665 : 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4666 : : {
4667 : 113 : tree resvar;
4668 : 113 : tree type;
4669 : 113 : stmtblock_t body;
4670 : 113 : stmtblock_t block;
4671 : 113 : tree tmp;
4672 : 113 : gfc_loopinfo loop;
4673 : 113 : gfc_actual_arglist *actual;
4674 : 113 : gfc_ss *arrayss1, *arrayss2;
4675 : 113 : gfc_se arrayse1, arrayse2;
4676 : 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4677 : :
4678 : 113 : type = gfc_typenode_for_spec (&expr->ts);
4679 : :
4680 : : /* Initialize the result. */
4681 : 113 : resvar = gfc_create_var (type, "val");
4682 : 113 : if (expr->ts.type == BT_LOGICAL)
4683 : 30 : tmp = build_int_cst (type, 0);
4684 : : else
4685 : 83 : tmp = gfc_build_const (type, integer_zero_node);
4686 : :
4687 : 113 : gfc_add_modify (&se->pre, resvar, tmp);
4688 : :
4689 : : /* Walk argument #1. */
4690 : 113 : actual = expr->value.function.actual;
4691 : 113 : arrayexpr1 = actual->expr;
4692 : 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4693 : 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4694 : :
4695 : : /* Walk argument #2. */
4696 : 113 : actual = actual->next;
4697 : 113 : arrayexpr2 = actual->expr;
4698 : 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4699 : 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4700 : :
4701 : : /* Initialize the scalarizer. */
4702 : 113 : gfc_init_loopinfo (&loop);
4703 : 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4704 : 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4705 : :
4706 : : /* Initialize the loop. */
4707 : 113 : gfc_conv_ss_startstride (&loop);
4708 : 113 : gfc_conv_loop_setup (&loop, &expr->where);
4709 : :
4710 : 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4711 : 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4712 : :
4713 : : /* Generate the loop body. */
4714 : 113 : gfc_start_scalarized_body (&loop, &body);
4715 : 113 : gfc_init_block (&block);
4716 : :
4717 : : /* Make the tree expression for [conjg(]array1[)]. */
4718 : 113 : gfc_init_se (&arrayse1, NULL);
4719 : 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4720 : 113 : arrayse1.ss = arrayss1;
4721 : 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4722 : 113 : if (expr->ts.type == BT_COMPLEX)
4723 : 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4724 : : arrayse1.expr);
4725 : 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4726 : :
4727 : : /* Make the tree expression for array2. */
4728 : 113 : gfc_init_se (&arrayse2, NULL);
4729 : 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4730 : 113 : arrayse2.ss = arrayss2;
4731 : 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4732 : 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4733 : :
4734 : : /* Do the actual product and sum. */
4735 : 113 : if (expr->ts.type == BT_LOGICAL)
4736 : : {
4737 : 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4738 : : arrayse1.expr, arrayse2.expr);
4739 : 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4740 : : }
4741 : : else
4742 : : {
4743 : 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4744 : : arrayse2.expr);
4745 : 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4746 : : }
4747 : 113 : gfc_add_modify (&block, resvar, tmp);
4748 : :
4749 : : /* Finish up the loop block and the loop. */
4750 : 113 : tmp = gfc_finish_block (&block);
4751 : 113 : gfc_add_expr_to_block (&body, tmp);
4752 : :
4753 : 113 : gfc_trans_scalarizing_loops (&loop, &body);
4754 : 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4755 : 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4756 : 113 : gfc_cleanup_loop (&loop);
4757 : :
4758 : 113 : se->expr = resvar;
4759 : 113 : }
4760 : :
4761 : :
4762 : : /* Tells whether the expression E is a reference to an optional variable whose
4763 : : presence is not known at compile time. Those are variable references without
4764 : : subreference; if there is a subreference, we can assume the variable is
4765 : : present. We have to special case full arrays, which we represent with a fake
4766 : : "full" reference, and class descriptors for which a reference to data is not
4767 : : really a subreference. */
4768 : :
4769 : : bool
4770 : 14613 : maybe_absent_optional_variable (gfc_expr *e)
4771 : : {
4772 : 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4773 : : return false;
4774 : :
4775 : 1716 : gfc_symbol *sym = e->symtree->n.sym;
4776 : 1716 : if (!sym->attr.optional)
4777 : : return false;
4778 : :
4779 : 224 : gfc_ref *ref = e->ref;
4780 : 224 : if (ref == nullptr)
4781 : : return true;
4782 : :
4783 : 20 : if (ref->type == REF_ARRAY
4784 : 20 : && ref->u.ar.type == AR_FULL
4785 : 20 : && ref->next == nullptr)
4786 : : return true;
4787 : :
4788 : 0 : if (!(sym->ts.type == BT_CLASS
4789 : 0 : && ref->type == REF_COMPONENT
4790 : 0 : && ref->u.c.component == CLASS_DATA (sym)))
4791 : : return false;
4792 : :
4793 : 0 : gfc_ref *next_ref = ref->next;
4794 : 0 : if (next_ref == nullptr)
4795 : : return true;
4796 : :
4797 : 0 : if (next_ref->type == REF_ARRAY
4798 : 0 : && next_ref->u.ar.type == AR_FULL
4799 : 0 : && next_ref->next == nullptr)
4800 : 0 : return true;
4801 : :
4802 : : return false;
4803 : : }
4804 : :
4805 : :
4806 : : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4807 : : we need to handle. For performance reasons we sometimes create two
4808 : : loops instead of one, where the second one is much simpler.
4809 : : Examples for minloc intrinsic:
4810 : : A: Result is scalar.
4811 : : 1) Array mask is used and NaNs need to be supported:
4812 : : limit = Infinity;
4813 : : pos = 0;
4814 : : S = from;
4815 : : while (S <= to) {
4816 : : if (mask[S]) {
4817 : : if (pos == 0) pos = S + (1 - from);
4818 : : if (a[S] <= limit) {
4819 : : limit = a[S];
4820 : : pos = S + (1 - from);
4821 : : goto lab1;
4822 : : }
4823 : : }
4824 : : S++;
4825 : : }
4826 : : goto lab2;
4827 : : lab1:;
4828 : : while (S <= to) {
4829 : : if (mask[S])
4830 : : if (a[S] < limit) {
4831 : : limit = a[S];
4832 : : pos = S + (1 - from);
4833 : : }
4834 : : S++;
4835 : : }
4836 : : lab2:;
4837 : : 2) NaNs need to be supported, but it is known at compile time or cheaply
4838 : : at runtime whether array is nonempty or not:
4839 : : limit = Infinity;
4840 : : pos = 0;
4841 : : S = from;
4842 : : while (S <= to) {
4843 : : if (a[S] <= limit) {
4844 : : limit = a[S];
4845 : : pos = S + (1 - from);
4846 : : goto lab1;
4847 : : }
4848 : : S++;
4849 : : }
4850 : : if (from <= to) pos = 1;
4851 : : goto lab2;
4852 : : lab1:;
4853 : : while (S <= to) {
4854 : : if (a[S] < limit) {
4855 : : limit = a[S];
4856 : : pos = S + (1 - from);
4857 : : }
4858 : : S++;
4859 : : }
4860 : : lab2:;
4861 : : 3) NaNs aren't supported, array mask is used:
4862 : : limit = infinities_supported ? Infinity : huge (limit);
4863 : : pos = 0;
4864 : : S = from;
4865 : : while (S <= to) {
4866 : : if (mask[S]) {
4867 : : limit = a[S];
4868 : : pos = S + (1 - from);
4869 : : goto lab1;
4870 : : }
4871 : : S++;
4872 : : }
4873 : : goto lab2;
4874 : : lab1:;
4875 : : while (S <= to) {
4876 : : if (mask[S])
4877 : : if (a[S] < limit) {
4878 : : limit = a[S];
4879 : : pos = S + (1 - from);
4880 : : }
4881 : : S++;
4882 : : }
4883 : : lab2:;
4884 : : 4) Same without array mask:
4885 : : limit = infinities_supported ? Infinity : huge (limit);
4886 : : pos = (from <= to) ? 1 : 0;
4887 : : S = from;
4888 : : while (S <= to) {
4889 : : if (a[S] < limit) {
4890 : : limit = a[S];
4891 : : pos = S + (1 - from);
4892 : : }
4893 : : S++;
4894 : : }
4895 : : B: Array result, non-CHARACTER type, DIM absent
4896 : : Generate similar code as in the scalar case, using a collection of
4897 : : variables (one per dimension) instead of a single variable as result.
4898 : : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4899 : : becomes:
4900 : : 1) Array mask is used and NaNs need to be supported:
4901 : : limit = Infinity;
4902 : : pos0 = 0;
4903 : : pos1 = 0;
4904 : : S1 = from1;
4905 : : second_loop_entry = false;
4906 : : while (S1 <= to1) {
4907 : : S0 = from0;
4908 : : while (s0 <= to0 {
4909 : : if (mask[S1][S0]) {
4910 : : if (pos0 == 0) {
4911 : : pos0 = S0 + (1 - from0);
4912 : : pos1 = S1 + (1 - from1);
4913 : : }
4914 : : if (a[S1][S0] <= limit) {
4915 : : limit = a[S1][S0];
4916 : : pos0 = S0 + (1 - from0);
4917 : : pos1 = S1 + (1 - from1);
4918 : : second_loop_entry = true;
4919 : : goto lab1;
4920 : : }
4921 : : }
4922 : : S0++;
4923 : : }
4924 : : S1++;
4925 : : }
4926 : : goto lab2;
4927 : : lab1:;
4928 : : S1 = second_loop_entry ? S1 : from1;
4929 : : while (S1 <= to1) {
4930 : : S0 = second_loop_entry ? S0 : from0;
4931 : : while (S0 <= to0) {
4932 : : if (mask[S1][S0])
4933 : : if (a[S1][S0] < limit) {
4934 : : limit = a[S1][S0];
4935 : : pos0 = S + (1 - from0);
4936 : : pos1 = S + (1 - from1);
4937 : : }
4938 : : second_loop_entry = false;
4939 : : S0++;
4940 : : }
4941 : : S1++;
4942 : : }
4943 : : lab2:;
4944 : : result = { pos0, pos1 };
4945 : : ...
4946 : : 4) NANs aren't supported, no array mask.
4947 : : limit = infinities_supported ? Infinity : huge (limit);
4948 : : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4949 : : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4950 : : S1 = from1;
4951 : : while (S1 <= to1) {
4952 : : S0 = from0;
4953 : : while (S0 <= to0) {
4954 : : if (a[S1][S0] < limit) {
4955 : : limit = a[S1][S0];
4956 : : pos0 = S + (1 - from0);
4957 : : pos1 = S + (1 - from1);
4958 : : }
4959 : : S0++;
4960 : : }
4961 : : S1++;
4962 : : }
4963 : : result = { pos0, pos1 };
4964 : : C: Otherwise, a call is generated.
4965 : : For 2) and 4), if mask is scalar, this all goes into a conditional,
4966 : : setting pos = 0; in the else branch.
4967 : :
4968 : : Since we now also support the BACK argument, instead of using
4969 : : if (a[S] < limit), we now use
4970 : :
4971 : : if (back)
4972 : : cond = a[S] <= limit;
4973 : : else
4974 : : cond = a[S] < limit;
4975 : : if (cond) {
4976 : : ....
4977 : :
4978 : : The optimizer is smart enough to move the condition out of the loop.
4979 : : They are now marked as unlikely too for further speedup. */
4980 : :
4981 : : static void
4982 : 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4983 : : {
4984 : 18898 : stmtblock_t body;
4985 : 18898 : stmtblock_t block;
4986 : 18898 : stmtblock_t ifblock;
4987 : 18898 : stmtblock_t elseblock;
4988 : 18898 : tree limit;
4989 : 18898 : tree type;
4990 : 18898 : tree tmp;
4991 : 18898 : tree cond;
4992 : 18898 : tree elsetmp;
4993 : 18898 : tree ifbody;
4994 : 18898 : tree offset[GFC_MAX_DIMENSIONS];
4995 : 18898 : tree nonempty;
4996 : 18898 : tree lab1, lab2;
4997 : 18898 : tree b_if, b_else;
4998 : 18898 : tree back;
4999 : 18898 : gfc_loopinfo loop, *ploop;
5000 : 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5001 : 18898 : gfc_actual_arglist *back_arg;
5002 : 18898 : gfc_ss *arrayss = nullptr;
5003 : 18898 : gfc_ss *maskss = nullptr;
5004 : 18898 : gfc_ss *orig_ss = nullptr;
5005 : 18898 : gfc_se arrayse;
5006 : 18898 : gfc_se maskse;
5007 : 18898 : gfc_se nested_se;
5008 : 18898 : gfc_se *base_se;
5009 : 18898 : gfc_expr *arrayexpr;
5010 : 18898 : gfc_expr *maskexpr;
5011 : 18898 : gfc_expr *backexpr;
5012 : 18898 : gfc_se backse;
5013 : 18898 : tree pos[GFC_MAX_DIMENSIONS];
5014 : 18898 : tree idx[GFC_MAX_DIMENSIONS];
5015 : 18898 : tree result_var = NULL_TREE;
5016 : 18898 : int n;
5017 : 18898 : bool optional_mask;
5018 : :
5019 : 18898 : array_arg = expr->value.function.actual;
5020 : 18898 : dim_arg = array_arg->next;
5021 : 18898 : mask_arg = dim_arg->next;
5022 : 18898 : kind_arg = mask_arg->next;
5023 : 18898 : back_arg = kind_arg->next;
5024 : :
5025 : 18898 : bool dim_present = dim_arg->expr != nullptr;
5026 : 18898 : bool nested_loop = dim_present && expr->rank > 0;
5027 : :
5028 : : /* Remove kind. */
5029 : 18898 : if (kind_arg->expr)
5030 : : {
5031 : 2240 : gfc_free_expr (kind_arg->expr);
5032 : 2240 : kind_arg->expr = NULL;
5033 : : }
5034 : :
5035 : : /* Pass BACK argument by value. */
5036 : 18898 : back_arg->name = "%VAL";
5037 : :
5038 : 18898 : if (se->ss)
5039 : : {
5040 : 14732 : if (se->ss->info->useflags)
5041 : : {
5042 : 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5043 : : {
5044 : : /* The code generating and initializing the result array has been
5045 : : generated already before the scalarization loop, either with a
5046 : : library function call or with inline code; now we can just use
5047 : : the result. */
5048 : 4875 : gfc_conv_tmp_array_ref (se);
5049 : 13822 : return;
5050 : : }
5051 : : }
5052 : 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5053 : : {
5054 : 3780 : gfc_conv_intrinsic_funcall (se, expr);
5055 : 3780 : return;
5056 : : }
5057 : : }
5058 : :
5059 : 10243 : arrayexpr = array_arg->expr;
5060 : :
5061 : : /* Special case for character maxloc. Remove unneeded "dim" actual
5062 : : argument, then call a library function. */
5063 : :
5064 : 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5065 : : {
5066 : 292 : gcc_assert (expr->rank == 0);
5067 : :
5068 : 292 : if (dim_arg->expr)
5069 : : {
5070 : 292 : gfc_free_expr (dim_arg->expr);
5071 : 292 : dim_arg->expr = NULL;
5072 : : }
5073 : 292 : gfc_conv_intrinsic_funcall (se, expr);
5074 : 292 : return;
5075 : : }
5076 : :
5077 : 9951 : type = gfc_typenode_for_spec (&expr->ts);
5078 : :
5079 : 9951 : if (expr->rank > 0 && !dim_present)
5080 : : {
5081 : 3281 : gfc_array_spec as;
5082 : 3281 : memset (&as, 0, sizeof (as));
5083 : :
5084 : 3281 : as.rank = 1;
5085 : 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5086 : : &arrayexpr->where,
5087 : : HOST_WIDE_INT_1);
5088 : 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5089 : : &arrayexpr->where,
5090 : 3281 : arrayexpr->rank);
5091 : :
5092 : 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5093 : :
5094 : 3281 : result_var = gfc_create_var (array, "loc_result");
5095 : : }
5096 : :
5097 : 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5098 : :
5099 : : /* Initialize the result. */
5100 : 22177 : for (int i = 0; i < reduction_dimensions; i++)
5101 : : {
5102 : 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5103 : : gfc_get_string ("pos%d", i));
5104 : 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5105 : : gfc_get_string ("offset%d", i));
5106 : 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5107 : : gfc_get_string ("idx%d", i));
5108 : : }
5109 : :
5110 : 9951 : maskexpr = mask_arg->expr;
5111 : 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5112 : 5329 : && maskexpr->symtree->n.sym->attr.dummy
5113 : 10116 : && maskexpr->symtree->n.sym->attr.optional;
5114 : 9951 : backexpr = back_arg->expr;
5115 : :
5116 : 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5117 : 9951 : if (backexpr == nullptr)
5118 : 0 : back = logical_false_node;
5119 : 9951 : else if (maybe_absent_optional_variable (backexpr))
5120 : : {
5121 : : /* This should have been checked already by
5122 : : maybe_absent_optional_variable. */
5123 : 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5124 : :
5125 : 184 : gfc_conv_expr (&backse, backexpr);
5126 : 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5127 : 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5128 : : logical_type_node, present, backse.expr);
5129 : : }
5130 : : else
5131 : : {
5132 : 9767 : gfc_conv_expr (&backse, backexpr);
5133 : 9767 : back = backse.expr;
5134 : : }
5135 : 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5136 : 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5137 : 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5138 : :
5139 : 9951 : if (nested_loop)
5140 : : {
5141 : 2796 : gfc_init_se (&nested_se, se);
5142 : 2796 : base_se = &nested_se;
5143 : : }
5144 : : else
5145 : : {
5146 : : /* Walk the arguments. */
5147 : 7155 : arrayss = gfc_walk_expr (arrayexpr);
5148 : 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5149 : :
5150 : 7155 : if (maskexpr && maskexpr->rank != 0)
5151 : : {
5152 : 2700 : maskss = gfc_walk_expr (maskexpr);
5153 : 2700 : gcc_assert (maskss != gfc_ss_terminator);
5154 : : }
5155 : :
5156 : : base_se = nullptr;
5157 : : }
5158 : :
5159 : 18091 : nonempty = nullptr;
5160 : 7448 : if (!(maskexpr && maskexpr->rank > 0))
5161 : : {
5162 : 6077 : mpz_t asize;
5163 : 6077 : bool reduction_size_known;
5164 : :
5165 : 6077 : if (dim_present)
5166 : : {
5167 : 4032 : int reduction_dim;
5168 : 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5169 : 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5170 : 2 : else if (arrayexpr->rank == 1)
5171 : : reduction_dim = 0;
5172 : : else
5173 : 0 : gcc_unreachable ();
5174 : 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5175 : : &asize);
5176 : : }
5177 : : else
5178 : 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5179 : :
5180 : 6077 : if (reduction_size_known)
5181 : : {
5182 : 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5183 : 4482 : mpz_clear (asize);
5184 : 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5185 : : logical_type_node, nonempty,
5186 : : gfc_index_zero_node);
5187 : : }
5188 : 6077 : maskss = NULL;
5189 : : }
5190 : :
5191 : 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5192 : 9951 : switch (arrayexpr->ts.type)
5193 : : {
5194 : 3898 : case BT_REAL:
5195 : 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5196 : 3898 : break;
5197 : :
5198 : 6029 : case BT_INTEGER:
5199 : 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5200 : 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5201 : : arrayexpr->ts.kind);
5202 : 6029 : break;
5203 : :
5204 : 24 : case BT_UNSIGNED:
5205 : : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5206 : 24 : if (op == GT_EXPR)
5207 : : {
5208 : 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5209 : 12 : tmp = build_int_cst (tmp, 0);
5210 : : }
5211 : : else
5212 : : {
5213 : 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5214 : 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5215 : : expr->ts.kind);
5216 : : }
5217 : : break;
5218 : :
5219 : 0 : default:
5220 : 0 : gcc_unreachable ();
5221 : : }
5222 : :
5223 : : /* We start with the most negative possible value for MAXLOC, and the most
5224 : : positive possible value for MINLOC. The most negative possible value is
5225 : : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5226 : : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5227 : : with above. */
5228 : 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5229 : 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5230 : 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5231 : 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5232 : 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5233 : :
5234 : 9951 : gfc_add_modify (&se->pre, limit, tmp);
5235 : :
5236 : : /* If we are in a case where we generate two sets of loops, the second one
5237 : : should continue where the first stopped instead of restarting from the
5238 : : beginning. So nested loops in the second set should have a partial range
5239 : : on the first iteration, but they should start from the beginning and span
5240 : : their full range on the following iterations. So we use conditionals in
5241 : : the loops lower bounds, and use the following variable in those
5242 : : conditionals to decide whether to use the original loop bound or to use
5243 : : the index at which the loop from the first set stopped. */
5244 : 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5245 : : "second_loop_entry");
5246 : 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5247 : :
5248 : 9951 : if (nested_loop)
5249 : : {
5250 : 2796 : ploop = enter_nested_loop (&nested_se);
5251 : 2796 : orig_ss = nested_se.ss;
5252 : 2796 : ploop->temp_dim = 1;
5253 : : }
5254 : : else
5255 : : {
5256 : : /* Initialize the scalarizer. */
5257 : 7155 : gfc_init_loopinfo (&loop);
5258 : :
5259 : : /* We add the mask first because the number of iterations is taken
5260 : : from the last ss, and this breaks if an absent optional argument
5261 : : is used for mask. */
5262 : :
5263 : 7155 : if (maskss)
5264 : 2700 : gfc_add_ss_to_loop (&loop, maskss);
5265 : :
5266 : 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5267 : :
5268 : : /* Initialize the loop. */
5269 : 7155 : gfc_conv_ss_startstride (&loop);
5270 : :
5271 : : /* The code generated can have more than one loop in sequence (see the
5272 : : comment at the function header). This doesn't work well with the
5273 : : scalarizer, which changes arrays' offset when the scalarization loops
5274 : : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5275 : : the scalarizer temporary code to handle multiple loops. Thus, we set
5276 : : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5277 : : we use gfc_trans_scalarized_loop_boundary even later to restore
5278 : : offset. */
5279 : 7155 : loop.temp_dim = loop.dimen;
5280 : 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5281 : :
5282 : 7155 : ploop = &loop;
5283 : : }
5284 : :
5285 : 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5286 : :
5287 : 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5288 : : {
5289 : 1595 : nonempty = logical_true_node;
5290 : :
5291 : 3697 : for (int i = 0; i < ploop->dimen; i++)
5292 : : {
5293 : 2102 : if (!(ploop->from[i] && ploop->to[i]))
5294 : : {
5295 : : nonempty = NULL;
5296 : : break;
5297 : : }
5298 : :
5299 : 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5300 : : logical_type_node, ploop->from[i],
5301 : : ploop->to[i]);
5302 : :
5303 : 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5304 : : logical_type_node, nonempty, tmp);
5305 : : }
5306 : : }
5307 : :
5308 : 11546 : lab1 = NULL;
5309 : 11546 : lab2 = NULL;
5310 : : /* Initialize the position to zero, following Fortran 2003. We are free
5311 : : to do this because Fortran 95 allows the result of an entirely false
5312 : : mask to be processor dependent. If we know at compile time the array
5313 : : is non-empty and no MASK is used, we can initialize to 1 to simplify
5314 : : the inner loop. */
5315 : 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5316 : : {
5317 : 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5318 : : gfc_array_index_type, nonempty,
5319 : : gfc_index_one_node,
5320 : : gfc_index_zero_node);
5321 : 8430 : for (int i = 0; i < ploop->dimen; i++)
5322 : 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5323 : : }
5324 : : else
5325 : : {
5326 : 13747 : for (int i = 0; i < ploop->dimen; i++)
5327 : 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5328 : 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5329 : 6203 : TREE_USED (lab1) = 1;
5330 : 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5331 : 6203 : TREE_USED (lab2) = 1;
5332 : : }
5333 : :
5334 : : /* An offset must be added to the loop
5335 : : counter to obtain the required position. */
5336 : 22177 : for (int i = 0; i < ploop->dimen; i++)
5337 : : {
5338 : 12226 : gcc_assert (ploop->from[i]);
5339 : :
5340 : 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5341 : : gfc_index_one_node, ploop->from[i]);
5342 : 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5343 : : }
5344 : :
5345 : 9951 : if (!nested_loop)
5346 : : {
5347 : 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5348 : 7155 : if (maskss)
5349 : 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5350 : : }
5351 : :
5352 : : /* Generate the loop body. */
5353 : 9951 : gfc_start_scalarized_body (ploop, &body);
5354 : :
5355 : : /* If we have a mask, only check this element if the mask is set. */
5356 : 9951 : if (maskexpr && maskexpr->rank > 0)
5357 : : {
5358 : 3874 : gfc_init_se (&maskse, base_se);
5359 : 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5360 : 3874 : if (!nested_loop)
5361 : 2700 : maskse.ss = maskss;
5362 : 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5363 : 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5364 : :
5365 : 3874 : gfc_start_block (&block);
5366 : : }
5367 : : else
5368 : 6077 : gfc_init_block (&block);
5369 : :
5370 : : /* Compare with the current limit. */
5371 : 9951 : gfc_init_se (&arrayse, base_se);
5372 : 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5373 : 9951 : if (!nested_loop)
5374 : 7155 : arrayse.ss = arrayss;
5375 : 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5376 : 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5377 : :
5378 : : /* We do the following if this is a more extreme value. */
5379 : 9951 : gfc_start_block (&ifblock);
5380 : :
5381 : : /* Assign the value to the limit... */
5382 : 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5383 : :
5384 : 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5385 : : {
5386 : 1569 : stmtblock_t ifblock2;
5387 : 1569 : tree ifbody2;
5388 : :
5389 : 1569 : gfc_start_block (&ifblock2);
5390 : 3439 : for (int i = 0; i < ploop->dimen; i++)
5391 : : {
5392 : 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5393 : : ploop->loopvar[i], offset[i]);
5394 : 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5395 : : }
5396 : 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5397 : :
5398 : 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5399 : : pos[0], gfc_index_zero_node);
5400 : 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5401 : : build_empty_stmt (input_location));
5402 : 1569 : gfc_add_expr_to_block (&block, tmp);
5403 : : }
5404 : :
5405 : 22177 : for (int i = 0; i < ploop->dimen; i++)
5406 : : {
5407 : 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5408 : : ploop->loopvar[i], offset[i]);
5409 : 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5410 : 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5411 : : }
5412 : :
5413 : 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5414 : :
5415 : 9951 : if (lab1)
5416 : 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5417 : :
5418 : 9951 : ifbody = gfc_finish_block (&ifblock);
5419 : :
5420 : 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5421 : : {
5422 : 7646 : if (lab1)
5423 : 5998 : cond = fold_build2_loc (input_location,
5424 : : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5425 : : logical_type_node, arrayse.expr, limit);
5426 : : else
5427 : : {
5428 : 3748 : tree ifbody2, elsebody2;
5429 : :
5430 : : /* We switch to > or >= depending on the value of the BACK argument. */
5431 : 3748 : cond = gfc_create_var (logical_type_node, "cond");
5432 : :
5433 : 3748 : gfc_start_block (&ifblock);
5434 : 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5435 : : logical_type_node, arrayse.expr, limit);
5436 : :
5437 : 3748 : gfc_add_modify (&ifblock, cond, b_if);
5438 : 3748 : ifbody2 = gfc_finish_block (&ifblock);
5439 : :
5440 : 3748 : gfc_start_block (&elseblock);
5441 : 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5442 : : arrayse.expr, limit);
5443 : :
5444 : 3748 : gfc_add_modify (&elseblock, cond, b_else);
5445 : 3748 : elsebody2 = gfc_finish_block (&elseblock);
5446 : :
5447 : 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5448 : : back, ifbody2, elsebody2);
5449 : :
5450 : 3748 : gfc_add_expr_to_block (&block, tmp);
5451 : : }
5452 : :
5453 : 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5454 : 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5455 : : build_empty_stmt (input_location));
5456 : : }
5457 : 9951 : gfc_add_expr_to_block (&block, ifbody);
5458 : :
5459 : 9951 : if (maskexpr && maskexpr->rank > 0)
5460 : : {
5461 : : /* We enclose the above in if (mask) {...}. If the mask is an
5462 : : optional argument, generate IF (.NOT. PRESENT(MASK)
5463 : : .OR. MASK(I)). */
5464 : :
5465 : 3874 : tree ifmask;
5466 : 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5467 : 3874 : tmp = gfc_finish_block (&block);
5468 : 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5469 : : build_empty_stmt (input_location));
5470 : 3874 : }
5471 : : else
5472 : 6077 : tmp = gfc_finish_block (&block);
5473 : 9951 : gfc_add_expr_to_block (&body, tmp);
5474 : :
5475 : 9951 : if (lab1)
5476 : : {
5477 : 13747 : for (int i = 0; i < ploop->dimen; i++)
5478 : 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5479 : 7544 : TREE_TYPE (ploop->from[i]),
5480 : : second_loop_entry, idx[i],
5481 : : ploop->from[i]);
5482 : :
5483 : 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5484 : :
5485 : 6203 : if (nested_loop)
5486 : : {
5487 : : /* The first loop already advanced the parent se'ss chain, so clear
5488 : : the parent now to avoid doing it a second time, making the chain
5489 : : out of sync. */
5490 : 1858 : nested_se.parent = nullptr;
5491 : 1858 : nested_se.ss = orig_ss;
5492 : : }
5493 : :
5494 : 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5495 : :
5496 : 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5497 : : {
5498 : 3898 : if (nonempty != NULL)
5499 : : {
5500 : 2329 : stmtblock_t init_block;
5501 : 2329 : gfc_init_block (&init_block);
5502 : :
5503 : 5229 : for (int i = 0; i < ploop->dimen; i++)
5504 : 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5505 : :
5506 : 2329 : tree ifbody = gfc_finish_block (&init_block);
5507 : 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5508 : : build_empty_stmt (input_location));
5509 : 2329 : gfc_add_expr_to_block (outer_block, tmp);
5510 : : }
5511 : : }
5512 : :
5513 : 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5514 : 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5515 : :
5516 : : /* If we have a mask, only check this element if the mask is set. */
5517 : 6203 : if (maskexpr && maskexpr->rank > 0)
5518 : : {
5519 : 3874 : gfc_init_se (&maskse, base_se);
5520 : 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5521 : 3874 : if (!nested_loop)
5522 : 2700 : maskse.ss = maskss;
5523 : 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5524 : 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5525 : :
5526 : 3874 : gfc_start_block (&block);
5527 : : }
5528 : : else
5529 : 2329 : gfc_init_block (&block);
5530 : :
5531 : : /* Compare with the current limit. */
5532 : 6203 : gfc_init_se (&arrayse, base_se);
5533 : 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5534 : 6203 : if (!nested_loop)
5535 : 4345 : arrayse.ss = arrayss;
5536 : 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5537 : 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5538 : :
5539 : : /* We do the following if this is a more extreme value. */
5540 : 6203 : gfc_start_block (&ifblock);
5541 : :
5542 : : /* Assign the value to the limit... */
5543 : 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5544 : :
5545 : 13747 : for (int i = 0; i < ploop->dimen; i++)
5546 : : {
5547 : 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5548 : : ploop->loopvar[i], offset[i]);
5549 : 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5550 : : }
5551 : :
5552 : 6203 : ifbody = gfc_finish_block (&ifblock);
5553 : :
5554 : : /* We switch to > or >= depending on the value of the BACK argument. */
5555 : 6203 : {
5556 : 6203 : tree ifbody2, elsebody2;
5557 : :
5558 : 6203 : cond = gfc_create_var (logical_type_node, "cond");
5559 : :
5560 : 6203 : gfc_start_block (&ifblock);
5561 : 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5562 : : logical_type_node, arrayse.expr, limit);
5563 : :
5564 : 6203 : gfc_add_modify (&ifblock, cond, b_if);
5565 : 6203 : ifbody2 = gfc_finish_block (&ifblock);
5566 : :
5567 : 6203 : gfc_start_block (&elseblock);
5568 : 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5569 : : arrayse.expr, limit);
5570 : :
5571 : 6203 : gfc_add_modify (&elseblock, cond, b_else);
5572 : 6203 : elsebody2 = gfc_finish_block (&elseblock);
5573 : :
5574 : 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5575 : : back, ifbody2, elsebody2);
5576 : : }
5577 : :
5578 : 6203 : gfc_add_expr_to_block (&block, tmp);
5579 : 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5580 : 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5581 : : build_empty_stmt (input_location));
5582 : :
5583 : 6203 : gfc_add_expr_to_block (&block, tmp);
5584 : :
5585 : 6203 : if (maskexpr && maskexpr->rank > 0)
5586 : : {
5587 : : /* We enclose the above in if (mask) {...}. If the mask is
5588 : : an optional argument, generate IF (.NOT. PRESENT(MASK)
5589 : : .OR. MASK(I)).*/
5590 : :
5591 : 3874 : tree ifmask;
5592 : 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5593 : 3874 : tmp = gfc_finish_block (&block);
5594 : 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5595 : : build_empty_stmt (input_location));
5596 : 3874 : }
5597 : : else
5598 : 2329 : tmp = gfc_finish_block (&block);
5599 : :
5600 : 6203 : gfc_add_expr_to_block (&body, tmp);
5601 : 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5602 : : }
5603 : :
5604 : 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5605 : :
5606 : 9951 : if (lab2)
5607 : 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5608 : :
5609 : : /* For a scalar mask, enclose the loop in an if statement. */
5610 : 9951 : if (maskexpr && maskexpr->rank == 0)
5611 : : {
5612 : 2644 : tree ifmask;
5613 : :
5614 : 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5615 : 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5616 : 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5617 : 2644 : gfc_init_block (&block);
5618 : 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5619 : 2644 : gfc_add_block_to_block (&block, &ploop->post);
5620 : 2644 : tmp = gfc_finish_block (&block);
5621 : :
5622 : : /* For the else part of the scalar mask, just initialize
5623 : : the pos variable the same way as above. */
5624 : :
5625 : 2644 : gfc_init_block (&elseblock);
5626 : 5580 : for (int i = 0; i < ploop->dimen; i++)
5627 : 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5628 : 2644 : elsetmp = gfc_finish_block (&elseblock);
5629 : 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5630 : 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5631 : 2644 : gfc_add_expr_to_block (&block, tmp);
5632 : 2644 : gfc_add_block_to_block (&se->pre, &block);
5633 : 2644 : }
5634 : : else
5635 : : {
5636 : 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5637 : 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5638 : : }
5639 : :
5640 : 9951 : if (!nested_loop)
5641 : 7155 : gfc_cleanup_loop (&loop);
5642 : :
5643 : 9951 : if (!dim_present)
5644 : : {
5645 : 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5646 : : {
5647 : 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5648 : 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5649 : : NULL_TREE, true);
5650 : :
5651 : 5556 : tree value = convert (type, pos[i]);
5652 : 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5653 : : }
5654 : :
5655 : 3281 : se->expr = result_var;
5656 : : }
5657 : : else
5658 : 6670 : se->expr = convert (type, pos[0]);
5659 : : }
5660 : :
5661 : : /* Emit code for findloc. */
5662 : :
5663 : : static void
5664 : 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5665 : : {
5666 : 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5667 : : *kind_arg, *back_arg;
5668 : 1332 : gfc_expr *value_expr;
5669 : 1332 : int ikind;
5670 : 1332 : tree resvar;
5671 : 1332 : stmtblock_t block;
5672 : 1332 : stmtblock_t body;
5673 : 1332 : stmtblock_t loopblock;
5674 : 1332 : tree type;
5675 : 1332 : tree tmp;
5676 : 1332 : tree found;
5677 : 1332 : tree forward_branch = NULL_TREE;
5678 : 1332 : tree back_branch;
5679 : 1332 : gfc_loopinfo loop;
5680 : 1332 : gfc_ss *arrayss;
5681 : 1332 : gfc_ss *maskss;
5682 : 1332 : gfc_se arrayse;
5683 : 1332 : gfc_se valuese;
5684 : 1332 : gfc_se maskse;
5685 : 1332 : gfc_se backse;
5686 : 1332 : tree exit_label;
5687 : 1332 : gfc_expr *maskexpr;
5688 : 1332 : tree offset;
5689 : 1332 : int i;
5690 : 1332 : bool optional_mask;
5691 : :
5692 : 1332 : array_arg = expr->value.function.actual;
5693 : 1332 : value_arg = array_arg->next;
5694 : 1332 : dim_arg = value_arg->next;
5695 : 1332 : mask_arg = dim_arg->next;
5696 : 1332 : kind_arg = mask_arg->next;
5697 : 1332 : back_arg = kind_arg->next;
5698 : :
5699 : : /* Remove kind and set ikind. */
5700 : 1332 : if (kind_arg->expr)
5701 : : {
5702 : 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5703 : 0 : gfc_free_expr (kind_arg->expr);
5704 : 0 : kind_arg->expr = NULL;
5705 : : }
5706 : : else
5707 : 1332 : ikind = gfc_default_integer_kind;
5708 : :
5709 : 1332 : value_expr = value_arg->expr;
5710 : :
5711 : : /* Unless it's a string, pass VALUE by value. */
5712 : 1332 : if (value_expr->ts.type != BT_CHARACTER)
5713 : 732 : value_arg->name = "%VAL";
5714 : :
5715 : : /* Pass BACK argument by value. */
5716 : 1332 : back_arg->name = "%VAL";
5717 : :
5718 : : /* Call the library if we have a character function or if
5719 : : rank > 0. */
5720 : 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5721 : : {
5722 : 1200 : se->ignore_optional = 1;
5723 : 1200 : if (expr->rank == 0)
5724 : : {
5725 : : /* Remove dim argument. */
5726 : 84 : gfc_free_expr (dim_arg->expr);
5727 : 84 : dim_arg->expr = NULL;
5728 : : }
5729 : 1200 : gfc_conv_intrinsic_funcall (se, expr);
5730 : 1200 : return;
5731 : : }
5732 : :
5733 : 132 : type = gfc_get_int_type (ikind);
5734 : :
5735 : : /* Initialize the result. */
5736 : 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5737 : 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5738 : 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5739 : :
5740 : 132 : maskexpr = mask_arg->expr;
5741 : 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5742 : 60 : && maskexpr->symtree->n.sym->attr.dummy
5743 : 144 : && maskexpr->symtree->n.sym->attr.optional;
5744 : :
5745 : : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5746 : :
5747 : 396 : for (i = 0 ; i < 2; i++)
5748 : : {
5749 : : /* Walk the arguments. */
5750 : 264 : arrayss = gfc_walk_expr (array_arg->expr);
5751 : 264 : gcc_assert (arrayss != gfc_ss_terminator);
5752 : :
5753 : 264 : if (maskexpr && maskexpr->rank != 0)
5754 : : {
5755 : 84 : maskss = gfc_walk_expr (maskexpr);
5756 : 84 : gcc_assert (maskss != gfc_ss_terminator);
5757 : : }
5758 : : else
5759 : : maskss = NULL;
5760 : :
5761 : : /* Initialize the scalarizer. */
5762 : 264 : gfc_init_loopinfo (&loop);
5763 : 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5764 : 264 : TREE_USED (exit_label) = 1;
5765 : :
5766 : : /* We add the mask first because the number of iterations is
5767 : : taken from the last ss, and this breaks if an absent
5768 : : optional argument is used for mask. */
5769 : :
5770 : 264 : if (maskss)
5771 : 84 : gfc_add_ss_to_loop (&loop, maskss);
5772 : 264 : gfc_add_ss_to_loop (&loop, arrayss);
5773 : :
5774 : : /* Initialize the loop. */
5775 : 264 : gfc_conv_ss_startstride (&loop);
5776 : 264 : gfc_conv_loop_setup (&loop, &expr->where);
5777 : :
5778 : : /* Calculate the offset. */
5779 : 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5780 : : gfc_index_one_node, loop.from[0]);
5781 : 264 : gfc_add_modify (&loop.pre, offset, tmp);
5782 : :
5783 : 264 : gfc_mark_ss_chain_used (arrayss, 1);
5784 : 264 : if (maskss)
5785 : 84 : gfc_mark_ss_chain_used (maskss, 1);
5786 : :
5787 : : /* The first loop is for BACK=.true. */
5788 : 264 : if (i == 0)
5789 : 132 : loop.reverse[0] = GFC_REVERSE_SET;
5790 : :
5791 : : /* Generate the loop body. */
5792 : 264 : gfc_start_scalarized_body (&loop, &body);
5793 : :
5794 : : /* If we have an array mask, only add the element if it is
5795 : : set. */
5796 : 264 : if (maskss)
5797 : : {
5798 : 84 : gfc_init_se (&maskse, NULL);
5799 : 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5800 : 84 : maskse.ss = maskss;
5801 : 84 : gfc_conv_expr_val (&maskse, maskexpr);
5802 : 84 : gfc_add_block_to_block (&body, &maskse.pre);
5803 : : }
5804 : :
5805 : : /* If the condition matches then set the return value. */
5806 : 264 : gfc_start_block (&block);
5807 : :
5808 : : /* Add the offset. */
5809 : 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5810 : 264 : TREE_TYPE (resvar),
5811 : : loop.loopvar[0], offset);
5812 : 264 : gfc_add_modify (&block, resvar, tmp);
5813 : : /* And break out of the loop. */
5814 : 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5815 : 264 : gfc_add_expr_to_block (&block, tmp);
5816 : :
5817 : 264 : found = gfc_finish_block (&block);
5818 : :
5819 : : /* Check this element. */
5820 : 264 : gfc_init_se (&arrayse, NULL);
5821 : 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5822 : 264 : arrayse.ss = arrayss;
5823 : 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5824 : 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5825 : :
5826 : 264 : gfc_init_se (&valuese, NULL);
5827 : 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5828 : 264 : gfc_add_block_to_block (&body, &valuese.pre);
5829 : :
5830 : 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5831 : : arrayse.expr, valuese.expr);
5832 : :
5833 : 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5834 : 264 : if (maskss)
5835 : : {
5836 : : /* We enclose the above in if (mask) {...}. If the mask is
5837 : : an optional argument, generate IF (.NOT. PRESENT(MASK)
5838 : : .OR. MASK(I)). */
5839 : :
5840 : 84 : tree ifmask;
5841 : 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5842 : 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5843 : : build_empty_stmt (input_location));
5844 : : }
5845 : :
5846 : 264 : gfc_add_expr_to_block (&body, tmp);
5847 : 264 : gfc_add_block_to_block (&body, &arrayse.post);
5848 : :
5849 : 264 : gfc_trans_scalarizing_loops (&loop, &body);
5850 : :
5851 : : /* Add the exit label. */
5852 : 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5853 : 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5854 : 264 : gfc_start_block (&loopblock);
5855 : 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5856 : 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5857 : 264 : if (i == 0)
5858 : 132 : forward_branch = gfc_finish_block (&loopblock);
5859 : : else
5860 : 132 : back_branch = gfc_finish_block (&loopblock);
5861 : :
5862 : 264 : gfc_cleanup_loop (&loop);
5863 : : }
5864 : :
5865 : : /* Enclose the two loops in an IF statement. */
5866 : :
5867 : 132 : gfc_init_se (&backse, NULL);
5868 : 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5869 : 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5870 : 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5871 : :
5872 : : /* For a scalar mask, enclose the loop in an if statement. */
5873 : 132 : if (maskexpr && maskss == NULL)
5874 : : {
5875 : 30 : tree ifmask;
5876 : 30 : tree if_stmt;
5877 : :
5878 : 30 : gfc_init_se (&maskse, NULL);
5879 : 30 : gfc_conv_expr_val (&maskse, maskexpr);
5880 : 30 : gfc_init_block (&block);
5881 : 30 : gfc_add_expr_to_block (&block, maskse.expr);
5882 : 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5883 : 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5884 : : build_empty_stmt (input_location));
5885 : 30 : gfc_add_expr_to_block (&block, if_stmt);
5886 : 30 : tmp = gfc_finish_block (&block);
5887 : : }
5888 : :
5889 : 132 : gfc_add_expr_to_block (&se->pre, tmp);
5890 : 132 : se->expr = convert (type, resvar);
5891 : :
5892 : : }
5893 : :
5894 : : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5895 : :
5896 : : static tree
5897 : 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5898 : : {
5899 : 55 : stmtblock_t block;
5900 : 55 : gfc_se se, se_stat;
5901 : 55 : tree unit = NULL_TREE;
5902 : 55 : tree name = NULL_TREE;
5903 : 55 : tree slen = NULL_TREE;
5904 : 55 : tree vals;
5905 : 55 : tree arg3 = NULL_TREE;
5906 : 55 : tree stat = NULL_TREE ;
5907 : 55 : tree present = NULL_TREE;
5908 : 55 : tree tmp;
5909 : 55 : int kind;
5910 : :
5911 : 55 : gfc_init_block (&block);
5912 : 55 : gfc_init_se (&se, NULL);
5913 : :
5914 : 55 : switch (code->resolved_isym->id)
5915 : : {
5916 : 21 : case GFC_ISYM_FSTAT:
5917 : : /* Deal with the UNIT argument. */
5918 : 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5919 : 21 : gfc_add_block_to_block (&block, &se.pre);
5920 : 21 : unit = gfc_evaluate_now (se.expr, &block);
5921 : 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5922 : 21 : gfc_add_block_to_block (&block, &se.post);
5923 : 21 : break;
5924 : :
5925 : 34 : case GFC_ISYM_LSTAT:
5926 : 34 : case GFC_ISYM_STAT:
5927 : : /* Deal with the NAME argument. */
5928 : 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5929 : 34 : gfc_conv_string_parameter (&se);
5930 : 34 : gfc_add_block_to_block (&block, &se.pre);
5931 : 34 : name = se.expr;
5932 : 34 : slen = se.string_length;
5933 : 34 : gfc_add_block_to_block (&block, &se.post);
5934 : 34 : break;
5935 : :
5936 : 0 : default:
5937 : 0 : gcc_unreachable ();
5938 : : }
5939 : :
5940 : : /* Deal with the VALUES argument. */
5941 : 55 : gfc_init_se (&se, NULL);
5942 : 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5943 : 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5944 : 55 : gfc_add_block_to_block (&block, &se.pre);
5945 : 55 : gfc_add_block_to_block (&block, &se.post);
5946 : 55 : kind = code->ext.actual->next->expr->ts.kind;
5947 : :
5948 : : /* Deal with an optional STATUS. */
5949 : 55 : if (code->ext.actual->next->next->expr)
5950 : : {
5951 : 45 : gfc_init_se (&se_stat, NULL);
5952 : 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5953 : 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5954 : 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5955 : :
5956 : : /* Handle case of status being an optional dummy. */
5957 : 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5958 : 45 : if (sym->attr.dummy && sym->attr.optional)
5959 : : {
5960 : 6 : present = gfc_conv_expr_present (sym);
5961 : 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
5962 : 6 : TREE_TYPE (arg3), present, arg3,
5963 : 6 : fold_convert (TREE_TYPE (arg3),
5964 : : null_pointer_node));
5965 : : }
5966 : : }
5967 : :
5968 : : /* Call library function depending on KIND of VALUES argument. */
5969 : 55 : switch (code->resolved_isym->id)
5970 : : {
5971 : 21 : case GFC_ISYM_FSTAT:
5972 : 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
5973 : : break;
5974 : 14 : case GFC_ISYM_LSTAT:
5975 : 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
5976 : : break;
5977 : 20 : case GFC_ISYM_STAT:
5978 : 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
5979 : : break;
5980 : 0 : default:
5981 : 0 : gcc_unreachable ();
5982 : : }
5983 : :
5984 : 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
5985 : 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
5986 : : stat ? arg3 : null_pointer_node);
5987 : : else
5988 : 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
5989 : : stat ? arg3 : null_pointer_node, slen);
5990 : 55 : gfc_add_expr_to_block (&block, tmp);
5991 : :
5992 : : /* Handle kind conversion of status. */
5993 : 55 : if (stat && stat != se_stat.expr)
5994 : : {
5995 : 45 : stmtblock_t block2;
5996 : :
5997 : 45 : gfc_init_block (&block2);
5998 : 45 : gfc_add_modify (&block2, se_stat.expr,
5999 : 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6000 : :
6001 : 45 : if (present)
6002 : : {
6003 : 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6004 : : build_empty_stmt (input_location));
6005 : 6 : gfc_add_expr_to_block (&block, tmp);
6006 : : }
6007 : : else
6008 : 39 : gfc_add_block_to_block (&block, &block2);
6009 : : }
6010 : :
6011 : 55 : return gfc_finish_block (&block);
6012 : : }
6013 : :
6014 : : /* Emit code for minval or maxval intrinsic. There are many different cases
6015 : : we need to handle. For performance reasons we sometimes create two
6016 : : loops instead of one, where the second one is much simpler.
6017 : : Examples for minval intrinsic:
6018 : : 1) Result is an array, a call is generated
6019 : : 2) Array mask is used and NaNs need to be supported, rank 1:
6020 : : limit = Infinity;
6021 : : nonempty = false;
6022 : : S = from;
6023 : : while (S <= to) {
6024 : : if (mask[S]) {
6025 : : nonempty = true;
6026 : : if (a[S] <= limit) {
6027 : : limit = a[S];
6028 : : S++;
6029 : : goto lab;
6030 : : }
6031 : : else
6032 : : S++;
6033 : : }
6034 : : }
6035 : : limit = nonempty ? NaN : huge (limit);
6036 : : lab:
6037 : : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6038 : : 3) NaNs need to be supported, but it is known at compile time or cheaply
6039 : : at runtime whether array is nonempty or not, rank 1:
6040 : : limit = Infinity;
6041 : : S = from;
6042 : : while (S <= to) {
6043 : : if (a[S] <= limit) {
6044 : : limit = a[S];
6045 : : S++;
6046 : : goto lab;
6047 : : }
6048 : : else
6049 : : S++;
6050 : : }
6051 : : limit = (from <= to) ? NaN : huge (limit);
6052 : : lab:
6053 : : while (S <= to) { limit = min (a[S], limit); S++; }
6054 : : 4) Array mask is used and NaNs need to be supported, rank > 1:
6055 : : limit = Infinity;
6056 : : nonempty = false;
6057 : : fast = false;
6058 : : S1 = from1;
6059 : : while (S1 <= to1) {
6060 : : S2 = from2;
6061 : : while (S2 <= to2) {
6062 : : if (mask[S1][S2]) {
6063 : : if (fast) limit = min (a[S1][S2], limit);
6064 : : else {
6065 : : nonempty = true;
6066 : : if (a[S1][S2] <= limit) {
6067 : : limit = a[S1][S2];
6068 : : fast = true;
6069 : : }
6070 : : }
6071 : : }
6072 : : S2++;
6073 : : }
6074 : : S1++;
6075 : : }
6076 : : if (!fast)
6077 : : limit = nonempty ? NaN : huge (limit);
6078 : : 5) NaNs need to be supported, but it is known at compile time or cheaply
6079 : : at runtime whether array is nonempty or not, rank > 1:
6080 : : limit = Infinity;
6081 : : fast = false;
6082 : : S1 = from1;
6083 : : while (S1 <= to1) {
6084 : : S2 = from2;
6085 : : while (S2 <= to2) {
6086 : : if (fast) limit = min (a[S1][S2], limit);
6087 : : else {
6088 : : if (a[S1][S2] <= limit) {
6089 : : limit = a[S1][S2];
6090 : : fast = true;
6091 : : }
6092 : : }
6093 : : S2++;
6094 : : }
6095 : : S1++;
6096 : : }
6097 : : if (!fast)
6098 : : limit = (nonempty_array) ? NaN : huge (limit);
6099 : : 6) NaNs aren't supported, but infinities are. Array mask is used:
6100 : : limit = Infinity;
6101 : : nonempty = false;
6102 : : S = from;
6103 : : while (S <= to) {
6104 : : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6105 : : S++;
6106 : : }
6107 : : limit = nonempty ? limit : huge (limit);
6108 : : 7) Same without array mask:
6109 : : limit = Infinity;
6110 : : S = from;
6111 : : while (S <= to) { limit = min (a[S], limit); S++; }
6112 : : limit = (from <= to) ? limit : huge (limit);
6113 : : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6114 : : limit = huge (limit);
6115 : : S = from;
6116 : : while (S <= to) { limit = min (a[S], limit); S++); }
6117 : : (or
6118 : : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6119 : : with array mask instead).
6120 : : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6121 : : setting limit = huge (limit); in the else branch. */
6122 : :
6123 : : static void
6124 : 2416 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6125 : : {
6126 : 2416 : tree limit;
6127 : 2416 : tree type;
6128 : 2416 : tree tmp;
6129 : 2416 : tree ifbody;
6130 : 2416 : tree nonempty;
6131 : 2416 : tree nonempty_var;
6132 : 2416 : tree lab;
6133 : 2416 : tree fast;
6134 : 2416 : tree huge_cst = NULL, nan_cst = NULL;
6135 : 2416 : stmtblock_t body;
6136 : 2416 : stmtblock_t block, block2;
6137 : 2416 : gfc_loopinfo loop;
6138 : 2416 : gfc_actual_arglist *actual;
6139 : 2416 : gfc_ss *arrayss;
6140 : 2416 : gfc_ss *maskss;
6141 : 2416 : gfc_se arrayse;
6142 : 2416 : gfc_se maskse;
6143 : 2416 : gfc_expr *arrayexpr;
6144 : 2416 : gfc_expr *maskexpr;
6145 : 2416 : int n;
6146 : 2416 : bool optional_mask;
6147 : :
6148 : 2416 : if (se->ss)
6149 : : {
6150 : 0 : gfc_conv_intrinsic_funcall (se, expr);
6151 : 186 : return;
6152 : : }
6153 : :
6154 : 2416 : actual = expr->value.function.actual;
6155 : 2416 : arrayexpr = actual->expr;
6156 : :
6157 : 2416 : if (arrayexpr->ts.type == BT_CHARACTER)
6158 : : {
6159 : 186 : gfc_actual_arglist *dim = actual->next;
6160 : 186 : if (expr->rank == 0 && dim->expr != 0)
6161 : : {
6162 : 6 : gfc_free_expr (dim->expr);
6163 : 6 : dim->expr = NULL;
6164 : : }
6165 : 186 : gfc_conv_intrinsic_funcall (se, expr);
6166 : 186 : return;
6167 : : }
6168 : :
6169 : 2230 : type = gfc_typenode_for_spec (&expr->ts);
6170 : : /* Initialize the result. */
6171 : 2230 : limit = gfc_create_var (type, "limit");
6172 : 2230 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6173 : 2230 : switch (expr->ts.type)
6174 : : {
6175 : 1245 : case BT_REAL:
6176 : 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6177 : : expr->ts.kind, 0);
6178 : 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6179 : : {
6180 : 1241 : REAL_VALUE_TYPE real;
6181 : 1241 : real_inf (&real);
6182 : 1241 : tmp = build_real (type, real);
6183 : : }
6184 : : else
6185 : : tmp = huge_cst;
6186 : 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6187 : 1241 : nan_cst = gfc_build_nan (type, "");
6188 : : break;
6189 : :
6190 : 955 : case BT_INTEGER:
6191 : 955 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6192 : 955 : break;
6193 : :
6194 : 30 : case BT_UNSIGNED:
6195 : : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6196 : 30 : if (op == GT_EXPR)
6197 : 18 : tmp = build_int_cst (type, 0);
6198 : : else
6199 : 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6200 : : expr->ts.kind);
6201 : : break;
6202 : :
6203 : 0 : default:
6204 : 0 : gcc_unreachable ();
6205 : : }
6206 : :
6207 : : /* We start with the most negative possible value for MAXVAL, and the most
6208 : : positive possible value for MINVAL. The most negative possible value is
6209 : : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6210 : : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6211 : : with above. */
6212 : 2230 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6213 : : {
6214 : 986 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6215 : 986 : if (huge_cst)
6216 : 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6217 : 560 : TREE_TYPE (huge_cst), huge_cst);
6218 : : }
6219 : :
6220 : 1004 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6221 : 426 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6222 : : tmp, build_int_cst (type, 1));
6223 : :
6224 : 2230 : gfc_add_modify (&se->pre, limit, tmp);
6225 : :
6226 : : /* Walk the arguments. */
6227 : 2230 : arrayss = gfc_walk_expr (arrayexpr);
6228 : 2230 : gcc_assert (arrayss != gfc_ss_terminator);
6229 : :
6230 : 2230 : actual = actual->next->next;
6231 : 2230 : gcc_assert (actual);
6232 : 2230 : maskexpr = actual->expr;
6233 : 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6234 : 1560 : && maskexpr->symtree->n.sym->attr.dummy
6235 : 2242 : && maskexpr->symtree->n.sym->attr.optional;
6236 : 1560 : nonempty = NULL;
6237 : 1572 : if (maskexpr && maskexpr->rank != 0)
6238 : : {
6239 : 1026 : maskss = gfc_walk_expr (maskexpr);
6240 : 1026 : gcc_assert (maskss != gfc_ss_terminator);
6241 : : }
6242 : : else
6243 : : {
6244 : 1204 : mpz_t asize;
6245 : 1204 : if (gfc_array_size (arrayexpr, &asize))
6246 : : {
6247 : 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6248 : 678 : mpz_clear (asize);
6249 : 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6250 : : logical_type_node, nonempty,
6251 : : gfc_index_zero_node);
6252 : : }
6253 : 1204 : maskss = NULL;
6254 : : }
6255 : :
6256 : : /* Initialize the scalarizer. */
6257 : 2230 : gfc_init_loopinfo (&loop);
6258 : :
6259 : : /* We add the mask first because the number of iterations is taken
6260 : : from the last ss, and this breaks if an absent optional argument
6261 : : is used for mask. */
6262 : :
6263 : 2230 : if (maskss)
6264 : 1026 : gfc_add_ss_to_loop (&loop, maskss);
6265 : 2230 : gfc_add_ss_to_loop (&loop, arrayss);
6266 : :
6267 : : /* Initialize the loop. */
6268 : 2230 : gfc_conv_ss_startstride (&loop);
6269 : :
6270 : : /* The code generated can have more than one loop in sequence (see the
6271 : : comment at the function header). This doesn't work well with the
6272 : : scalarizer, which changes arrays' offset when the scalarization loops
6273 : : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6274 : : are currently inlined in the scalar case only. As there is no dependency
6275 : : to care about in that case, there is no temporary, so that we can use the
6276 : : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6277 : : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6278 : : gfc_trans_scalarized_loop_boundary even later to restore offset.
6279 : : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6280 : : should eventually go away. We could either create two loops properly,
6281 : : or find another way to save/restore the array offsets between the two
6282 : : loops (without conflicting with temporary management), or use a single
6283 : : loop minmaxval implementation. See PR 31067. */
6284 : 2230 : loop.temp_dim = loop.dimen;
6285 : 2230 : gfc_conv_loop_setup (&loop, &expr->where);
6286 : :
6287 : 2230 : if (nonempty == NULL && maskss == NULL
6288 : 526 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6289 : 490 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6290 : : loop.from[0], loop.to[0]);
6291 : 2230 : nonempty_var = NULL;
6292 : 2230 : if (nonempty == NULL
6293 : 2230 : && (HONOR_INFINITIES (DECL_MODE (limit))
6294 : 480 : || HONOR_NANS (DECL_MODE (limit))))
6295 : : {
6296 : 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6297 : 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6298 : 582 : nonempty = nonempty_var;
6299 : : }
6300 : 2230 : lab = NULL;
6301 : 2230 : fast = NULL;
6302 : 2230 : if (HONOR_NANS (DECL_MODE (limit)))
6303 : : {
6304 : 1241 : if (loop.dimen == 1)
6305 : : {
6306 : 821 : lab = gfc_build_label_decl (NULL_TREE);
6307 : 821 : TREE_USED (lab) = 1;
6308 : : }
6309 : : else
6310 : : {
6311 : 420 : fast = gfc_create_var (logical_type_node, "fast");
6312 : 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6313 : : }
6314 : : }
6315 : :
6316 : 2230 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6317 : 2230 : if (maskss)
6318 : 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6319 : : /* Generate the loop body. */
6320 : 2230 : gfc_start_scalarized_body (&loop, &body);
6321 : :
6322 : : /* If we have a mask, only add this element if the mask is set. */
6323 : 2230 : if (maskss)
6324 : : {
6325 : 1026 : gfc_init_se (&maskse, NULL);
6326 : 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6327 : 1026 : maskse.ss = maskss;
6328 : 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6329 : 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6330 : :
6331 : 1026 : gfc_start_block (&block);
6332 : : }
6333 : : else
6334 : 1204 : gfc_init_block (&block);
6335 : :
6336 : : /* Compare with the current limit. */
6337 : 2230 : gfc_init_se (&arrayse, NULL);
6338 : 2230 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6339 : 2230 : arrayse.ss = arrayss;
6340 : 2230 : gfc_conv_expr_val (&arrayse, arrayexpr);
6341 : 2230 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6342 : 2230 : gfc_add_block_to_block (&block, &arrayse.pre);
6343 : :
6344 : 2230 : gfc_init_block (&block2);
6345 : :
6346 : 2230 : if (nonempty_var)
6347 : 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6348 : :
6349 : 2230 : if (HONOR_NANS (DECL_MODE (limit)))
6350 : : {
6351 : 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6352 : : logical_type_node, arrayse.expr, limit);
6353 : 1241 : if (lab)
6354 : : {
6355 : 821 : stmtblock_t ifblock;
6356 : 821 : tree inc_loop;
6357 : 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6358 : 821 : TREE_TYPE (loop.loopvar[0]),
6359 : : loop.loopvar[0], gfc_index_one_node);
6360 : 821 : gfc_init_block (&ifblock);
6361 : 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6362 : 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6363 : 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6364 : 821 : ifbody = gfc_finish_block (&ifblock);
6365 : : }
6366 : : else
6367 : : {
6368 : 420 : stmtblock_t ifblock;
6369 : :
6370 : 420 : gfc_init_block (&ifblock);
6371 : 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6372 : 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6373 : 420 : ifbody = gfc_finish_block (&ifblock);
6374 : : }
6375 : 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6376 : : build_empty_stmt (input_location));
6377 : 1241 : gfc_add_expr_to_block (&block2, tmp);
6378 : : }
6379 : : else
6380 : : {
6381 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6382 : : signed zeros. */
6383 : 1534 : tmp = fold_build2_loc (input_location,
6384 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6385 : : type, arrayse.expr, limit);
6386 : 989 : gfc_add_modify (&block2, limit, tmp);
6387 : : }
6388 : :
6389 : 2230 : if (fast)
6390 : : {
6391 : 420 : tree elsebody = gfc_finish_block (&block2);
6392 : :
6393 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6394 : : signed zeros. */
6395 : 420 : if (HONOR_NANS (DECL_MODE (limit)))
6396 : : {
6397 : 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6398 : : arrayse.expr, limit);
6399 : 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6400 : 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6401 : : build_empty_stmt (input_location));
6402 : : }
6403 : : else
6404 : : {
6405 : 0 : tmp = fold_build2_loc (input_location,
6406 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6407 : : type, arrayse.expr, limit);
6408 : 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6409 : : }
6410 : 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6411 : 420 : gfc_add_expr_to_block (&block, tmp);
6412 : : }
6413 : : else
6414 : 1810 : gfc_add_block_to_block (&block, &block2);
6415 : :
6416 : 2230 : gfc_add_block_to_block (&block, &arrayse.post);
6417 : :
6418 : 2230 : tmp = gfc_finish_block (&block);
6419 : 2230 : if (maskss)
6420 : : {
6421 : : /* We enclose the above in if (mask) {...}. If the mask is an
6422 : : optional argument, generate IF (.NOT. PRESENT(MASK)
6423 : : .OR. MASK(I)). */
6424 : 1026 : tree ifmask;
6425 : 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6426 : 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6427 : : build_empty_stmt (input_location));
6428 : : }
6429 : 2230 : gfc_add_expr_to_block (&body, tmp);
6430 : :
6431 : 2230 : if (lab)
6432 : : {
6433 : 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6434 : :
6435 : 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6436 : : nan_cst, huge_cst);
6437 : 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6438 : 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6439 : :
6440 : : /* If we have a mask, only add this element if the mask is set. */
6441 : 821 : if (maskss)
6442 : : {
6443 : 348 : gfc_init_se (&maskse, NULL);
6444 : 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6445 : 348 : maskse.ss = maskss;
6446 : 348 : gfc_conv_expr_val (&maskse, maskexpr);
6447 : 348 : gfc_add_block_to_block (&body, &maskse.pre);
6448 : :
6449 : 348 : gfc_start_block (&block);
6450 : : }
6451 : : else
6452 : 473 : gfc_init_block (&block);
6453 : :
6454 : : /* Compare with the current limit. */
6455 : 821 : gfc_init_se (&arrayse, NULL);
6456 : 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6457 : 821 : arrayse.ss = arrayss;
6458 : 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6459 : 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6460 : 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6461 : :
6462 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6463 : : signed zeros. */
6464 : 821 : if (HONOR_NANS (DECL_MODE (limit)))
6465 : : {
6466 : 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6467 : : arrayse.expr, limit);
6468 : 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6469 : 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6470 : : build_empty_stmt (input_location));
6471 : 821 : gfc_add_expr_to_block (&block, tmp);
6472 : : }
6473 : : else
6474 : : {
6475 : 0 : tmp = fold_build2_loc (input_location,
6476 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6477 : : type, arrayse.expr, limit);
6478 : 0 : gfc_add_modify (&block, limit, tmp);
6479 : : }
6480 : :
6481 : 821 : gfc_add_block_to_block (&block, &arrayse.post);
6482 : :
6483 : 821 : tmp = gfc_finish_block (&block);
6484 : 821 : if (maskss)
6485 : : /* We enclose the above in if (mask) {...}. */
6486 : : {
6487 : 348 : tree ifmask;
6488 : 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6489 : 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6490 : : build_empty_stmt (input_location));
6491 : : }
6492 : :
6493 : 821 : gfc_add_expr_to_block (&body, tmp);
6494 : : /* Avoid initializing loopvar[0] again, it should be left where
6495 : : it finished by the first loop. */
6496 : 821 : loop.from[0] = loop.loopvar[0];
6497 : : }
6498 : 2230 : gfc_trans_scalarizing_loops (&loop, &body);
6499 : :
6500 : 2230 : if (fast)
6501 : : {
6502 : 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6503 : : nan_cst, huge_cst);
6504 : 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6505 : 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6506 : : ifbody);
6507 : 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6508 : : }
6509 : 1810 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6510 : : {
6511 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6512 : : huge_cst);
6513 : 0 : gfc_add_modify (&loop.pre, limit, tmp);
6514 : : }
6515 : :
6516 : : /* For a scalar mask, enclose the loop in an if statement. */
6517 : 2230 : if (maskexpr && maskss == NULL)
6518 : : {
6519 : 546 : tree else_stmt;
6520 : 546 : tree ifmask;
6521 : :
6522 : 546 : gfc_init_se (&maskse, NULL);
6523 : 546 : gfc_conv_expr_val (&maskse, maskexpr);
6524 : 546 : gfc_init_block (&block);
6525 : 546 : gfc_add_block_to_block (&block, &loop.pre);
6526 : 546 : gfc_add_block_to_block (&block, &loop.post);
6527 : 546 : tmp = gfc_finish_block (&block);
6528 : :
6529 : 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6530 : 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6531 : : else
6532 : 192 : else_stmt = build_empty_stmt (input_location);
6533 : :
6534 : 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6535 : 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6536 : 546 : gfc_add_expr_to_block (&block, tmp);
6537 : 546 : gfc_add_block_to_block (&se->pre, &block);
6538 : : }
6539 : : else
6540 : : {
6541 : 1684 : gfc_add_block_to_block (&se->pre, &loop.pre);
6542 : 1684 : gfc_add_block_to_block (&se->pre, &loop.post);
6543 : : }
6544 : :
6545 : 2230 : gfc_cleanup_loop (&loop);
6546 : :
6547 : 2230 : se->expr = limit;
6548 : : }
6549 : :
6550 : : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6551 : : static void
6552 : 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6553 : : {
6554 : 145 : tree args[2];
6555 : 145 : tree type;
6556 : 145 : tree tmp;
6557 : :
6558 : 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6559 : 145 : type = TREE_TYPE (args[0]);
6560 : :
6561 : : /* Optionally generate code for runtime argument check. */
6562 : 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6563 : : {
6564 : 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6565 : : logical_type_node, args[1],
6566 : 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6567 : 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6568 : 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6569 : : logical_type_node, args[1], nbits);
6570 : 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6571 : : logical_type_node, below, above);
6572 : 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6573 : : "POS argument (%ld) out of range 0:%ld "
6574 : : "in intrinsic BTEST",
6575 : : fold_convert (long_integer_type_node, args[1]),
6576 : : fold_convert (long_integer_type_node, nbits));
6577 : : }
6578 : :
6579 : 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6580 : : build_int_cst (type, 1), args[1]);
6581 : 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6582 : 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6583 : : build_int_cst (type, 0));
6584 : 145 : type = gfc_typenode_for_spec (&expr->ts);
6585 : 145 : se->expr = convert (type, tmp);
6586 : 145 : }
6587 : :
6588 : :
6589 : : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6590 : : static void
6591 : 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6592 : : {
6593 : 216 : tree args[2];
6594 : :
6595 : 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6596 : :
6597 : : /* Convert both arguments to the unsigned type of the same size. */
6598 : 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6599 : 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6600 : :
6601 : : /* If they have unequal type size, convert to the larger one. */
6602 : 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6603 : 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6604 : 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6605 : 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6606 : 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6607 : 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6608 : :
6609 : : /* Now, we compare them. */
6610 : 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6611 : : args[0], args[1]);
6612 : 216 : }
6613 : :
6614 : :
6615 : : /* Generate code to perform the specified operation. */
6616 : : static void
6617 : 1891 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6618 : : {
6619 : 1891 : tree args[2];
6620 : :
6621 : 1891 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6622 : 1891 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6623 : : args[0], args[1]);
6624 : 1891 : }
6625 : :
6626 : : /* Bitwise not. */
6627 : : static void
6628 : 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6629 : : {
6630 : 230 : tree arg;
6631 : :
6632 : 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6633 : 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6634 : 230 : TREE_TYPE (arg), arg);
6635 : 230 : }
6636 : :
6637 : :
6638 : : /* Generate code for OUT_OF_RANGE. */
6639 : : static void
6640 : 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6641 : : {
6642 : 468 : tree *args;
6643 : 468 : tree type;
6644 : 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6645 : 468 : unsigned int num_args;
6646 : 468 : int k;
6647 : 468 : gfc_se rnd_se;
6648 : 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6649 : 468 : gfc_expr *x = arg->expr;
6650 : 468 : gfc_expr *mold = arg->next->expr;
6651 : :
6652 : 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6653 : 468 : args = XALLOCAVEC (tree, num_args);
6654 : :
6655 : 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6656 : :
6657 : 468 : gfc_init_se (&rnd_se, NULL);
6658 : :
6659 : 468 : if (num_args == 3)
6660 : : {
6661 : : /* The ROUND argument is optional and shall appear only if X is
6662 : : of type real and MOLD is of type integer (see edit F23/004). */
6663 : 270 : gfc_expr *round = arg->next->next->expr;
6664 : 270 : gfc_conv_expr (&rnd_se, round);
6665 : :
6666 : 270 : if (round->expr_type == EXPR_VARIABLE
6667 : 198 : && round->symtree->n.sym->attr.dummy
6668 : 30 : && round->symtree->n.sym->attr.optional)
6669 : : {
6670 : 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6671 : 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6672 : : logical_type_node, present,
6673 : : rnd_se.expr, logical_false_node);
6674 : 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6675 : : }
6676 : : }
6677 : : else
6678 : : {
6679 : : /* If ROUND is absent, it is equivalent to having the value false. */
6680 : 198 : rnd_se.expr = logical_false_node;
6681 : : }
6682 : :
6683 : 468 : type = TREE_TYPE (args[0]);
6684 : 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6685 : :
6686 : 468 : switch (x->ts.type)
6687 : : {
6688 : 378 : case BT_REAL:
6689 : : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6690 : : support infinity or NaN. */
6691 : 378 : tree finite;
6692 : 378 : finite = build_call_expr_loc (input_location,
6693 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
6694 : : 1, args[0]);
6695 : 378 : finite = convert (logical_type_node, finite);
6696 : :
6697 : 378 : if (mold->ts.type == BT_REAL)
6698 : : {
6699 : 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6700 : 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6701 : : mold->ts.kind, 0);
6702 : 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6703 : : convert (type, tmp2));
6704 : :
6705 : : /* Check if MOLD representation supports infinity or NaN. */
6706 : 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6707 : 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6708 : 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6709 : : infnan ? logical_false_node : logical_true_node);
6710 : : }
6711 : : else
6712 : : {
6713 : 354 : tree rounded;
6714 : 354 : tree decl;
6715 : :
6716 : 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6717 : 354 : gcc_assert (decl != NULL_TREE);
6718 : :
6719 : : /* Round or truncate argument X, depending on the optional argument
6720 : : ROUND (default: .false.). */
6721 : 354 : tmp1 = build_round_expr (args[0], type);
6722 : 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6723 : 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6724 : :
6725 : 354 : if (mold->ts.type == BT_INTEGER)
6726 : : {
6727 : 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6728 : : x->ts.kind);
6729 : 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6730 : : x->ts.kind);
6731 : : }
6732 : 174 : else if (mold->ts.type == BT_UNSIGNED)
6733 : : {
6734 : 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6735 : 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6736 : : x->ts.kind);
6737 : : }
6738 : : else
6739 : 0 : gcc_unreachable ();
6740 : :
6741 : 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6742 : : convert (type, tmp1));
6743 : 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6744 : : convert (type, tmp2));
6745 : 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6746 : 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6747 : : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6748 : : tmp);
6749 : : }
6750 : : break;
6751 : :
6752 : 48 : case BT_INTEGER:
6753 : 48 : if (mold->ts.type == BT_INTEGER)
6754 : : {
6755 : 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6756 : : x->ts.kind);
6757 : 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6758 : : x->ts.kind);
6759 : 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6760 : : convert (type, tmp1));
6761 : 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6762 : : convert (type, tmp2));
6763 : 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6764 : : }
6765 : 36 : else if (mold->ts.type == BT_UNSIGNED)
6766 : : {
6767 : 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6768 : 36 : tmp = build_int_cst (type, 0);
6769 : 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6770 : 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6771 : 36 : gfc_unsigned_kinds[k].huge) > 0)
6772 : : {
6773 : 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6774 : : x->ts.kind);
6775 : 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6776 : : convert (type, tmp2));
6777 : 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6778 : : }
6779 : : }
6780 : 0 : else if (mold->ts.type == BT_REAL)
6781 : : {
6782 : 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6783 : : mold->ts.kind, 0);
6784 : 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6785 : 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6786 : : convert (type, tmp1));
6787 : 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6788 : : convert (type, tmp2));
6789 : 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6790 : : }
6791 : : else
6792 : 0 : gcc_unreachable ();
6793 : : break;
6794 : :
6795 : 42 : case BT_UNSIGNED:
6796 : 42 : if (mold->ts.type == BT_UNSIGNED)
6797 : : {
6798 : 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6799 : : x->ts.kind);
6800 : 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6801 : : convert (type, tmp));
6802 : : }
6803 : 30 : else if (mold->ts.type == BT_INTEGER)
6804 : : {
6805 : 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6806 : : x->ts.kind);
6807 : 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6808 : : convert (type, tmp));
6809 : : }
6810 : 12 : else if (mold->ts.type == BT_REAL)
6811 : : {
6812 : 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6813 : : mold->ts.kind, 0);
6814 : 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6815 : : convert (type, tmp));
6816 : : }
6817 : : else
6818 : 0 : gcc_unreachable ();
6819 : : break;
6820 : :
6821 : 0 : default:
6822 : 0 : gcc_unreachable ();
6823 : : }
6824 : :
6825 : 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6826 : 468 : }
6827 : :
6828 : :
6829 : : /* Set or clear a single bit. */
6830 : : static void
6831 : 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6832 : : {
6833 : 306 : tree args[2];
6834 : 306 : tree type;
6835 : 306 : tree tmp;
6836 : 306 : enum tree_code op;
6837 : :
6838 : 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6839 : 306 : type = TREE_TYPE (args[0]);
6840 : :
6841 : : /* Optionally generate code for runtime argument check. */
6842 : 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6843 : : {
6844 : 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6845 : : logical_type_node, args[1],
6846 : 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6847 : 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6848 : 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6849 : : logical_type_node, args[1], nbits);
6850 : 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6851 : : logical_type_node, below, above);
6852 : 12 : size_t len_name = strlen (expr->value.function.isym->name);
6853 : 12 : char *name = XALLOCAVEC (char, len_name + 1);
6854 : 72 : for (size_t i = 0; i < len_name; i++)
6855 : 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6856 : 12 : name[len_name] = '\0';
6857 : 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6858 : : gfc_build_cstring_const (name));
6859 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6860 : : "POS argument (%ld) out of range 0:%ld "
6861 : : "in intrinsic %s",
6862 : : fold_convert (long_integer_type_node, args[1]),
6863 : : fold_convert (long_integer_type_node, nbits),
6864 : : iname);
6865 : : }
6866 : :
6867 : 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6868 : : build_int_cst (type, 1), args[1]);
6869 : 306 : if (set)
6870 : : op = BIT_IOR_EXPR;
6871 : : else
6872 : : {
6873 : 168 : op = BIT_AND_EXPR;
6874 : 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6875 : : }
6876 : 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6877 : 306 : }
6878 : :
6879 : : /* Extract a sequence of bits.
6880 : : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6881 : : static void
6882 : 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6883 : : {
6884 : 27 : tree args[3];
6885 : 27 : tree type;
6886 : 27 : tree tmp;
6887 : 27 : tree mask;
6888 : 27 : tree num_bits, cond;
6889 : :
6890 : 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6891 : 27 : type = TREE_TYPE (args[0]);
6892 : :
6893 : : /* Optionally generate code for runtime argument check. */
6894 : 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6895 : : {
6896 : 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6897 : 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6898 : 12 : tree nbits = build_int_cst (long_integer_type_node,
6899 : 12 : TYPE_PRECISION (type));
6900 : 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6901 : : logical_type_node, args[1],
6902 : 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6903 : 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6904 : : logical_type_node, tmp1, nbits);
6905 : 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6906 : : logical_type_node, below, above);
6907 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6908 : : "POS argument (%ld) out of range 0:%ld "
6909 : : "in intrinsic IBITS", tmp1, nbits);
6910 : 12 : below = fold_build2_loc (input_location, LT_EXPR,
6911 : : logical_type_node, args[2],
6912 : 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6913 : 12 : above = fold_build2_loc (input_location, GT_EXPR,
6914 : : logical_type_node, tmp2, nbits);
6915 : 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6916 : : logical_type_node, below, above);
6917 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6918 : : "LEN argument (%ld) out of range 0:%ld "
6919 : : "in intrinsic IBITS", tmp2, nbits);
6920 : 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6921 : : long_integer_type_node, tmp1, tmp2);
6922 : 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6923 : : logical_type_node, above, nbits);
6924 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6925 : : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6926 : : "in intrinsic IBITS", tmp1, tmp2, nbits);
6927 : : }
6928 : :
6929 : : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6930 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6931 : : special case. See also gfc_conv_intrinsic_ishft (). */
6932 : 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6933 : :
6934 : 27 : mask = build_int_cst (type, -1);
6935 : 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6936 : 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6937 : : num_bits);
6938 : 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6939 : : build_int_cst (type, 0), mask);
6940 : 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6941 : :
6942 : 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6943 : :
6944 : 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6945 : 27 : }
6946 : :
6947 : : static void
6948 : 441 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6949 : : bool arithmetic)
6950 : : {
6951 : 441 : tree args[2], type, num_bits, cond;
6952 : 441 : tree bigshift;
6953 : 441 : bool do_convert = false;
6954 : :
6955 : 441 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6956 : :
6957 : 441 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6958 : 441 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6959 : 441 : type = TREE_TYPE (args[0]);
6960 : :
6961 : 441 : if (!arithmetic)
6962 : : {
6963 : 339 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6964 : 339 : do_convert = true;
6965 : : }
6966 : : else
6967 : 102 : gcc_assert (right_shift);
6968 : :
6969 : 441 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
6970 : : {
6971 : 30 : do_convert = true;
6972 : 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
6973 : : }
6974 : :
6975 : 714 : se->expr = fold_build2_loc (input_location,
6976 : : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6977 : 441 : TREE_TYPE (args[0]), args[0], args[1]);
6978 : :
6979 : 441 : if (do_convert)
6980 : 369 : se->expr = fold_convert (type, se->expr);
6981 : :
6982 : 441 : if (!arithmetic)
6983 : 339 : bigshift = build_int_cst (type, 0);
6984 : : else
6985 : : {
6986 : 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
6987 : : logical_type_node, args[0],
6988 : 102 : build_int_cst (TREE_TYPE (args[0]), 0));
6989 : 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
6990 : : build_int_cst (type, 0),
6991 : : build_int_cst (type, -1));
6992 : : }
6993 : :
6994 : : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6995 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6996 : : special case. */
6997 : 441 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6998 : :
6999 : : /* Optionally generate code for runtime argument check. */
7000 : 441 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7001 : : {
7002 : 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7003 : : logical_type_node, args[1],
7004 : 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7005 : 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7006 : : logical_type_node, args[1], num_bits);
7007 : 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7008 : : logical_type_node, below, above);
7009 : 30 : size_t len_name = strlen (expr->value.function.isym->name);
7010 : 30 : char *name = XALLOCAVEC (char, len_name + 1);
7011 : 210 : for (size_t i = 0; i < len_name; i++)
7012 : 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7013 : 30 : name[len_name] = '\0';
7014 : 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7015 : : gfc_build_cstring_const (name));
7016 : 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7017 : : "SHIFT argument (%ld) out of range 0:%ld "
7018 : : "in intrinsic %s",
7019 : : fold_convert (long_integer_type_node, args[1]),
7020 : : fold_convert (long_integer_type_node, num_bits),
7021 : : iname);
7022 : : }
7023 : :
7024 : 441 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7025 : : args[1], num_bits);
7026 : :
7027 : 441 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7028 : : bigshift, se->expr);
7029 : 441 : }
7030 : :
7031 : : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7032 : : ? 0
7033 : : : ((shift >= 0) ? i << shift : i >> -shift)
7034 : : where all shifts are logical shifts. */
7035 : : static void
7036 : 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7037 : : {
7038 : 318 : tree args[2];
7039 : 318 : tree type;
7040 : 318 : tree utype;
7041 : 318 : tree tmp;
7042 : 318 : tree width;
7043 : 318 : tree num_bits;
7044 : 318 : tree cond;
7045 : 318 : tree lshift;
7046 : 318 : tree rshift;
7047 : :
7048 : 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7049 : :
7050 : 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7051 : 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7052 : :
7053 : 318 : type = TREE_TYPE (args[0]);
7054 : 318 : utype = unsigned_type_for (type);
7055 : :
7056 : 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7057 : : args[1]);
7058 : :
7059 : : /* Left shift if positive. */
7060 : 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7061 : :
7062 : : /* Right shift if negative.
7063 : : We convert to an unsigned type because we want a logical shift.
7064 : : The standard doesn't define the case of shifting negative
7065 : : numbers, and we try to be compatible with other compilers, most
7066 : : notably g77, here. */
7067 : 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7068 : : utype, convert (utype, args[0]), width));
7069 : :
7070 : 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7071 : 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7072 : 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7073 : :
7074 : : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7075 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7076 : : special case. */
7077 : 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7078 : :
7079 : : /* Optionally generate code for runtime argument check. */
7080 : 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7081 : : {
7082 : 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7083 : : logical_type_node, width, num_bits);
7084 : 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7085 : : "SHIFT argument (%ld) out of range -%ld:%ld "
7086 : : "in intrinsic ISHFT",
7087 : : fold_convert (long_integer_type_node, args[1]),
7088 : : fold_convert (long_integer_type_node, num_bits),
7089 : : fold_convert (long_integer_type_node, num_bits));
7090 : : }
7091 : :
7092 : 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7093 : : num_bits);
7094 : 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7095 : : build_int_cst (type, 0), tmp);
7096 : 318 : }
7097 : :
7098 : :
7099 : : /* Circular shift. AKA rotate or barrel shift. */
7100 : :
7101 : : static void
7102 : 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7103 : : {
7104 : 658 : tree *args;
7105 : 658 : tree type;
7106 : 658 : tree tmp;
7107 : 658 : tree lrot;
7108 : 658 : tree rrot;
7109 : 658 : tree zero;
7110 : 658 : tree nbits;
7111 : 658 : unsigned int num_args;
7112 : :
7113 : 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7114 : 658 : args = XALLOCAVEC (tree, num_args);
7115 : :
7116 : 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7117 : :
7118 : 658 : type = TREE_TYPE (args[0]);
7119 : 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7120 : :
7121 : 658 : if (num_args == 3)
7122 : : {
7123 : 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7124 : :
7125 : : /* Use a library function for the 3 parameter version. */
7126 : 550 : tree int4type = gfc_get_int_type (4);
7127 : :
7128 : : /* Treat optional SIZE argument when it is passed as an optional
7129 : : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7130 : 550 : if (size->expr_type == EXPR_VARIABLE
7131 : 438 : && size->symtree->n.sym->attr.dummy
7132 : 36 : && size->symtree->n.sym->attr.optional)
7133 : : {
7134 : 36 : tree type_of_size = TREE_TYPE (args[2]);
7135 : 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7136 : 36 : gfc_conv_expr_present (size->symtree->n.sym),
7137 : : args[2], fold_convert (type_of_size, nbits));
7138 : : }
7139 : :
7140 : : /* We convert the first argument to at least 4 bytes, and
7141 : : convert back afterwards. This removes the need for library
7142 : : functions for all argument sizes, and function will be
7143 : : aligned to at least 32 bits, so there's no loss. */
7144 : 550 : if (expr->ts.kind < 4)
7145 : 242 : args[0] = convert (int4type, args[0]);
7146 : :
7147 : : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7148 : : need loads of library functions. They cannot have values >
7149 : : BIT_SIZE (I) so the conversion is safe. */
7150 : 550 : args[1] = convert (int4type, args[1]);
7151 : 550 : args[2] = convert (int4type, args[2]);
7152 : :
7153 : : /* Optionally generate code for runtime argument check. */
7154 : 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7155 : : {
7156 : 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7157 : 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7158 : : logical_type_node, size,
7159 : 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7160 : 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7161 : : logical_type_node, size, nbits);
7162 : 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7163 : : logical_type_node, below, above);
7164 : 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7165 : : "SIZE argument (%ld) out of range 1:%ld "
7166 : : "in intrinsic ISHFTC", size, nbits);
7167 : 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7168 : 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7169 : : long_integer_type_node, width);
7170 : 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7171 : : logical_type_node, width, size);
7172 : 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7173 : : "SHIFT argument (%ld) out of range -%ld:%ld "
7174 : : "in intrinsic ISHFTC",
7175 : : fold_convert (long_integer_type_node, args[1]),
7176 : : size, size);
7177 : : }
7178 : :
7179 : 550 : switch (expr->ts.kind)
7180 : : {
7181 : 426 : case 1:
7182 : 426 : case 2:
7183 : 426 : case 4:
7184 : 426 : tmp = gfor_fndecl_math_ishftc4;
7185 : 426 : break;
7186 : 124 : case 8:
7187 : 124 : tmp = gfor_fndecl_math_ishftc8;
7188 : 124 : break;
7189 : 0 : case 16:
7190 : 0 : tmp = gfor_fndecl_math_ishftc16;
7191 : 0 : break;
7192 : 0 : default:
7193 : 0 : gcc_unreachable ();
7194 : : }
7195 : 550 : se->expr = build_call_expr_loc (input_location,
7196 : : tmp, 3, args[0], args[1], args[2]);
7197 : : /* Convert the result back to the original type, if we extended
7198 : : the first argument's width above. */
7199 : 550 : if (expr->ts.kind < 4)
7200 : 242 : se->expr = convert (type, se->expr);
7201 : :
7202 : 550 : return;
7203 : : }
7204 : :
7205 : : /* Evaluate arguments only once. */
7206 : 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7207 : 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7208 : :
7209 : : /* Optionally generate code for runtime argument check. */
7210 : 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7211 : : {
7212 : 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7213 : 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7214 : : long_integer_type_node, width);
7215 : 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7216 : : logical_type_node, width, nbits);
7217 : 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7218 : : "SHIFT argument (%ld) out of range -%ld:%ld "
7219 : : "in intrinsic ISHFTC",
7220 : : fold_convert (long_integer_type_node, args[1]),
7221 : : nbits, nbits);
7222 : : }
7223 : :
7224 : : /* Rotate left if positive. */
7225 : 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7226 : :
7227 : : /* Rotate right if negative. */
7228 : 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7229 : : args[1]);
7230 : 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7231 : :
7232 : 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7233 : 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7234 : : zero);
7235 : 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7236 : :
7237 : : /* Do nothing if shift == 0. */
7238 : 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7239 : : zero);
7240 : 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7241 : : rrot);
7242 : : }
7243 : :
7244 : :
7245 : : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7246 : : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7247 : :
7248 : : The conditional expression is necessary because the result of LEADZ(0)
7249 : : is defined, but the result of __builtin_clz(0) is undefined for most
7250 : : targets.
7251 : :
7252 : : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7253 : : difference in bit size between the argument of LEADZ and the C int. */
7254 : :
7255 : : static void
7256 : 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7257 : : {
7258 : 270 : tree arg;
7259 : 270 : tree arg_type;
7260 : 270 : tree cond;
7261 : 270 : tree result_type;
7262 : 270 : tree leadz;
7263 : 270 : tree bit_size;
7264 : 270 : tree tmp;
7265 : 270 : tree func;
7266 : 270 : int s, argsize;
7267 : :
7268 : 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7269 : 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7270 : :
7271 : : /* Which variant of __builtin_clz* should we call? */
7272 : 270 : if (argsize <= INT_TYPE_SIZE)
7273 : : {
7274 : 183 : arg_type = unsigned_type_node;
7275 : 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7276 : : }
7277 : 87 : else if (argsize <= LONG_TYPE_SIZE)
7278 : : {
7279 : 57 : arg_type = long_unsigned_type_node;
7280 : 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7281 : : }
7282 : 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7283 : : {
7284 : 0 : arg_type = long_long_unsigned_type_node;
7285 : 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7286 : : }
7287 : : else
7288 : : {
7289 : 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7290 : 30 : arg_type = gfc_build_uint_type (argsize);
7291 : 30 : func = NULL_TREE;
7292 : : }
7293 : :
7294 : : /* Convert the actual argument twice: first, to the unsigned type of the
7295 : : same size; then, to the proper argument type for the built-in
7296 : : function. But the return type is of the default INTEGER kind. */
7297 : 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7298 : 270 : arg = fold_convert (arg_type, arg);
7299 : 270 : arg = gfc_evaluate_now (arg, &se->pre);
7300 : 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7301 : :
7302 : : /* Compute LEADZ for the case i .ne. 0. */
7303 : 270 : if (func)
7304 : : {
7305 : 240 : s = TYPE_PRECISION (arg_type) - argsize;
7306 : 240 : tmp = fold_convert (result_type,
7307 : : build_call_expr_loc (input_location, func,
7308 : : 1, arg));
7309 : 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7310 : 240 : tmp, build_int_cst (result_type, s));
7311 : : }
7312 : : else
7313 : : {
7314 : : /* We end up here if the argument type is larger than 'long long'.
7315 : : We generate this code:
7316 : :
7317 : : if (x & (ULL_MAX << ULL_SIZE) != 0)
7318 : : return clzll ((unsigned long long) (x >> ULLSIZE));
7319 : : else
7320 : : return ULL_SIZE + clzll ((unsigned long long) x);
7321 : : where ULL_MAX is the largest value that a ULL_MAX can hold
7322 : : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7323 : : is the bit-size of the long long type (64 in this example). */
7324 : 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7325 : :
7326 : 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7327 : 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7328 : : long_long_unsigned_type_node,
7329 : : build_int_cst (long_long_unsigned_type_node,
7330 : : 0));
7331 : :
7332 : 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7333 : : fold_convert (arg_type, ullmax), ullsize);
7334 : 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7335 : : arg, cond);
7336 : 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7337 : : cond, build_int_cst (arg_type, 0));
7338 : :
7339 : 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7340 : : arg, ullsize);
7341 : 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7342 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7343 : 30 : tmp1 = fold_convert (result_type,
7344 : : build_call_expr_loc (input_location, btmp, 1, tmp1));
7345 : :
7346 : 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7347 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7348 : 30 : tmp2 = fold_convert (result_type,
7349 : : build_call_expr_loc (input_location, btmp, 1, tmp2));
7350 : 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7351 : : tmp2, ullsize);
7352 : :
7353 : 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7354 : : cond, tmp1, tmp2);
7355 : : }
7356 : :
7357 : : /* Build BIT_SIZE. */
7358 : 270 : bit_size = build_int_cst (result_type, argsize);
7359 : :
7360 : 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7361 : : arg, build_int_cst (arg_type, 0));
7362 : 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7363 : : bit_size, leadz);
7364 : 270 : }
7365 : :
7366 : :
7367 : : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7368 : :
7369 : : The conditional expression is necessary because the result of TRAILZ(0)
7370 : : is defined, but the result of __builtin_ctz(0) is undefined for most
7371 : : targets. */
7372 : :
7373 : : static void
7374 : 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7375 : : {
7376 : 282 : tree arg;
7377 : 282 : tree arg_type;
7378 : 282 : tree cond;
7379 : 282 : tree result_type;
7380 : 282 : tree trailz;
7381 : 282 : tree bit_size;
7382 : 282 : tree func;
7383 : 282 : int argsize;
7384 : :
7385 : 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7386 : 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7387 : :
7388 : : /* Which variant of __builtin_ctz* should we call? */
7389 : 282 : if (argsize <= INT_TYPE_SIZE)
7390 : : {
7391 : 195 : arg_type = unsigned_type_node;
7392 : 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7393 : : }
7394 : 87 : else if (argsize <= LONG_TYPE_SIZE)
7395 : : {
7396 : 57 : arg_type = long_unsigned_type_node;
7397 : 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7398 : : }
7399 : 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7400 : : {
7401 : 0 : arg_type = long_long_unsigned_type_node;
7402 : 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7403 : : }
7404 : : else
7405 : : {
7406 : 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7407 : 30 : arg_type = gfc_build_uint_type (argsize);
7408 : 30 : func = NULL_TREE;
7409 : : }
7410 : :
7411 : : /* Convert the actual argument twice: first, to the unsigned type of the
7412 : : same size; then, to the proper argument type for the built-in
7413 : : function. But the return type is of the default INTEGER kind. */
7414 : 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7415 : 282 : arg = fold_convert (arg_type, arg);
7416 : 282 : arg = gfc_evaluate_now (arg, &se->pre);
7417 : 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7418 : :
7419 : : /* Compute TRAILZ for the case i .ne. 0. */
7420 : 282 : if (func)
7421 : 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7422 : : func, 1, arg));
7423 : : else
7424 : : {
7425 : : /* We end up here if the argument type is larger than 'long long'.
7426 : : We generate this code:
7427 : :
7428 : : if ((x & ULL_MAX) == 0)
7429 : : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7430 : : else
7431 : : return ctzll ((unsigned long long) x);
7432 : :
7433 : : where ULL_MAX is the largest value that a ULL_MAX can hold
7434 : : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7435 : : is the bit-size of the long long type (64 in this example). */
7436 : 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7437 : :
7438 : 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7439 : 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7440 : : long_long_unsigned_type_node,
7441 : : build_int_cst (long_long_unsigned_type_node, 0));
7442 : :
7443 : 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7444 : : fold_convert (arg_type, ullmax));
7445 : 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7446 : : build_int_cst (arg_type, 0));
7447 : :
7448 : 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7449 : : arg, ullsize);
7450 : 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7451 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7452 : 30 : tmp1 = fold_convert (result_type,
7453 : : build_call_expr_loc (input_location, btmp, 1, tmp1));
7454 : 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7455 : : tmp1, ullsize);
7456 : :
7457 : 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7458 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7459 : 30 : tmp2 = fold_convert (result_type,
7460 : : build_call_expr_loc (input_location, btmp, 1, tmp2));
7461 : :
7462 : 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7463 : : cond, tmp1, tmp2);
7464 : : }
7465 : :
7466 : : /* Build BIT_SIZE. */
7467 : 282 : bit_size = build_int_cst (result_type, argsize);
7468 : :
7469 : 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7470 : : arg, build_int_cst (arg_type, 0));
7471 : 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7472 : : bit_size, trailz);
7473 : 282 : }
7474 : :
7475 : : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7476 : : for types larger than "long long", we call the long long built-in for
7477 : : the lower and higher bits and combine the result. */
7478 : :
7479 : : static void
7480 : 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7481 : : {
7482 : 134 : tree arg;
7483 : 134 : tree arg_type;
7484 : 134 : tree result_type;
7485 : 134 : tree func;
7486 : 134 : int argsize;
7487 : :
7488 : 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7489 : 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7490 : 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7491 : :
7492 : : /* Which variant of the builtin should we call? */
7493 : 134 : if (argsize <= INT_TYPE_SIZE)
7494 : : {
7495 : 108 : arg_type = unsigned_type_node;
7496 : 198 : func = builtin_decl_explicit (parity
7497 : : ? BUILT_IN_PARITY
7498 : : : BUILT_IN_POPCOUNT);
7499 : : }
7500 : 26 : else if (argsize <= LONG_TYPE_SIZE)
7501 : : {
7502 : 12 : arg_type = long_unsigned_type_node;
7503 : 18 : func = builtin_decl_explicit (parity
7504 : : ? BUILT_IN_PARITYL
7505 : : : BUILT_IN_POPCOUNTL);
7506 : : }
7507 : 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7508 : : {
7509 : 0 : arg_type = long_long_unsigned_type_node;
7510 : 0 : func = builtin_decl_explicit (parity
7511 : : ? BUILT_IN_PARITYLL
7512 : : : BUILT_IN_POPCOUNTLL);
7513 : : }
7514 : : else
7515 : : {
7516 : : /* Our argument type is larger than 'long long', which mean none
7517 : : of the POPCOUNT builtins covers it. We thus call the 'long long'
7518 : : variant multiple times, and add the results. */
7519 : 14 : tree utype, arg2, call1, call2;
7520 : :
7521 : : /* For now, we only cover the case where argsize is twice as large
7522 : : as 'long long'. */
7523 : 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7524 : :
7525 : 21 : func = builtin_decl_explicit (parity
7526 : : ? BUILT_IN_PARITYLL
7527 : : : BUILT_IN_POPCOUNTLL);
7528 : :
7529 : : /* Convert it to an integer, and store into a variable. */
7530 : 14 : utype = gfc_build_uint_type (argsize);
7531 : 14 : arg = fold_convert (utype, arg);
7532 : 14 : arg = gfc_evaluate_now (arg, &se->pre);
7533 : :
7534 : : /* Call the builtin twice. */
7535 : 14 : call1 = build_call_expr_loc (input_location, func, 1,
7536 : : fold_convert (long_long_unsigned_type_node,
7537 : : arg));
7538 : :
7539 : 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7540 : : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7541 : 14 : call2 = build_call_expr_loc (input_location, func, 1,
7542 : : fold_convert (long_long_unsigned_type_node,
7543 : : arg2));
7544 : :
7545 : : /* Combine the results. */
7546 : 14 : if (parity)
7547 : 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7548 : : integer_type_node, call1, call2);
7549 : : else
7550 : 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7551 : : integer_type_node, call1, call2);
7552 : :
7553 : 14 : se->expr = convert (result_type, se->expr);
7554 : 14 : return;
7555 : : }
7556 : :
7557 : : /* Convert the actual argument twice: first, to the unsigned type of the
7558 : : same size; then, to the proper argument type for the built-in
7559 : : function. */
7560 : 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7561 : 120 : arg = fold_convert (arg_type, arg);
7562 : :
7563 : 120 : se->expr = fold_convert (result_type,
7564 : : build_call_expr_loc (input_location, func, 1, arg));
7565 : : }
7566 : :
7567 : :
7568 : : /* Process an intrinsic with unspecified argument-types that has an optional
7569 : : argument (which could be of type character), e.g. EOSHIFT. For those, we
7570 : : need to append the string length of the optional argument if it is not
7571 : : present and the type is really character.
7572 : : primary specifies the position (starting at 1) of the non-optional argument
7573 : : specifying the type and optional gives the position of the optional
7574 : : argument in the arglist. */
7575 : :
7576 : : static void
7577 : 6086 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7578 : : unsigned primary, unsigned optional)
7579 : : {
7580 : 6086 : gfc_actual_arglist* prim_arg;
7581 : 6086 : gfc_actual_arglist* opt_arg;
7582 : 6086 : unsigned cur_pos;
7583 : 6086 : gfc_actual_arglist* arg;
7584 : 6086 : gfc_symbol* sym;
7585 : 6086 : vec<tree, va_gc> *append_args;
7586 : :
7587 : : /* Find the two arguments given as position. */
7588 : 6086 : cur_pos = 0;
7589 : 6086 : prim_arg = NULL;
7590 : 6086 : opt_arg = NULL;
7591 : 18258 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7592 : : {
7593 : 18258 : ++cur_pos;
7594 : :
7595 : 18258 : if (cur_pos == primary)
7596 : 6086 : prim_arg = arg;
7597 : 18258 : if (cur_pos == optional)
7598 : 6086 : opt_arg = arg;
7599 : :
7600 : 18258 : if (cur_pos >= primary && cur_pos >= optional)
7601 : : break;
7602 : : }
7603 : 6086 : gcc_assert (prim_arg);
7604 : 6086 : gcc_assert (prim_arg->expr);
7605 : 6086 : gcc_assert (opt_arg);
7606 : :
7607 : : /* If we do have type CHARACTER and the optional argument is really absent,
7608 : : append a dummy 0 as string length. */
7609 : 6086 : append_args = NULL;
7610 : 6086 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7611 : : {
7612 : 608 : tree dummy;
7613 : :
7614 : 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7615 : 608 : vec_alloc (append_args, 1);
7616 : 608 : append_args->quick_push (dummy);
7617 : : }
7618 : :
7619 : : /* Build the call itself. */
7620 : 6086 : gcc_assert (!se->ignore_optional);
7621 : 6086 : sym = gfc_get_symbol_for_expr (expr, false);
7622 : 6086 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7623 : : append_args);
7624 : 6086 : gfc_free_symbol (sym);
7625 : 6086 : }
7626 : :
7627 : : /* The length of a character string. */
7628 : : static void
7629 : 5643 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7630 : : {
7631 : 5643 : tree len;
7632 : 5643 : tree type;
7633 : 5643 : tree decl;
7634 : 5643 : gfc_symbol *sym;
7635 : 5643 : gfc_se argse;
7636 : 5643 : gfc_expr *arg;
7637 : :
7638 : 5643 : gcc_assert (!se->ss);
7639 : :
7640 : 5643 : arg = expr->value.function.actual->expr;
7641 : :
7642 : 5643 : type = gfc_typenode_for_spec (&expr->ts);
7643 : 5643 : switch (arg->expr_type)
7644 : : {
7645 : 0 : case EXPR_CONSTANT:
7646 : 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7647 : 0 : break;
7648 : :
7649 : 2 : case EXPR_ARRAY:
7650 : : /* Obtain the string length from the function used by
7651 : : trans-array.cc(gfc_trans_array_constructor). */
7652 : 2 : len = NULL_TREE;
7653 : 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7654 : 2 : break;
7655 : :
7656 : 5056 : case EXPR_VARIABLE:
7657 : 5056 : if (arg->ref == NULL
7658 : 2282 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7659 : : {
7660 : : /* This doesn't catch all cases.
7661 : : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7662 : : and the surrounding thread. */
7663 : 4524 : sym = arg->symtree->n.sym;
7664 : 4524 : decl = gfc_get_symbol_decl (sym);
7665 : 4524 : if (decl == current_function_decl && sym->attr.function
7666 : 53 : && (sym->result == sym))
7667 : 53 : decl = gfc_get_fake_result_decl (sym, 0);
7668 : :
7669 : 4524 : len = sym->ts.u.cl->backend_decl;
7670 : 4524 : gcc_assert (len);
7671 : : break;
7672 : : }
7673 : :
7674 : : /* Fall through. */
7675 : :
7676 : 1117 : default:
7677 : 1117 : gfc_init_se (&argse, se);
7678 : 1117 : if (arg->rank == 0)
7679 : 995 : gfc_conv_expr (&argse, arg);
7680 : : else
7681 : 122 : gfc_conv_expr_descriptor (&argse, arg);
7682 : 1117 : gfc_add_block_to_block (&se->pre, &argse.pre);
7683 : 1117 : gfc_add_block_to_block (&se->post, &argse.post);
7684 : 1117 : len = argse.string_length;
7685 : 1117 : break;
7686 : : }
7687 : 5643 : se->expr = convert (type, len);
7688 : 5643 : }
7689 : :
7690 : : /* The length of a character string not including trailing blanks. */
7691 : : static void
7692 : 2321 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7693 : : {
7694 : 2321 : int kind = expr->value.function.actual->expr->ts.kind;
7695 : 2321 : tree args[2], type, fndecl;
7696 : :
7697 : 2321 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7698 : 2321 : type = gfc_typenode_for_spec (&expr->ts);
7699 : :
7700 : 2321 : if (kind == 1)
7701 : 1919 : fndecl = gfor_fndecl_string_len_trim;
7702 : 402 : else if (kind == 4)
7703 : 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7704 : : else
7705 : 0 : gcc_unreachable ();
7706 : :
7707 : 2321 : se->expr = build_call_expr_loc (input_location,
7708 : : fndecl, 2, args[0], args[1]);
7709 : 2321 : se->expr = convert (type, se->expr);
7710 : 2321 : }
7711 : :
7712 : :
7713 : : /* Returns the starting position of a substring within a string. */
7714 : :
7715 : : static void
7716 : 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7717 : : tree function)
7718 : : {
7719 : 751 : tree logical4_type_node = gfc_get_logical_type (4);
7720 : 751 : tree type;
7721 : 751 : tree fndecl;
7722 : 751 : tree *args;
7723 : 751 : unsigned int num_args;
7724 : :
7725 : 751 : args = XALLOCAVEC (tree, 5);
7726 : :
7727 : : /* Get number of arguments; characters count double due to the
7728 : : string length argument. Kind= is not passed to the library
7729 : : and thus ignored. */
7730 : 751 : if (expr->value.function.actual->next->next->expr == NULL)
7731 : : num_args = 4;
7732 : : else
7733 : 304 : num_args = 5;
7734 : :
7735 : 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7736 : 751 : type = gfc_typenode_for_spec (&expr->ts);
7737 : :
7738 : 751 : if (num_args == 4)
7739 : 447 : args[4] = build_int_cst (logical4_type_node, 0);
7740 : : else
7741 : 304 : args[4] = convert (logical4_type_node, args[4]);
7742 : :
7743 : 751 : fndecl = build_addr (function);
7744 : 751 : se->expr = build_call_array_loc (input_location,
7745 : 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7746 : : 5, args);
7747 : 751 : se->expr = convert (type, se->expr);
7748 : :
7749 : 751 : }
7750 : :
7751 : : /* The ascii value for a single character. */
7752 : : static void
7753 : 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7754 : : {
7755 : 2033 : tree args[3], type, pchartype;
7756 : 2033 : int nargs;
7757 : :
7758 : 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7759 : 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7760 : 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7761 : 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7762 : 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7763 : 2033 : type = gfc_typenode_for_spec (&expr->ts);
7764 : :
7765 : 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7766 : : args[1]);
7767 : 2033 : se->expr = convert (type, se->expr);
7768 : 2033 : }
7769 : :
7770 : :
7771 : : /* Intrinsic ISNAN calls __builtin_isnan. */
7772 : :
7773 : : static void
7774 : 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7775 : : {
7776 : 432 : tree arg;
7777 : :
7778 : 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7779 : 432 : se->expr = build_call_expr_loc (input_location,
7780 : : builtin_decl_explicit (BUILT_IN_ISNAN),
7781 : : 1, arg);
7782 : 864 : STRIP_TYPE_NOPS (se->expr);
7783 : 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7784 : 432 : }
7785 : :
7786 : :
7787 : : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7788 : : their argument against a constant integer value. */
7789 : :
7790 : : static void
7791 : 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7792 : : {
7793 : 24 : tree arg;
7794 : :
7795 : 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7796 : 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7797 : : gfc_typenode_for_spec (&expr->ts),
7798 : 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7799 : 24 : }
7800 : :
7801 : :
7802 : :
7803 : : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7804 : :
7805 : : static void
7806 : 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7807 : : {
7808 : 949 : tree tsource;
7809 : 949 : tree fsource;
7810 : 949 : tree mask;
7811 : 949 : tree type;
7812 : 949 : tree len, len2;
7813 : 949 : tree *args;
7814 : 949 : unsigned int num_args;
7815 : :
7816 : 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7817 : 949 : args = XALLOCAVEC (tree, num_args);
7818 : :
7819 : 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7820 : 949 : if (expr->ts.type != BT_CHARACTER)
7821 : : {
7822 : 422 : tsource = args[0];
7823 : 422 : fsource = args[1];
7824 : 422 : mask = args[2];
7825 : : }
7826 : : else
7827 : : {
7828 : : /* We do the same as in the non-character case, but the argument
7829 : : list is different because of the string length arguments. We
7830 : : also have to set the string length for the result. */
7831 : 527 : len = args[0];
7832 : 527 : tsource = args[1];
7833 : 527 : len2 = args[2];
7834 : 527 : fsource = args[3];
7835 : 527 : mask = args[4];
7836 : :
7837 : 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7838 : : &se->pre);
7839 : 527 : se->string_length = len;
7840 : : }
7841 : 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7842 : 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7843 : 949 : mask = gfc_evaluate_now (mask, &se->pre);
7844 : 949 : type = TREE_TYPE (tsource);
7845 : 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7846 : : fold_convert (type, fsource));
7847 : 949 : }
7848 : :
7849 : :
7850 : : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7851 : :
7852 : : static void
7853 : 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7854 : : {
7855 : 42 : tree args[3], mask, type;
7856 : :
7857 : 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7858 : 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7859 : :
7860 : 42 : type = TREE_TYPE (args[0]);
7861 : 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7862 : 42 : gcc_assert (TREE_TYPE (mask) == type);
7863 : :
7864 : 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7865 : 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7866 : : fold_build1_loc (input_location, BIT_NOT_EXPR,
7867 : : type, mask));
7868 : 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7869 : : args[0], args[1]);
7870 : 42 : }
7871 : :
7872 : :
7873 : : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7874 : : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7875 : :
7876 : : static void
7877 : 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7878 : : {
7879 : 64 : tree arg, allones, type, utype, res, cond, bitsize;
7880 : 64 : int i;
7881 : :
7882 : 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7883 : 64 : arg = gfc_evaluate_now (arg, &se->pre);
7884 : :
7885 : 64 : type = gfc_get_int_type (expr->ts.kind);
7886 : 64 : utype = unsigned_type_for (type);
7887 : :
7888 : 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7889 : 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7890 : :
7891 : 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7892 : : build_int_cst (utype, 0));
7893 : :
7894 : 64 : if (left)
7895 : : {
7896 : : /* Left-justified mask. */
7897 : 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7898 : : bitsize, arg);
7899 : 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7900 : : fold_convert (utype, res));
7901 : :
7902 : : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7903 : : smaller than type width. */
7904 : 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7905 : 32 : build_int_cst (TREE_TYPE (arg), 0));
7906 : 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7907 : : build_int_cst (utype, 0), res);
7908 : : }
7909 : : else
7910 : : {
7911 : : /* Right-justified mask. */
7912 : 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7913 : : fold_convert (utype, arg));
7914 : 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7915 : :
7916 : : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7917 : : strictly smaller than type width. */
7918 : 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7919 : : arg, bitsize);
7920 : 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7921 : : cond, allones, res);
7922 : : }
7923 : :
7924 : 64 : se->expr = fold_convert (type, res);
7925 : 64 : }
7926 : :
7927 : :
7928 : : /* FRACTION (s) is translated into:
7929 : : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7930 : : static void
7931 : 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7932 : : {
7933 : 60 : tree arg, type, tmp, res, frexp, cond;
7934 : :
7935 : 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7936 : :
7937 : 60 : type = gfc_typenode_for_spec (&expr->ts);
7938 : 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7939 : 60 : arg = gfc_evaluate_now (arg, &se->pre);
7940 : :
7941 : 60 : cond = build_call_expr_loc (input_location,
7942 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
7943 : : 1, arg);
7944 : :
7945 : 60 : tmp = gfc_create_var (integer_type_node, NULL);
7946 : 60 : res = build_call_expr_loc (input_location, frexp, 2,
7947 : : fold_convert (type, arg),
7948 : : gfc_build_addr_expr (NULL_TREE, tmp));
7949 : 60 : res = fold_convert (type, res);
7950 : :
7951 : 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7952 : : cond, res, gfc_build_nan (type, ""));
7953 : 60 : }
7954 : :
7955 : :
7956 : : /* NEAREST (s, dir) is translated into
7957 : : tmp = copysign (HUGE_VAL, dir);
7958 : : return nextafter (s, tmp);
7959 : : */
7960 : : static void
7961 : 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7962 : : {
7963 : 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
7964 : :
7965 : 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
7966 : 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
7967 : :
7968 : 1595 : type = gfc_typenode_for_spec (&expr->ts);
7969 : 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7970 : :
7971 : 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7972 : 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7973 : : fold_convert (type, args[1]));
7974 : 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
7975 : : fold_convert (type, args[0]), tmp);
7976 : 1595 : se->expr = fold_convert (type, se->expr);
7977 : 1595 : }
7978 : :
7979 : :
7980 : : /* SPACING (s) is translated into
7981 : : int e;
7982 : : if (!isfinite (s))
7983 : : res = NaN;
7984 : : else if (s == 0)
7985 : : res = tiny;
7986 : : else
7987 : : {
7988 : : frexp (s, &e);
7989 : : e = e - prec;
7990 : : e = MAX_EXPR (e, emin);
7991 : : res = scalbn (1., e);
7992 : : }
7993 : : return res;
7994 : :
7995 : : where prec is the precision of s, gfc_real_kinds[k].digits,
7996 : : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7997 : : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7998 : :
7999 : : static void
8000 : 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8001 : : {
8002 : 70 : tree arg, type, prec, emin, tiny, res, e;
8003 : 70 : tree cond, nan, tmp, frexp, scalbn;
8004 : 70 : int k;
8005 : 70 : stmtblock_t block;
8006 : :
8007 : 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8008 : 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8009 : 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8010 : 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8011 : :
8012 : 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8013 : 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8014 : :
8015 : 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8016 : 70 : arg = gfc_evaluate_now (arg, &se->pre);
8017 : :
8018 : 70 : type = gfc_typenode_for_spec (&expr->ts);
8019 : 70 : e = gfc_create_var (integer_type_node, NULL);
8020 : 70 : res = gfc_create_var (type, NULL);
8021 : :
8022 : :
8023 : : /* Build the block for s /= 0. */
8024 : 70 : gfc_start_block (&block);
8025 : 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8026 : : gfc_build_addr_expr (NULL_TREE, e));
8027 : 70 : gfc_add_expr_to_block (&block, tmp);
8028 : :
8029 : 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8030 : : prec);
8031 : 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8032 : : integer_type_node, tmp, emin));
8033 : :
8034 : 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8035 : 70 : build_real_from_int_cst (type, integer_one_node), e);
8036 : 70 : gfc_add_modify (&block, res, tmp);
8037 : :
8038 : : /* Finish by building the IF statement for value zero. */
8039 : 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8040 : 70 : build_real_from_int_cst (type, integer_zero_node));
8041 : 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8042 : : gfc_finish_block (&block));
8043 : :
8044 : : /* And deal with infinities and NaNs. */
8045 : 70 : cond = build_call_expr_loc (input_location,
8046 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
8047 : : 1, arg);
8048 : 70 : nan = gfc_build_nan (type, "");
8049 : 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8050 : :
8051 : 70 : gfc_add_expr_to_block (&se->pre, tmp);
8052 : 70 : se->expr = res;
8053 : 70 : }
8054 : :
8055 : :
8056 : : /* RRSPACING (s) is translated into
8057 : : int e;
8058 : : real x;
8059 : : x = fabs (s);
8060 : : if (isfinite (x))
8061 : : {
8062 : : if (x != 0)
8063 : : {
8064 : : frexp (s, &e);
8065 : : x = scalbn (x, precision - e);
8066 : : }
8067 : : }
8068 : : else
8069 : : x = NaN;
8070 : : return x;
8071 : :
8072 : : where precision is gfc_real_kinds[k].digits. */
8073 : :
8074 : : static void
8075 : 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8076 : : {
8077 : 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8078 : 48 : int prec, k;
8079 : 48 : stmtblock_t block;
8080 : :
8081 : 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8082 : 48 : prec = gfc_real_kinds[k].digits;
8083 : :
8084 : 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8085 : 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8086 : 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8087 : :
8088 : 48 : type = gfc_typenode_for_spec (&expr->ts);
8089 : 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8090 : 48 : arg = gfc_evaluate_now (arg, &se->pre);
8091 : :
8092 : 48 : e = gfc_create_var (integer_type_node, NULL);
8093 : 48 : x = gfc_create_var (type, NULL);
8094 : 48 : gfc_add_modify (&se->pre, x,
8095 : : build_call_expr_loc (input_location, fabs, 1, arg));
8096 : :
8097 : :
8098 : 48 : gfc_start_block (&block);
8099 : 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8100 : : gfc_build_addr_expr (NULL_TREE, e));
8101 : 48 : gfc_add_expr_to_block (&block, tmp);
8102 : :
8103 : 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8104 : 48 : build_int_cst (integer_type_node, prec), e);
8105 : 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8106 : 48 : gfc_add_modify (&block, x, tmp);
8107 : 48 : stmt = gfc_finish_block (&block);
8108 : :
8109 : : /* if (x != 0) */
8110 : 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8111 : 48 : build_real_from_int_cst (type, integer_zero_node));
8112 : 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8113 : :
8114 : : /* And deal with infinities and NaNs. */
8115 : 48 : cond = build_call_expr_loc (input_location,
8116 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
8117 : : 1, x);
8118 : 48 : nan = gfc_build_nan (type, "");
8119 : 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8120 : :
8121 : 48 : gfc_add_expr_to_block (&se->pre, tmp);
8122 : 48 : se->expr = fold_convert (type, x);
8123 : 48 : }
8124 : :
8125 : :
8126 : : /* SCALE (s, i) is translated into scalbn (s, i). */
8127 : : static void
8128 : 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8129 : : {
8130 : 72 : tree args[2], type, scalbn;
8131 : :
8132 : 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8133 : :
8134 : 72 : type = gfc_typenode_for_spec (&expr->ts);
8135 : 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8136 : 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8137 : : fold_convert (type, args[0]),
8138 : : fold_convert (integer_type_node, args[1]));
8139 : 72 : se->expr = fold_convert (type, se->expr);
8140 : 72 : }
8141 : :
8142 : :
8143 : : /* SET_EXPONENT (s, i) is translated into
8144 : : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8145 : : static void
8146 : 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8147 : : {
8148 : 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8149 : :
8150 : 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8151 : 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8152 : :
8153 : 262 : type = gfc_typenode_for_spec (&expr->ts);
8154 : 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8155 : 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8156 : :
8157 : 262 : tmp = gfc_create_var (integer_type_node, NULL);
8158 : 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8159 : : fold_convert (type, args[0]),
8160 : : gfc_build_addr_expr (NULL_TREE, tmp));
8161 : 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8162 : : fold_convert (integer_type_node, args[1]));
8163 : 262 : res = fold_convert (type, res);
8164 : :
8165 : : /* Call to isfinite */
8166 : 262 : cond = build_call_expr_loc (input_location,
8167 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
8168 : : 1, args[0]);
8169 : 262 : nan = gfc_build_nan (type, "");
8170 : :
8171 : 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8172 : : res, nan);
8173 : 262 : }
8174 : :
8175 : :
8176 : : static void
8177 : 14745 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8178 : : {
8179 : 14745 : gfc_actual_arglist *actual;
8180 : 14745 : tree arg1;
8181 : 14745 : tree type;
8182 : 14745 : tree size;
8183 : 14745 : gfc_se argse;
8184 : 14745 : gfc_expr *e;
8185 : 14745 : gfc_symbol *sym = NULL;
8186 : :
8187 : 14745 : gfc_init_se (&argse, NULL);
8188 : 14745 : actual = expr->value.function.actual;
8189 : :
8190 : 14745 : if (actual->expr->ts.type == BT_CLASS)
8191 : 578 : gfc_add_class_array_ref (actual->expr);
8192 : :
8193 : 14745 : e = actual->expr;
8194 : :
8195 : : /* These are emerging from the interface mapping, when a class valued
8196 : : function appears as the rhs in a realloc on assign statement, where
8197 : : the size of the result is that of one of the actual arguments. */
8198 : 14745 : if (e->expr_type == EXPR_VARIABLE
8199 : 14279 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8200 : 555 : && e->symtree->n.sym->ts.type == BT_CLASS
8201 : 44 : && e->ref && e->ref->type == REF_COMPONENT
8202 : 26 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8203 : 14745 : sym = e->symtree->n.sym;
8204 : :
8205 : 14745 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8206 : : && e
8207 : 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8208 : : {
8209 : 854 : symbol_attribute attr;
8210 : 854 : char *msg;
8211 : 854 : tree temp;
8212 : 854 : tree cond;
8213 : :
8214 : 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8215 : : {
8216 : 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8217 : 33 : attr.pointer = attr.class_pointer;
8218 : : }
8219 : : else
8220 : 821 : attr = gfc_expr_attr (e);
8221 : :
8222 : 854 : if (attr.allocatable)
8223 : 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8224 : 100 : e->symtree->n.sym->name);
8225 : 754 : else if (attr.pointer)
8226 : 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8227 : 46 : e->symtree->n.sym->name);
8228 : : else
8229 : 708 : goto end_arg_check;
8230 : :
8231 : 146 : if (sym)
8232 : : {
8233 : 0 : temp = gfc_class_data_get (sym->backend_decl);
8234 : 0 : temp = gfc_conv_descriptor_data_get (temp);
8235 : : }
8236 : : else
8237 : : {
8238 : 146 : argse.descriptor_only = 1;
8239 : 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8240 : 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8241 : : }
8242 : :
8243 : 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8244 : : logical_type_node, temp,
8245 : 146 : fold_convert (TREE_TYPE (temp),
8246 : : null_pointer_node));
8247 : 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8248 : :
8249 : 146 : free (msg);
8250 : : }
8251 : 13891 : end_arg_check:
8252 : :
8253 : 14745 : argse.data_not_needed = 1;
8254 : 14745 : if (gfc_is_class_array_function (e))
8255 : : {
8256 : : /* For functions that return a class array conv_expr_descriptor is not
8257 : : able to get the descriptor right. Therefore this special case. */
8258 : 6 : gfc_conv_expr_reference (&argse, e);
8259 : 6 : argse.expr = gfc_class_data_get (argse.expr);
8260 : : }
8261 : 14739 : else if (sym && sym->backend_decl)
8262 : : {
8263 : 14 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8264 : 14 : argse.expr = gfc_class_data_get (sym->backend_decl);
8265 : : }
8266 : : else
8267 : 14725 : gfc_conv_expr_descriptor (&argse, actual->expr);
8268 : 14745 : gfc_add_block_to_block (&se->pre, &argse.pre);
8269 : 14745 : gfc_add_block_to_block (&se->post, &argse.post);
8270 : 14745 : arg1 = argse.expr;
8271 : :
8272 : 14745 : actual = actual->next;
8273 : 14745 : if (actual->expr)
8274 : : {
8275 : 8736 : stmtblock_t block;
8276 : 8736 : gfc_init_block (&block);
8277 : 8736 : gfc_init_se (&argse, NULL);
8278 : 8736 : gfc_conv_expr_type (&argse, actual->expr,
8279 : : gfc_array_index_type);
8280 : 8736 : gfc_add_block_to_block (&block, &argse.pre);
8281 : 8736 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8282 : : argse.expr, gfc_index_one_node);
8283 : 8736 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8284 : :
8285 : : /* Unusually, for an intrinsic, size does not exclude
8286 : : an optional arg2, so we must test for it. */
8287 : 8736 : if (actual->expr->expr_type == EXPR_VARIABLE
8288 : 2108 : && actual->expr->symtree->n.sym->attr.dummy
8289 : 31 : && actual->expr->symtree->n.sym->attr.optional)
8290 : : {
8291 : 31 : tree cond;
8292 : 31 : stmtblock_t block2;
8293 : 31 : gfc_init_block (&block2);
8294 : 31 : gfc_init_se (&argse, NULL);
8295 : 31 : argse.want_pointer = 1;
8296 : 31 : argse.data_not_needed = 1;
8297 : 31 : gfc_conv_expr (&argse, actual->expr);
8298 : 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8299 : : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8300 : : case; size_var can be used in both blocks. */
8301 : 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8302 : 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8303 : 31 : TREE_TYPE (size_var), size_var, size);
8304 : 31 : gfc_add_expr_to_block (&block, tmp);
8305 : 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8306 : 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8307 : 31 : TREE_TYPE (size_var), size_var, size);
8308 : 31 : gfc_add_expr_to_block (&block2, tmp);
8309 : 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8310 : 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8311 : : gfc_finish_block (&block2));
8312 : 31 : gfc_add_expr_to_block (&se->pre, tmp);
8313 : 31 : size = size_var;
8314 : 31 : }
8315 : : else
8316 : 8705 : gfc_add_block_to_block (&se->pre, &block);
8317 : : }
8318 : : else
8319 : 6009 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8320 : 14745 : type = gfc_typenode_for_spec (&expr->ts);
8321 : 14745 : se->expr = convert (type, size);
8322 : 14745 : }
8323 : :
8324 : :
8325 : : /* Helper function to compute the size of a character variable,
8326 : : excluding the terminating null characters. The result has
8327 : : gfc_array_index_type type. */
8328 : :
8329 : : tree
8330 : 1809 : size_of_string_in_bytes (int kind, tree string_length)
8331 : : {
8332 : 1809 : tree bytesize;
8333 : 1809 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8334 : :
8335 : 3618 : bytesize = build_int_cst (gfc_array_index_type,
8336 : 1809 : gfc_character_kinds[i].bit_size / 8);
8337 : :
8338 : 1809 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8339 : : bytesize,
8340 : 1809 : fold_convert (gfc_array_index_type, string_length));
8341 : : }
8342 : :
8343 : :
8344 : : static void
8345 : 1304 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8346 : : {
8347 : 1304 : gfc_expr *arg;
8348 : 1304 : gfc_se argse;
8349 : 1304 : tree source_bytes;
8350 : 1304 : tree tmp;
8351 : 1304 : tree lower;
8352 : 1304 : tree upper;
8353 : 1304 : tree byte_size;
8354 : 1304 : tree field;
8355 : 1304 : int n;
8356 : :
8357 : 1304 : gfc_init_se (&argse, NULL);
8358 : 1304 : arg = expr->value.function.actual->expr;
8359 : :
8360 : 1304 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8361 : 1012 : gfc_conv_expr_descriptor (&argse, arg);
8362 : : else
8363 : 292 : gfc_conv_expr_reference (&argse, arg);
8364 : :
8365 : 1304 : if (arg->ts.type == BT_ASSUMED)
8366 : : {
8367 : : /* This only works if an array descriptor has been passed; thus, extract
8368 : : the size from the descriptor. */
8369 : 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8370 : : == TYPE_PRECISION (size_type_node));
8371 : 172 : tmp = arg->symtree->n.sym->backend_decl;
8372 : 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8373 : 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8374 : 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8375 : 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8376 : 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8377 : :
8378 : 172 : tmp = gfc_conv_descriptor_dtype (tmp);
8379 : 172 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8380 : : GFC_DTYPE_ELEM_LEN);
8381 : 172 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8382 : : tmp, field, NULL_TREE);
8383 : :
8384 : 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8385 : : }
8386 : 1132 : else if (arg->ts.type == BT_CLASS)
8387 : : {
8388 : : /* Conv_expr_descriptor returns a component_ref to _data component of the
8389 : : class object. The class object may be a non-pointer object, e.g.
8390 : : located on the stack, or a memory location pointed to, e.g. a
8391 : : parameter, i.e., an indirect_ref. */
8392 : 954 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8393 : 584 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8394 : 198 : byte_size
8395 : 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8396 : 386 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8397 : 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8398 : 386 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8399 : 386 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8400 : 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8401 : 58 : else if (arg->rank > 0
8402 : 16 : || (arg->rank == 0
8403 : 16 : && arg->ref && arg->ref->type == REF_COMPONENT))
8404 : : {
8405 : : /* The scalarizer added an additional temp. To get the class' vptr
8406 : : one has to look at the original backend_decl. */
8407 : 58 : if (argse.class_container)
8408 : 16 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8409 : 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8410 : 84 : byte_size = gfc_class_vtab_size_get (
8411 : 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8412 : : else
8413 : 0 : gcc_unreachable ();
8414 : : }
8415 : : else
8416 : 0 : gcc_unreachable ();
8417 : : }
8418 : : else
8419 : : {
8420 : 548 : if (arg->ts.type == BT_CHARACTER)
8421 : 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8422 : : else
8423 : : {
8424 : 464 : if (arg->rank == 0)
8425 : 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8426 : : argse.expr));
8427 : : else
8428 : 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8429 : 464 : byte_size = fold_convert (gfc_array_index_type,
8430 : : size_in_bytes (byte_size));
8431 : : }
8432 : : }
8433 : :
8434 : 1304 : if (arg->rank == 0)
8435 : 292 : se->expr = byte_size;
8436 : : else
8437 : : {
8438 : 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8439 : 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8440 : :
8441 : 1012 : if (arg->rank == -1)
8442 : : {
8443 : 365 : tree cond, loop_var, exit_label;
8444 : 365 : stmtblock_t body;
8445 : :
8446 : 365 : tmp = fold_convert (gfc_array_index_type,
8447 : : gfc_conv_descriptor_rank (argse.expr));
8448 : 365 : loop_var = gfc_create_var (gfc_array_index_type, "i");
8449 : 365 : gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8450 : 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8451 : :
8452 : : /* Create loop:
8453 : : for (;;)
8454 : : {
8455 : : if (i >= rank)
8456 : : goto exit;
8457 : : source_bytes = source_bytes * array.dim[i].extent;
8458 : : i = i + 1;
8459 : : }
8460 : : exit: */
8461 : 365 : gfc_start_block (&body);
8462 : 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8463 : : loop_var, tmp);
8464 : 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8465 : 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8466 : : cond, tmp, build_empty_stmt (input_location));
8467 : 365 : gfc_add_expr_to_block (&body, tmp);
8468 : :
8469 : 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8470 : 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8471 : 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8472 : 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8473 : : gfc_array_index_type, tmp, source_bytes);
8474 : 365 : gfc_add_modify (&body, source_bytes, tmp);
8475 : :
8476 : 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8477 : : gfc_array_index_type, loop_var,
8478 : : gfc_index_one_node);
8479 : 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8480 : :
8481 : 365 : tmp = gfc_finish_block (&body);
8482 : :
8483 : 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8484 : : tmp);
8485 : 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8486 : :
8487 : 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8488 : 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8489 : : }
8490 : : else
8491 : : {
8492 : : /* Obtain the size of the array in bytes. */
8493 : 1834 : for (n = 0; n < arg->rank; n++)
8494 : : {
8495 : 1187 : tree idx;
8496 : 1187 : idx = gfc_rank_cst[n];
8497 : 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8498 : 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8499 : 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8500 : 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8501 : : gfc_array_index_type, tmp, source_bytes);
8502 : 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8503 : : }
8504 : : }
8505 : 1012 : se->expr = source_bytes;
8506 : : }
8507 : :
8508 : 1304 : gfc_add_block_to_block (&se->pre, &argse.pre);
8509 : 1304 : }
8510 : :
8511 : :
8512 : : static void
8513 : 802 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8514 : : {
8515 : 802 : gfc_expr *arg;
8516 : 802 : gfc_se argse;
8517 : 802 : tree type, result_type, tmp, class_decl = NULL;
8518 : 802 : gfc_symbol *sym;
8519 : 802 : bool unlimited = false;
8520 : :
8521 : 802 : arg = expr->value.function.actual->expr;
8522 : :
8523 : 802 : gfc_init_se (&argse, NULL);
8524 : 802 : result_type = gfc_get_int_type (expr->ts.kind);
8525 : :
8526 : 802 : if (arg->rank == 0)
8527 : : {
8528 : 211 : if (arg->ts.type == BT_CLASS)
8529 : : {
8530 : 86 : unlimited = UNLIMITED_POLY (arg);
8531 : 86 : gfc_add_vptr_component (arg);
8532 : 86 : gfc_add_size_component (arg);
8533 : 86 : gfc_conv_expr (&argse, arg);
8534 : 86 : tmp = fold_convert (result_type, argse.expr);
8535 : 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8536 : 86 : goto done;
8537 : : }
8538 : :
8539 : 125 : gfc_conv_expr_reference (&argse, arg);
8540 : 125 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8541 : : argse.expr));
8542 : : }
8543 : : else
8544 : : {
8545 : 591 : argse.want_pointer = 0;
8546 : 591 : gfc_conv_expr_descriptor (&argse, arg);
8547 : 591 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8548 : 591 : if (arg->ts.type == BT_CLASS)
8549 : : {
8550 : 60 : unlimited = UNLIMITED_POLY (arg);
8551 : 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8552 : 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8553 : 6 : else if (arg->rank > 0 && sym
8554 : 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8555 : 12 : tmp = gfc_class_vtab_size_get (
8556 : 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8557 : : else
8558 : 0 : gcc_unreachable ();
8559 : 60 : tmp = fold_convert (result_type, tmp);
8560 : 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8561 : 60 : goto done;
8562 : : }
8563 : 531 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8564 : : }
8565 : :
8566 : : /* Obtain the argument's word length. */
8567 : 656 : if (arg->ts.type == BT_CHARACTER)
8568 : 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8569 : : else
8570 : 415 : tmp = size_in_bytes (type);
8571 : 656 : tmp = fold_convert (result_type, tmp);
8572 : :
8573 : 802 : done:
8574 : 802 : if (unlimited && class_decl)
8575 : 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8576 : :
8577 : 802 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8578 : : build_int_cst (result_type, BITS_PER_UNIT));
8579 : 802 : gfc_add_block_to_block (&se->pre, &argse.pre);
8580 : 802 : }
8581 : :
8582 : :
8583 : : /* Intrinsic string comparison functions. */
8584 : :
8585 : : static void
8586 : 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8587 : : {
8588 : 99 : tree args[4];
8589 : :
8590 : 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8591 : :
8592 : 99 : se->expr
8593 : 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8594 : 99 : expr->value.function.actual->expr->ts.kind,
8595 : : op);
8596 : 99 : se->expr = fold_build2_loc (input_location, op,
8597 : : gfc_typenode_for_spec (&expr->ts), se->expr,
8598 : 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8599 : 99 : }
8600 : :
8601 : : /* Generate a call to the adjustl/adjustr library function. */
8602 : : static void
8603 : 474 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8604 : : {
8605 : 474 : tree args[3];
8606 : 474 : tree len;
8607 : 474 : tree type;
8608 : 474 : tree var;
8609 : 474 : tree tmp;
8610 : :
8611 : 474 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8612 : 474 : len = args[1];
8613 : :
8614 : 474 : type = TREE_TYPE (args[2]);
8615 : 474 : var = gfc_conv_string_tmp (se, type, len);
8616 : 474 : args[0] = var;
8617 : :
8618 : 474 : tmp = build_call_expr_loc (input_location,
8619 : : fndecl, 3, args[0], args[1], args[2]);
8620 : 474 : gfc_add_expr_to_block (&se->pre, tmp);
8621 : 474 : se->expr = var;
8622 : 474 : se->string_length = len;
8623 : 474 : }
8624 : :
8625 : :
8626 : : /* Generate code for the TRANSFER intrinsic:
8627 : : For scalar results:
8628 : : DEST = TRANSFER (SOURCE, MOLD)
8629 : : where:
8630 : : typeof<DEST> = typeof<MOLD>
8631 : : and:
8632 : : MOLD is scalar.
8633 : :
8634 : : For array results:
8635 : : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8636 : : where:
8637 : : typeof<DEST> = typeof<MOLD>
8638 : : and:
8639 : : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8640 : : sizeof (DEST(0) * SIZE). */
8641 : : static void
8642 : 3409 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8643 : : {
8644 : 3409 : tree tmp;
8645 : 3409 : tree tmpdecl;
8646 : 3409 : tree ptr;
8647 : 3409 : tree extent;
8648 : 3409 : tree source;
8649 : 3409 : tree source_type;
8650 : 3409 : tree source_bytes;
8651 : 3409 : tree mold_type;
8652 : 3409 : tree dest_word_len;
8653 : 3409 : tree size_words;
8654 : 3409 : tree size_bytes;
8655 : 3409 : tree upper;
8656 : 3409 : tree lower;
8657 : 3409 : tree stmt;
8658 : 3409 : tree class_ref = NULL_TREE;
8659 : 3409 : gfc_actual_arglist *arg;
8660 : 3409 : gfc_se argse;
8661 : 3409 : gfc_array_info *info;
8662 : 3409 : stmtblock_t block;
8663 : 3409 : int n;
8664 : 3409 : bool scalar_mold;
8665 : 3409 : gfc_expr *source_expr, *mold_expr, *class_expr;
8666 : :
8667 : 3409 : info = NULL;
8668 : 3409 : if (se->loop)
8669 : 472 : info = &se->ss->info->data.array;
8670 : :
8671 : : /* Convert SOURCE. The output from this stage is:-
8672 : : source_bytes = length of the source in bytes
8673 : : source = pointer to the source data. */
8674 : 3409 : arg = expr->value.function.actual;
8675 : 3409 : source_expr = arg->expr;
8676 : :
8677 : : /* Ensure double transfer through LOGICAL preserves all
8678 : : the needed bits. */
8679 : 3409 : if (arg->expr->expr_type == EXPR_FUNCTION
8680 : 2420 : && arg->expr->value.function.esym == NULL
8681 : 2402 : && arg->expr->value.function.isym != NULL
8682 : 2402 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8683 : 12 : && arg->expr->ts.type == BT_LOGICAL
8684 : 12 : && expr->ts.type != arg->expr->ts.type)
8685 : 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8686 : :
8687 : 3409 : gfc_init_se (&argse, NULL);
8688 : :
8689 : 3409 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8690 : :
8691 : : /* Obtain the pointer to source and the length of source in bytes. */
8692 : 3409 : if (arg->expr->rank == 0)
8693 : : {
8694 : 3053 : gfc_conv_expr_reference (&argse, arg->expr);
8695 : 3053 : if (arg->expr->ts.type == BT_CLASS)
8696 : : {
8697 : 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8698 : 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8699 : : {
8700 : 19 : source = gfc_class_data_get (tmp);
8701 : 19 : class_ref = tmp;
8702 : : }
8703 : : else
8704 : : {
8705 : : /* Array elements are evaluated as a reference to the data.
8706 : : To obtain the vptr for the element size, the argument
8707 : : expression must be stripped to the class reference and
8708 : : re-evaluated. The pre and post blocks are not needed. */
8709 : 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8710 : 18 : source = argse.expr;
8711 : 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8712 : 18 : gfc_init_se (&argse, NULL);
8713 : 18 : gfc_conv_expr (&argse, class_expr);
8714 : 18 : class_ref = argse.expr;
8715 : : }
8716 : : }
8717 : : else
8718 : 3016 : source = argse.expr;
8719 : :
8720 : : /* Obtain the source word length. */
8721 : 3053 : switch (arg->expr->ts.type)
8722 : : {
8723 : 294 : case BT_CHARACTER:
8724 : 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8725 : : argse.string_length);
8726 : 294 : break;
8727 : 37 : case BT_CLASS:
8728 : 37 : if (class_ref != NULL_TREE)
8729 : : {
8730 : 37 : tmp = gfc_class_vtab_size_get (class_ref);
8731 : 37 : if (UNLIMITED_POLY (source_expr))
8732 : 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8733 : : }
8734 : : else
8735 : : {
8736 : 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8737 : 0 : if (UNLIMITED_POLY (source_expr))
8738 : 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8739 : : }
8740 : : break;
8741 : 2722 : default:
8742 : 2722 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8743 : : source));
8744 : 2722 : tmp = fold_convert (gfc_array_index_type,
8745 : : size_in_bytes (source_type));
8746 : 2722 : break;
8747 : : }
8748 : : }
8749 : : else
8750 : : {
8751 : 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8752 : : false, true);
8753 : 356 : argse.want_pointer = 0;
8754 : : /* A non-contiguous SOURCE needs packing. */
8755 : 356 : if (!simply_contiguous)
8756 : 74 : argse.force_tmp = 1;
8757 : 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8758 : 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8759 : 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8760 : :
8761 : : /* Repack the source if not simply contiguous. */
8762 : 356 : if (!simply_contiguous)
8763 : : {
8764 : 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8765 : :
8766 : 74 : if (warn_array_temporaries)
8767 : 0 : gfc_warning (OPT_Warray_temporaries,
8768 : : "Creating array temporary at %L", &expr->where);
8769 : :
8770 : 74 : source = build_call_expr_loc (input_location,
8771 : : gfor_fndecl_in_pack, 1, tmp);
8772 : 74 : source = gfc_evaluate_now (source, &argse.pre);
8773 : :
8774 : : /* Free the temporary. */
8775 : 74 : gfc_start_block (&block);
8776 : 74 : tmp = gfc_call_free (source);
8777 : 74 : gfc_add_expr_to_block (&block, tmp);
8778 : 74 : stmt = gfc_finish_block (&block);
8779 : :
8780 : : /* Clean up if it was repacked. */
8781 : 74 : gfc_init_block (&block);
8782 : 74 : tmp = gfc_conv_array_data (argse.expr);
8783 : 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8784 : : source, tmp);
8785 : 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8786 : : build_empty_stmt (input_location));
8787 : 74 : gfc_add_expr_to_block (&block, tmp);
8788 : 74 : gfc_add_block_to_block (&block, &se->post);
8789 : 74 : gfc_init_block (&se->post);
8790 : 74 : gfc_add_block_to_block (&se->post, &block);
8791 : : }
8792 : :
8793 : : /* Obtain the source word length. */
8794 : 356 : if (arg->expr->ts.type == BT_CHARACTER)
8795 : 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8796 : : argse.string_length);
8797 : 212 : else if (arg->expr->ts.type == BT_CLASS)
8798 : : {
8799 : 54 : if (UNLIMITED_POLY (source_expr)
8800 : 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8801 : 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8802 : : (source_expr->symtree->n.sym->backend_decl);
8803 : : else
8804 : 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8805 : 54 : tmp = gfc_class_vtab_size_get (class_ref);
8806 : 54 : if (UNLIMITED_POLY (arg->expr))
8807 : 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8808 : : }
8809 : : else
8810 : 158 : tmp = fold_convert (gfc_array_index_type,
8811 : : size_in_bytes (source_type));
8812 : :
8813 : : /* Obtain the size of the array in bytes. */
8814 : 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8815 : 742 : for (n = 0; n < arg->expr->rank; n++)
8816 : : {
8817 : 386 : tree idx;
8818 : 386 : idx = gfc_rank_cst[n];
8819 : 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8820 : 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8821 : 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8822 : 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8823 : : gfc_array_index_type, upper, lower);
8824 : 386 : gfc_add_modify (&argse.pre, extent, tmp);
8825 : 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8826 : : gfc_array_index_type, extent,
8827 : : gfc_index_one_node);
8828 : 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8829 : : gfc_array_index_type, tmp, source_bytes);
8830 : : }
8831 : : }
8832 : :
8833 : 3409 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8834 : 3409 : gfc_add_block_to_block (&se->pre, &argse.pre);
8835 : 3409 : gfc_add_block_to_block (&se->post, &argse.post);
8836 : :
8837 : : /* Now convert MOLD. The outputs are:
8838 : : mold_type = the TREE type of MOLD
8839 : : dest_word_len = destination word length in bytes. */
8840 : 3409 : arg = arg->next;
8841 : 3409 : mold_expr = arg->expr;
8842 : :
8843 : 3409 : gfc_init_se (&argse, NULL);
8844 : :
8845 : 3409 : scalar_mold = arg->expr->rank == 0;
8846 : :
8847 : 3409 : if (arg->expr->rank == 0)
8848 : : {
8849 : 3086 : gfc_conv_expr_reference (&argse, mold_expr);
8850 : 3086 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8851 : : argse.expr));
8852 : : }
8853 : : else
8854 : : {
8855 : 323 : argse.want_pointer = 0;
8856 : 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8857 : 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8858 : : }
8859 : :
8860 : 3409 : gfc_add_block_to_block (&se->pre, &argse.pre);
8861 : 3409 : gfc_add_block_to_block (&se->post, &argse.post);
8862 : :
8863 : 3409 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8864 : : {
8865 : : /* If this TRANSFER is nested in another TRANSFER, use a type
8866 : : that preserves all bits. */
8867 : 12 : if (mold_expr->ts.type == BT_LOGICAL)
8868 : 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8869 : : }
8870 : :
8871 : : /* Obtain the destination word length. */
8872 : 3409 : switch (mold_expr->ts.type)
8873 : : {
8874 : 467 : case BT_CHARACTER:
8875 : 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8876 : 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8877 : : argse.string_length);
8878 : 467 : break;
8879 : 6 : case BT_CLASS:
8880 : 6 : if (scalar_mold)
8881 : 6 : class_ref = argse.expr;
8882 : : else
8883 : 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8884 : 6 : tmp = gfc_class_vtab_size_get (class_ref);
8885 : 6 : if (UNLIMITED_POLY (arg->expr))
8886 : 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8887 : : break;
8888 : 2936 : default:
8889 : 2936 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8890 : 2936 : break;
8891 : : }
8892 : :
8893 : : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8894 : : up being used before the assignment. */
8895 : 3409 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8896 : : dest_word_len = tmp;
8897 : : else
8898 : : {
8899 : 3355 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8900 : 3355 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8901 : : }
8902 : :
8903 : : /* Finally convert SIZE, if it is present. */
8904 : 3409 : arg = arg->next;
8905 : 3409 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8906 : :
8907 : 3409 : if (arg->expr)
8908 : : {
8909 : 222 : gfc_init_se (&argse, NULL);
8910 : 222 : gfc_conv_expr_reference (&argse, arg->expr);
8911 : 222 : tmp = convert (gfc_array_index_type,
8912 : : build_fold_indirect_ref_loc (input_location,
8913 : : argse.expr));
8914 : 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8915 : 222 : gfc_add_block_to_block (&se->post, &argse.post);
8916 : : }
8917 : : else
8918 : : tmp = NULL_TREE;
8919 : :
8920 : : /* Separate array and scalar results. */
8921 : 3409 : if (scalar_mold && tmp == NULL_TREE)
8922 : 2937 : goto scalar_transfer;
8923 : :
8924 : 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8925 : 472 : if (tmp != NULL_TREE)
8926 : 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8927 : : tmp, dest_word_len);
8928 : : else
8929 : : tmp = source_bytes;
8930 : :
8931 : 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8932 : 472 : gfc_add_modify (&se->pre, size_words,
8933 : : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8934 : : gfc_array_index_type,
8935 : : size_bytes, dest_word_len));
8936 : :
8937 : : /* Evaluate the bounds of the result. If the loop range exists, we have
8938 : : to check if it is too large. If so, we modify loop->to be consistent
8939 : : with min(size, size(source)). Otherwise, size is made consistent with
8940 : : the loop range, so that the right number of bytes is transferred.*/
8941 : 472 : n = se->loop->order[0];
8942 : 472 : if (se->loop->to[n] != NULL_TREE)
8943 : : {
8944 : 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8945 : : se->loop->to[n], se->loop->from[n]);
8946 : 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8947 : : tmp, gfc_index_one_node);
8948 : 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8949 : : tmp, size_words);
8950 : 205 : gfc_add_modify (&se->pre, size_words, tmp);
8951 : 205 : gfc_add_modify (&se->pre, size_bytes,
8952 : : fold_build2_loc (input_location, MULT_EXPR,
8953 : : gfc_array_index_type,
8954 : : size_words, dest_word_len));
8955 : 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8956 : 205 : size_words, se->loop->from[n]);
8957 : 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8958 : : upper, gfc_index_one_node);
8959 : : }
8960 : : else
8961 : : {
8962 : 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8963 : : size_words, gfc_index_one_node);
8964 : 267 : se->loop->from[n] = gfc_index_zero_node;
8965 : : }
8966 : :
8967 : 472 : se->loop->to[n] = upper;
8968 : :
8969 : : /* Build a destination descriptor, using the pointer, source, as the
8970 : : data field. */
8971 : 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8972 : : NULL_TREE, false, true, false, &expr->where);
8973 : :
8974 : : /* Cast the pointer to the result. */
8975 : 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8976 : 472 : tmp = fold_convert (pvoid_type_node, tmp);
8977 : :
8978 : : /* Use memcpy to do the transfer. */
8979 : 472 : tmp
8980 : 472 : = build_call_expr_loc (input_location,
8981 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
8982 : : fold_convert (pvoid_type_node, source),
8983 : : fold_convert (size_type_node,
8984 : : fold_build2_loc (input_location,
8985 : : MIN_EXPR,
8986 : : gfc_array_index_type,
8987 : : size_bytes,
8988 : : source_bytes)));
8989 : 472 : gfc_add_expr_to_block (&se->pre, tmp);
8990 : :
8991 : 472 : se->expr = info->descriptor;
8992 : 472 : if (expr->ts.type == BT_CHARACTER)
8993 : : {
8994 : 275 : tmp = fold_convert (gfc_charlen_type_node,
8995 : : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8996 : 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8997 : : gfc_charlen_type_node,
8998 : : dest_word_len, tmp);
8999 : : }
9000 : :
9001 : 472 : return;
9002 : :
9003 : : /* Deal with scalar results. */
9004 : 2937 : scalar_transfer:
9005 : 2937 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9006 : : dest_word_len, source_bytes);
9007 : 2937 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9008 : : extent, gfc_index_zero_node);
9009 : :
9010 : 2937 : if (expr->ts.type == BT_CHARACTER)
9011 : : {
9012 : 192 : tree direct, indirect, free;
9013 : :
9014 : 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9015 : 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9016 : : "transfer");
9017 : :
9018 : : /* If source is longer than the destination, use a pointer to
9019 : : the source directly. */
9020 : 192 : gfc_init_block (&block);
9021 : 192 : gfc_add_modify (&block, tmpdecl, ptr);
9022 : 192 : direct = gfc_finish_block (&block);
9023 : :
9024 : : /* Otherwise, allocate a string with the length of the destination
9025 : : and copy the source into it. */
9026 : 192 : gfc_init_block (&block);
9027 : 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9028 : 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9029 : 192 : gfc_add_modify (&block, tmpdecl,
9030 : 192 : fold_convert (TREE_TYPE (ptr), tmp));
9031 : 192 : tmp = build_call_expr_loc (input_location,
9032 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9033 : : fold_convert (pvoid_type_node, tmpdecl),
9034 : : fold_convert (pvoid_type_node, ptr),
9035 : : fold_convert (size_type_node, extent));
9036 : 192 : gfc_add_expr_to_block (&block, tmp);
9037 : 192 : indirect = gfc_finish_block (&block);
9038 : :
9039 : : /* Wrap it up with the condition. */
9040 : 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9041 : : dest_word_len, source_bytes);
9042 : 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9043 : 192 : gfc_add_expr_to_block (&se->pre, tmp);
9044 : :
9045 : : /* Free the temporary string, if necessary. */
9046 : 192 : free = gfc_call_free (tmpdecl);
9047 : 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9048 : : dest_word_len, source_bytes);
9049 : 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9050 : 192 : gfc_add_expr_to_block (&se->post, tmp);
9051 : :
9052 : 192 : se->expr = tmpdecl;
9053 : 192 : tmp = fold_convert (gfc_charlen_type_node,
9054 : : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9055 : 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9056 : : gfc_charlen_type_node,
9057 : : dest_word_len, tmp);
9058 : : }
9059 : : else
9060 : : {
9061 : 2745 : tmpdecl = gfc_create_var (mold_type, "transfer");
9062 : :
9063 : 2745 : ptr = convert (build_pointer_type (mold_type), source);
9064 : :
9065 : : /* For CLASS results, allocate the needed memory first. */
9066 : 2745 : if (mold_expr->ts.type == BT_CLASS)
9067 : : {
9068 : 6 : tree cdata;
9069 : 6 : cdata = gfc_class_data_get (tmpdecl);
9070 : 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9071 : 6 : gfc_add_modify (&se->pre, cdata, tmp);
9072 : : }
9073 : :
9074 : : /* Use memcpy to do the transfer. */
9075 : 2745 : if (mold_expr->ts.type == BT_CLASS)
9076 : 6 : tmp = gfc_class_data_get (tmpdecl);
9077 : : else
9078 : 2739 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9079 : :
9080 : 2745 : tmp = build_call_expr_loc (input_location,
9081 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9082 : : fold_convert (pvoid_type_node, tmp),
9083 : : fold_convert (pvoid_type_node, ptr),
9084 : : fold_convert (size_type_node, extent));
9085 : 2745 : gfc_add_expr_to_block (&se->pre, tmp);
9086 : :
9087 : : /* For CLASS results, set the _vptr. */
9088 : 2745 : if (mold_expr->ts.type == BT_CLASS)
9089 : 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9090 : :
9091 : 2745 : se->expr = tmpdecl;
9092 : : }
9093 : : }
9094 : :
9095 : :
9096 : : /* Generate code for the ALLOCATED intrinsic.
9097 : : Generate inline code that directly check the address of the argument. */
9098 : :
9099 : : static void
9100 : 7214 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9101 : : {
9102 : 7214 : gfc_se arg1se;
9103 : 7214 : tree tmp;
9104 : 7214 : gfc_expr *e = expr->value.function.actual->expr;
9105 : :
9106 : 7214 : gfc_init_se (&arg1se, NULL);
9107 : 7214 : if (e->ts.type == BT_CLASS)
9108 : : {
9109 : : /* Make sure that class array expressions have both a _data
9110 : : component reference and an array reference.... */
9111 : 893 : if (CLASS_DATA (e)->attr.dimension)
9112 : 418 : gfc_add_class_array_ref (e);
9113 : : /* .... whilst scalars only need the _data component. */
9114 : : else
9115 : 475 : gfc_add_data_component (e);
9116 : : }
9117 : :
9118 : 7214 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9119 : :
9120 : 7214 : if (e->rank == 0)
9121 : : {
9122 : : /* Allocatable scalar. */
9123 : 2816 : arg1se.want_pointer = 1;
9124 : 2816 : gfc_conv_expr (&arg1se, e);
9125 : 2816 : tmp = arg1se.expr;
9126 : : }
9127 : : else
9128 : : {
9129 : : /* Allocatable array. */
9130 : 4398 : arg1se.descriptor_only = 1;
9131 : 4398 : gfc_conv_expr_descriptor (&arg1se, e);
9132 : 4398 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9133 : : }
9134 : :
9135 : 7214 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9136 : 7214 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9137 : :
9138 : : /* Components of pointer array references sometimes come back with a pre block. */
9139 : 7214 : if (arg1se.pre.head)
9140 : 326 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9141 : :
9142 : 7214 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9143 : 7214 : }
9144 : :
9145 : :
9146 : : /* Generate code for the ASSOCIATED intrinsic.
9147 : : If both POINTER and TARGET are arrays, generate a call to library function
9148 : : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9149 : : In other cases, generate inline code that directly compare the address of
9150 : : POINTER with the address of TARGET. */
9151 : :
9152 : : static void
9153 : 8967 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9154 : : {
9155 : 8967 : gfc_actual_arglist *arg1;
9156 : 8967 : gfc_actual_arglist *arg2;
9157 : 8967 : gfc_se arg1se;
9158 : 8967 : gfc_se arg2se;
9159 : 8967 : tree tmp2;
9160 : 8967 : tree tmp;
9161 : 8967 : tree nonzero_arraylen = NULL_TREE;
9162 : 8967 : gfc_ss *ss;
9163 : 8967 : bool scalar;
9164 : :
9165 : 8967 : gfc_init_se (&arg1se, NULL);
9166 : 8967 : gfc_init_se (&arg2se, NULL);
9167 : 8967 : arg1 = expr->value.function.actual;
9168 : 8967 : arg2 = arg1->next;
9169 : :
9170 : : /* Check whether the expression is a scalar or not; we cannot use
9171 : : arg1->expr->rank as it can be nonzero for proc pointers. */
9172 : 8967 : ss = gfc_walk_expr (arg1->expr);
9173 : 8967 : scalar = ss == gfc_ss_terminator;
9174 : 8967 : if (!scalar)
9175 : 3846 : gfc_free_ss_chain (ss);
9176 : :
9177 : 8967 : if (!arg2->expr)
9178 : : {
9179 : : /* No optional target. */
9180 : 6634 : if (scalar)
9181 : : {
9182 : : /* A pointer to a scalar. */
9183 : 4240 : arg1se.want_pointer = 1;
9184 : 4240 : gfc_conv_expr (&arg1se, arg1->expr);
9185 : 4240 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9186 : 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9187 : 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9188 : : arg1se.expr);
9189 : 4240 : if (arg1->expr->ts.type == BT_CLASS)
9190 : : {
9191 : 384 : tmp2 = gfc_class_data_get (arg1se.expr);
9192 : 384 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9193 : 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9194 : : }
9195 : : else
9196 : 3856 : tmp2 = arg1se.expr;
9197 : : }
9198 : : else
9199 : : {
9200 : : /* A pointer to an array. */
9201 : 2394 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9202 : 2394 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9203 : : }
9204 : 6634 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9205 : 6634 : gfc_add_block_to_block (&se->post, &arg1se.post);
9206 : 6634 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9207 : 6634 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9208 : 6634 : se->expr = tmp;
9209 : : }
9210 : : else
9211 : : {
9212 : : /* An optional target. */
9213 : 2333 : if (arg2->expr->ts.type == BT_CLASS
9214 : 24 : && arg2->expr->expr_type != EXPR_FUNCTION)
9215 : 18 : gfc_add_data_component (arg2->expr);
9216 : :
9217 : 2333 : if (scalar)
9218 : : {
9219 : : /* A pointer to a scalar. */
9220 : 881 : arg1se.want_pointer = 1;
9221 : 881 : gfc_conv_expr (&arg1se, arg1->expr);
9222 : 881 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9223 : 92 : && arg1->expr->symtree->n.sym->attr.dummy)
9224 : 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9225 : : arg1se.expr);
9226 : 881 : if (arg1->expr->ts.type == BT_CLASS)
9227 : 246 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9228 : :
9229 : 881 : arg2se.want_pointer = 1;
9230 : 881 : gfc_conv_expr (&arg2se, arg2->expr);
9231 : 881 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9232 : 0 : && arg2->expr->symtree->n.sym->attr.dummy)
9233 : 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9234 : : arg2se.expr);
9235 : 881 : if (arg2->expr->ts.type == BT_CLASS)
9236 : : {
9237 : 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9238 : 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9239 : : }
9240 : 881 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9241 : 881 : gfc_add_block_to_block (&se->post, &arg1se.post);
9242 : 881 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9243 : 881 : gfc_add_block_to_block (&se->post, &arg2se.post);
9244 : 881 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9245 : : arg1se.expr, arg2se.expr);
9246 : 881 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9247 : : arg1se.expr, null_pointer_node);
9248 : 881 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9249 : : logical_type_node, tmp, tmp2);
9250 : : }
9251 : : else
9252 : : {
9253 : : /* An array pointer of zero length is not associated if target is
9254 : : present. */
9255 : 1452 : arg1se.descriptor_only = 1;
9256 : 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9257 : 1452 : if (arg1->expr->rank == -1)
9258 : : {
9259 : 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9260 : 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9261 : 84 : TREE_TYPE (tmp), tmp,
9262 : 84 : build_int_cst (TREE_TYPE (tmp), 1));
9263 : : }
9264 : : else
9265 : 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9266 : 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9267 : 1452 : if (arg2->expr->rank != 0)
9268 : 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9269 : : logical_type_node, tmp,
9270 : 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9271 : :
9272 : : /* A pointer to an array, call library function _gfor_associated. */
9273 : 1452 : arg1se.want_pointer = 1;
9274 : 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9275 : 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9276 : 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9277 : :
9278 : 1452 : arg2se.want_pointer = 1;
9279 : 1452 : arg2se.force_no_tmp = 1;
9280 : 1452 : if (arg2->expr->rank != 0)
9281 : 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9282 : : else
9283 : : {
9284 : 30 : gfc_conv_expr (&arg2se, arg2->expr);
9285 : 30 : arg2se.expr
9286 : 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9287 : 30 : gfc_expr_attr (arg2->expr));
9288 : 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9289 : : }
9290 : 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9291 : 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9292 : 1452 : se->expr = build_call_expr_loc (input_location,
9293 : : gfor_fndecl_associated, 2,
9294 : : arg1se.expr, arg2se.expr);
9295 : 1452 : se->expr = convert (logical_type_node, se->expr);
9296 : 1452 : if (arg2->expr->rank != 0)
9297 : 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9298 : : logical_type_node, se->expr,
9299 : : nonzero_arraylen);
9300 : : }
9301 : :
9302 : : /* If target is present zero character length pointers cannot
9303 : : be associated. */
9304 : 2333 : if (arg1->expr->ts.type == BT_CHARACTER)
9305 : : {
9306 : 631 : tmp = arg1se.string_length;
9307 : 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9308 : : logical_type_node, tmp,
9309 : 631 : build_zero_cst (TREE_TYPE (tmp)));
9310 : 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9311 : : logical_type_node, se->expr, tmp);
9312 : : }
9313 : : }
9314 : :
9315 : 8967 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9316 : 8967 : }
9317 : :
9318 : :
9319 : : /* Generate code for the SAME_TYPE_AS intrinsic.
9320 : : Generate inline code that directly checks the vindices. */
9321 : :
9322 : : static void
9323 : 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9324 : : {
9325 : 409 : gfc_expr *a, *b;
9326 : 409 : gfc_se se1, se2;
9327 : 409 : tree tmp;
9328 : 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9329 : :
9330 : 409 : gfc_init_se (&se1, NULL);
9331 : 409 : gfc_init_se (&se2, NULL);
9332 : :
9333 : 409 : a = expr->value.function.actual->expr;
9334 : 409 : b = expr->value.function.actual->next->expr;
9335 : :
9336 : 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9337 : 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9338 : 409 : if (unlimited_poly_a)
9339 : : {
9340 : 111 : se1.want_pointer = 1;
9341 : 111 : gfc_add_vptr_component (a);
9342 : : }
9343 : 298 : else if (a->ts.type == BT_CLASS)
9344 : : {
9345 : 256 : gfc_add_vptr_component (a);
9346 : 256 : gfc_add_hash_component (a);
9347 : : }
9348 : 42 : else if (a->ts.type == BT_DERIVED)
9349 : 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9350 : 42 : a->ts.u.derived->hash_value);
9351 : :
9352 : 409 : if (unlimited_poly_b)
9353 : : {
9354 : 72 : se2.want_pointer = 1;
9355 : 72 : gfc_add_vptr_component (b);
9356 : : }
9357 : 337 : else if (b->ts.type == BT_CLASS)
9358 : : {
9359 : 169 : gfc_add_vptr_component (b);
9360 : 169 : gfc_add_hash_component (b);
9361 : : }
9362 : 168 : else if (b->ts.type == BT_DERIVED)
9363 : 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9364 : 168 : b->ts.u.derived->hash_value);
9365 : :
9366 : 409 : gfc_conv_expr (&se1, a);
9367 : 409 : gfc_conv_expr (&se2, b);
9368 : :
9369 : 409 : if (unlimited_poly_a)
9370 : : {
9371 : 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9372 : : se1.expr,
9373 : 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9374 : 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9375 : : }
9376 : :
9377 : 409 : if (unlimited_poly_b)
9378 : : {
9379 : 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9380 : : se2.expr,
9381 : 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9382 : 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9383 : : }
9384 : :
9385 : 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9386 : : logical_type_node, se1.expr,
9387 : 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9388 : :
9389 : 409 : if (conda)
9390 : 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9391 : : logical_type_node, conda, tmp);
9392 : :
9393 : 409 : if (condb)
9394 : 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9395 : : logical_type_node, condb, tmp);
9396 : :
9397 : 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9398 : 409 : }
9399 : :
9400 : :
9401 : : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9402 : :
9403 : : static void
9404 : 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9405 : : {
9406 : 42 : tree args[2];
9407 : :
9408 : 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9409 : 42 : se->expr = build_call_expr_loc (input_location,
9410 : : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9411 : 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9412 : 42 : }
9413 : :
9414 : :
9415 : : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9416 : :
9417 : : static void
9418 : 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9419 : : {
9420 : 45 : tree arg, type;
9421 : :
9422 : 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9423 : :
9424 : : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9425 : 45 : type = gfc_get_int_type (4);
9426 : 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9427 : :
9428 : : /* Convert it to the required type. */
9429 : 45 : type = gfc_typenode_for_spec (&expr->ts);
9430 : 45 : se->expr = build_call_expr_loc (input_location,
9431 : : gfor_fndecl_si_kind, 1, arg);
9432 : 45 : se->expr = fold_convert (type, se->expr);
9433 : 45 : }
9434 : :
9435 : :
9436 : : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9437 : :
9438 : : static void
9439 : 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9440 : : {
9441 : 6 : tree arg, type;
9442 : :
9443 : 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9444 : :
9445 : : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9446 : 6 : type = gfc_get_int_type (4);
9447 : 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9448 : :
9449 : : /* Convert it to the required type. */
9450 : 6 : type = gfc_typenode_for_spec (&expr->ts);
9451 : 6 : se->expr = build_call_expr_loc (input_location,
9452 : : gfor_fndecl_sl_kind, 1, arg);
9453 : 6 : se->expr = fold_convert (type, se->expr);
9454 : 6 : }
9455 : :
9456 : :
9457 : : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9458 : :
9459 : : static void
9460 : 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9461 : : {
9462 : 82 : gfc_actual_arglist *actual;
9463 : 82 : tree type;
9464 : 82 : gfc_se argse;
9465 : 82 : vec<tree, va_gc> *args = NULL;
9466 : :
9467 : 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9468 : : {
9469 : 246 : gfc_init_se (&argse, se);
9470 : :
9471 : : /* Pass a NULL pointer for an absent arg. */
9472 : 246 : if (actual->expr == NULL)
9473 : 96 : argse.expr = null_pointer_node;
9474 : : else
9475 : : {
9476 : 150 : gfc_typespec ts;
9477 : 150 : gfc_clear_ts (&ts);
9478 : :
9479 : 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9480 : : {
9481 : : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9482 : 0 : ts.type = BT_INTEGER;
9483 : 0 : ts.kind = gfc_c_int_kind;
9484 : 0 : gfc_convert_type (actual->expr, &ts, 2);
9485 : : }
9486 : 150 : gfc_conv_expr_reference (&argse, actual->expr);
9487 : : }
9488 : :
9489 : 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9490 : 246 : gfc_add_block_to_block (&se->post, &argse.post);
9491 : 246 : vec_safe_push (args, argse.expr);
9492 : : }
9493 : :
9494 : : /* Convert it to the required type. */
9495 : 82 : type = gfc_typenode_for_spec (&expr->ts);
9496 : 82 : se->expr = build_call_expr_loc_vec (input_location,
9497 : : gfor_fndecl_sr_kind, args);
9498 : 82 : se->expr = fold_convert (type, se->expr);
9499 : 82 : }
9500 : :
9501 : :
9502 : : /* Generate code for TRIM (A) intrinsic function. */
9503 : :
9504 : : static void
9505 : 574 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9506 : : {
9507 : 574 : tree var;
9508 : 574 : tree len;
9509 : 574 : tree addr;
9510 : 574 : tree tmp;
9511 : 574 : tree cond;
9512 : 574 : tree fndecl;
9513 : 574 : tree function;
9514 : 574 : tree *args;
9515 : 574 : unsigned int num_args;
9516 : :
9517 : 574 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9518 : 574 : args = XALLOCAVEC (tree, num_args);
9519 : :
9520 : 574 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9521 : 574 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9522 : 574 : len = gfc_create_var (gfc_charlen_type_node, "len");
9523 : :
9524 : 574 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9525 : 574 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9526 : 574 : args[1] = addr;
9527 : :
9528 : 574 : if (expr->ts.kind == 1)
9529 : 542 : function = gfor_fndecl_string_trim;
9530 : 32 : else if (expr->ts.kind == 4)
9531 : 32 : function = gfor_fndecl_string_trim_char4;
9532 : : else
9533 : 0 : gcc_unreachable ();
9534 : :
9535 : 574 : fndecl = build_addr (function);
9536 : 574 : tmp = build_call_array_loc (input_location,
9537 : 574 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9538 : : num_args, args);
9539 : 574 : gfc_add_expr_to_block (&se->pre, tmp);
9540 : :
9541 : : /* Free the temporary afterwards, if necessary. */
9542 : 574 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9543 : 574 : len, build_int_cst (TREE_TYPE (len), 0));
9544 : 574 : tmp = gfc_call_free (var);
9545 : 574 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9546 : 574 : gfc_add_expr_to_block (&se->post, tmp);
9547 : :
9548 : 574 : se->expr = var;
9549 : 574 : se->string_length = len;
9550 : 574 : }
9551 : :
9552 : :
9553 : : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9554 : :
9555 : : static void
9556 : 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9557 : : {
9558 : 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9559 : 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9560 : 529 : tree size;
9561 : 529 : stmtblock_t block, body;
9562 : 529 : int i;
9563 : :
9564 : : /* We store in charsize the size of a character. */
9565 : 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9566 : 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9567 : :
9568 : : /* Get the arguments. */
9569 : 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9570 : 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9571 : 529 : src = args[1];
9572 : 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9573 : 529 : ncopies_type = TREE_TYPE (ncopies);
9574 : :
9575 : : /* Check that NCOPIES is not negative. */
9576 : 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9577 : : build_int_cst (ncopies_type, 0));
9578 : 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9579 : : "Argument NCOPIES of REPEAT intrinsic is negative "
9580 : : "(its value is %ld)",
9581 : : fold_convert (long_integer_type_node, ncopies));
9582 : :
9583 : : /* If the source length is zero, any non negative value of NCOPIES
9584 : : is valid, and nothing happens. */
9585 : 529 : n = gfc_create_var (ncopies_type, "ncopies");
9586 : 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9587 : : size_zero_node);
9588 : 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9589 : : build_int_cst (ncopies_type, 0), ncopies);
9590 : 529 : gfc_add_modify (&se->pre, n, tmp);
9591 : 529 : ncopies = n;
9592 : :
9593 : : /* Check that ncopies is not too large: ncopies should be less than
9594 : : (or equal to) MAX / slen, where MAX is the maximal integer of
9595 : : the gfc_charlen_type_node type. If slen == 0, we need a special
9596 : : case to avoid the division by zero. */
9597 : 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9598 : 529 : fold_convert (sizetype,
9599 : : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9600 : : slen);
9601 : 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9602 : 529 : ? sizetype : ncopies_type;
9603 : 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9604 : : fold_convert (largest, ncopies),
9605 : : fold_convert (largest, max));
9606 : 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9607 : : size_zero_node);
9608 : 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9609 : : logical_false_node, cond);
9610 : 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9611 : : "Argument NCOPIES of REPEAT intrinsic is too large");
9612 : :
9613 : : /* Compute the destination length. */
9614 : 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9615 : : fold_convert (gfc_charlen_type_node, slen),
9616 : : fold_convert (gfc_charlen_type_node, ncopies));
9617 : 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9618 : 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9619 : :
9620 : : /* Generate the code to do the repeat operation:
9621 : : for (i = 0; i < ncopies; i++)
9622 : : memmove (dest + (i * slen * size), src, slen*size); */
9623 : 529 : gfc_start_block (&block);
9624 : 529 : count = gfc_create_var (sizetype, "count");
9625 : 529 : gfc_add_modify (&block, count, size_zero_node);
9626 : 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9627 : :
9628 : : /* Start the loop body. */
9629 : 529 : gfc_start_block (&body);
9630 : :
9631 : : /* Exit the loop if count >= ncopies. */
9632 : 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9633 : : fold_convert (sizetype, ncopies));
9634 : 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9635 : 529 : TREE_USED (exit_label) = 1;
9636 : 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9637 : : build_empty_stmt (input_location));
9638 : 529 : gfc_add_expr_to_block (&body, tmp);
9639 : :
9640 : : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9641 : 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9642 : : count);
9643 : 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9644 : : size);
9645 : 529 : tmp = fold_build_pointer_plus_loc (input_location,
9646 : : fold_convert (pvoid_type_node, dest), tmp);
9647 : 529 : tmp = build_call_expr_loc (input_location,
9648 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9649 : : 3, tmp, src,
9650 : : fold_build2_loc (input_location, MULT_EXPR,
9651 : : size_type_node, slen, size));
9652 : 529 : gfc_add_expr_to_block (&body, tmp);
9653 : :
9654 : : /* Increment count. */
9655 : 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9656 : : count, size_one_node);
9657 : 529 : gfc_add_modify (&body, count, tmp);
9658 : :
9659 : : /* Build the loop. */
9660 : 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9661 : 529 : gfc_add_expr_to_block (&block, tmp);
9662 : :
9663 : : /* Add the exit label. */
9664 : 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9665 : 529 : gfc_add_expr_to_block (&block, tmp);
9666 : :
9667 : : /* Finish the block. */
9668 : 529 : tmp = gfc_finish_block (&block);
9669 : 529 : gfc_add_expr_to_block (&se->pre, tmp);
9670 : :
9671 : : /* Set the result value. */
9672 : 529 : se->expr = dest;
9673 : 529 : se->string_length = dlen;
9674 : 529 : }
9675 : :
9676 : :
9677 : : /* Generate code for the IARGC intrinsic. */
9678 : :
9679 : : static void
9680 : 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9681 : : {
9682 : 12 : tree tmp;
9683 : 12 : tree fndecl;
9684 : 12 : tree type;
9685 : :
9686 : : /* Call the library function. This always returns an INTEGER(4). */
9687 : 12 : fndecl = gfor_fndecl_iargc;
9688 : 12 : tmp = build_call_expr_loc (input_location,
9689 : : fndecl, 0);
9690 : :
9691 : : /* Convert it to the required type. */
9692 : 12 : type = gfc_typenode_for_spec (&expr->ts);
9693 : 12 : tmp = fold_convert (type, tmp);
9694 : :
9695 : 12 : se->expr = tmp;
9696 : 12 : }
9697 : :
9698 : :
9699 : : /* Generate code for the KILL intrinsic. */
9700 : :
9701 : : static void
9702 : 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9703 : : {
9704 : 8 : tree *args;
9705 : 8 : tree int4_type_node = gfc_get_int_type (4);
9706 : 8 : tree pid;
9707 : 8 : tree sig;
9708 : 8 : tree tmp;
9709 : 8 : unsigned int num_args;
9710 : :
9711 : 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9712 : 8 : args = XALLOCAVEC (tree, num_args);
9713 : 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9714 : :
9715 : : /* Convert PID to a INTEGER(4) entity. */
9716 : 8 : pid = convert (int4_type_node, args[0]);
9717 : :
9718 : : /* Convert SIG to a INTEGER(4) entity. */
9719 : 8 : sig = convert (int4_type_node, args[1]);
9720 : :
9721 : 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9722 : :
9723 : 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9724 : 8 : }
9725 : :
9726 : :
9727 : : static tree
9728 : 15 : conv_intrinsic_kill_sub (gfc_code *code)
9729 : : {
9730 : 15 : stmtblock_t block;
9731 : 15 : gfc_se se, se_stat;
9732 : 15 : tree int4_type_node = gfc_get_int_type (4);
9733 : 15 : tree pid;
9734 : 15 : tree sig;
9735 : 15 : tree statp;
9736 : 15 : tree tmp;
9737 : :
9738 : : /* Make the function call. */
9739 : 15 : gfc_init_block (&block);
9740 : 15 : gfc_init_se (&se, NULL);
9741 : :
9742 : : /* Convert PID to a INTEGER(4) entity. */
9743 : 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9744 : 15 : gfc_add_block_to_block (&block, &se.pre);
9745 : 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9746 : 15 : gfc_add_block_to_block (&block, &se.post);
9747 : :
9748 : : /* Convert SIG to a INTEGER(4) entity. */
9749 : 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9750 : 15 : gfc_add_block_to_block (&block, &se.pre);
9751 : 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9752 : 15 : gfc_add_block_to_block (&block, &se.post);
9753 : :
9754 : : /* Deal with an optional STATUS. */
9755 : 15 : if (code->ext.actual->next->next->expr)
9756 : : {
9757 : 10 : gfc_init_se (&se_stat, NULL);
9758 : 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9759 : 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9760 : : }
9761 : : else
9762 : : statp = NULL_TREE;
9763 : :
9764 : 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9765 : 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9766 : :
9767 : 15 : gfc_add_expr_to_block (&block, tmp);
9768 : :
9769 : 15 : if (statp && statp != se_stat.expr)
9770 : 10 : gfc_add_modify (&block, se_stat.expr,
9771 : 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9772 : :
9773 : 15 : return gfc_finish_block (&block);
9774 : : }
9775 : :
9776 : :
9777 : :
9778 : : /* The loc intrinsic returns the address of its argument as
9779 : : gfc_index_integer_kind integer. */
9780 : :
9781 : : static void
9782 : 8642 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9783 : : {
9784 : 8642 : tree temp_var;
9785 : 8642 : gfc_expr *arg_expr;
9786 : :
9787 : 8642 : gcc_assert (!se->ss);
9788 : :
9789 : 8642 : arg_expr = expr->value.function.actual->expr;
9790 : 8642 : if (arg_expr->rank == 0)
9791 : : {
9792 : 6242 : if (arg_expr->ts.type == BT_CLASS)
9793 : 18 : gfc_add_data_component (arg_expr);
9794 : 6242 : gfc_conv_expr_reference (se, arg_expr);
9795 : : }
9796 : : else
9797 : 2400 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9798 : 8642 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9799 : :
9800 : : /* Create a temporary variable for loc return value. Without this,
9801 : : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9802 : 8642 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9803 : 8642 : gfc_add_modify (&se->pre, temp_var, se->expr);
9804 : 8642 : se->expr = temp_var;
9805 : 8642 : }
9806 : :
9807 : :
9808 : : /* Specialized trim for f_c_string. */
9809 : :
9810 : : static void
9811 : 42 : conv_trim (gfc_se *tse, gfc_se *str)
9812 : : {
9813 : 42 : tree cond, plen, pvar, tlen, ttmp, tvar;
9814 : :
9815 : 42 : tlen = gfc_create_var (gfc_charlen_type_node, "tlen");
9816 : 42 : plen = gfc_build_addr_expr (NULL_TREE, tlen);
9817 : :
9818 : 42 : tvar = gfc_create_var (pchar_type_node, "tstr");
9819 : 42 : pvar = gfc_build_addr_expr (ppvoid_type_node, tvar);
9820 : :
9821 : 42 : ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4,
9822 : : plen, pvar, str->string_length, str->expr);
9823 : :
9824 : 42 : gfc_add_expr_to_block (&tse->pre, ttmp);
9825 : :
9826 : : /* Free the temporary afterwards, if necessary. */
9827 : 42 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9828 : 42 : tlen, build_int_cst (TREE_TYPE (tlen), 0));
9829 : 42 : ttmp = gfc_call_free (tvar);
9830 : 42 : ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location));
9831 : 42 : gfc_add_expr_to_block (&tse->post, ttmp);
9832 : :
9833 : 42 : tse->expr = tvar;
9834 : 42 : tse->string_length = tlen;
9835 : 42 : }
9836 : :
9837 : :
9838 : : /* The following routine generates code for the intrinsic functions from
9839 : : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9840 : : F_C_STRING. */
9841 : :
9842 : : static void
9843 : 9049 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9844 : : {
9845 : 9049 : gfc_actual_arglist *arg = expr->value.function.actual;
9846 : :
9847 : 9049 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9848 : : {
9849 : 6746 : if (arg->expr->rank == 0)
9850 : 1919 : gfc_conv_expr_reference (se, arg->expr);
9851 : 4827 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9852 : 3791 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9853 : : else
9854 : : {
9855 : 1036 : gfc_conv_expr_descriptor (se, arg->expr);
9856 : 1036 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9857 : : }
9858 : :
9859 : : /* TODO -- the following two lines shouldn't be necessary, but if
9860 : : they're removed, a bug is exposed later in the code path.
9861 : : This workaround was thus introduced, but will have to be
9862 : : removed; please see PR 35150 for details about the issue. */
9863 : 6746 : se->expr = convert (pvoid_type_node, se->expr);
9864 : 6746 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9865 : : }
9866 : 2303 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9867 : 231 : gfc_conv_expr_reference (se, arg->expr);
9868 : 2072 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9869 : : {
9870 : 2030 : gfc_se arg1se;
9871 : 2030 : gfc_se arg2se;
9872 : :
9873 : : /* Build the addr_expr for the first argument. The argument is
9874 : : already an *address* so we don't need to set want_pointer in
9875 : : the gfc_se. */
9876 : 2030 : gfc_init_se (&arg1se, NULL);
9877 : 2030 : gfc_conv_expr (&arg1se, arg->expr);
9878 : 2030 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9879 : 2030 : gfc_add_block_to_block (&se->post, &arg1se.post);
9880 : :
9881 : : /* See if we were given two arguments. */
9882 : 2030 : if (arg->next->expr == NULL)
9883 : : /* Only given one arg so generate a null and do a
9884 : : not-equal comparison against the first arg. */
9885 : 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9886 : : arg1se.expr,
9887 : 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9888 : : null_pointer_node));
9889 : : else
9890 : : {
9891 : 355 : tree eq_expr;
9892 : 355 : tree not_null_expr;
9893 : :
9894 : : /* Given two arguments so build the arg2se from second arg. */
9895 : 355 : gfc_init_se (&arg2se, NULL);
9896 : 355 : gfc_conv_expr (&arg2se, arg->next->expr);
9897 : 355 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9898 : 355 : gfc_add_block_to_block (&se->post, &arg2se.post);
9899 : :
9900 : : /* Generate test to compare that the two args are equal. */
9901 : 355 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9902 : : arg1se.expr, arg2se.expr);
9903 : : /* Generate test to ensure that the first arg is not null. */
9904 : 355 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9905 : : logical_type_node,
9906 : : arg1se.expr, null_pointer_node);
9907 : :
9908 : : /* Finally, the generated test must check that both arg1 is not
9909 : : NULL and that it is equal to the second arg. */
9910 : 355 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9911 : : logical_type_node,
9912 : : not_null_expr, eq_expr);
9913 : : }
9914 : : }
9915 : 42 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9916 : : {
9917 : : /* There are three cases:
9918 : : f_c_string(string) -> trim(string) // c_null_char
9919 : : f_c_string(string, .false.) -> trim(string) // c_null_char
9920 : : f_c_string(string, .true.) -> string // c_null_char */
9921 : :
9922 : 42 : gfc_se lse, rse, tse;
9923 : 42 : tree len, tmp, var;
9924 : 42 : gfc_expr *string = arg->expr;
9925 : 42 : gfc_expr *asis = arg->next->expr;
9926 : 42 : gfc_expr *cnc;
9927 : :
9928 : : /* Convert string. */
9929 : 42 : gfc_init_se (&lse, se);
9930 : 42 : gfc_conv_expr (&lse, string);
9931 : 42 : gfc_conv_string_parameter (&lse);
9932 : :
9933 : : /* Create a string for C_NULL_CHAR and convert it. */
9934 : 42 : cnc = gfc_get_character_expr (gfc_default_character_kind,
9935 : : &string->where, "\0", 1);
9936 : 42 : gfc_init_se (&rse, se);
9937 : 42 : gfc_conv_expr (&rse, cnc);
9938 : 42 : gfc_conv_string_parameter (&rse);
9939 : 42 : gfc_free_expr (cnc);
9940 : :
9941 : : #ifdef cnode
9942 : : #undef cnode
9943 : : #endif
9944 : : #define cnode gfc_charlen_type_node
9945 : 42 : if (asis)
9946 : : {
9947 : 30 : stmtblock_t block;
9948 : 30 : gfc_se asis_se, vse;
9949 : 30 : tree elen, evar, tlen, tvar;
9950 : 30 : tree else_branch, then_branch;
9951 : :
9952 : 30 : elen = evar = tlen = tvar = NULL_TREE;
9953 : :
9954 : : /* f_c_string(string, .true.) -> string // c_null_char */
9955 : :
9956 : 30 : gfc_init_block (&block);
9957 : :
9958 : 30 : gfc_add_block_to_block (&block, &lse.pre);
9959 : 30 : gfc_add_block_to_block (&block, &rse.pre);
9960 : :
9961 : 30 : tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
9962 : : fold_convert (cnode, lse.string_length),
9963 : : fold_convert (cnode, rse.string_length));
9964 : :
9965 : 30 : gfc_init_se (&vse, se);
9966 : 30 : tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
9967 : 30 : gfc_add_block_to_block (&block, &vse.pre);
9968 : :
9969 : 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
9970 : : 6, tlen, tvar,
9971 : : lse.string_length, lse.expr,
9972 : : rse.string_length, rse.expr);
9973 : 30 : gfc_add_expr_to_block (&block, tmp);
9974 : :
9975 : 30 : then_branch = gfc_finish_block (&block);
9976 : :
9977 : : /* f_c_string(string, .false.) = trim(string) // c_null_char */
9978 : :
9979 : 30 : gfc_init_block (&block);
9980 : :
9981 : 30 : gfc_init_se (&tse, se);
9982 : 30 : conv_trim (&tse, &lse);
9983 : 30 : gfc_add_block_to_block (&block, &tse.pre);
9984 : 30 : gfc_add_block_to_block (&block, &rse.pre);
9985 : :
9986 : 30 : elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
9987 : : fold_convert (cnode, tse.string_length),
9988 : : fold_convert (cnode, rse.string_length));
9989 : :
9990 : 30 : gfc_init_se (&vse, se);
9991 : 30 : evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
9992 : 30 : gfc_add_block_to_block (&block, &vse.pre);
9993 : :
9994 : 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
9995 : : 6, elen, evar,
9996 : : tse.string_length, tse.expr,
9997 : : rse.string_length, rse.expr);
9998 : 30 : gfc_add_expr_to_block (&block, tmp);
9999 : :
10000 : 30 : else_branch = gfc_finish_block (&block);
10001 : :
10002 : 30 : gfc_init_se (&asis_se, se);
10003 : 30 : gfc_conv_expr (&asis_se, asis);
10004 : 30 : if (asis->expr_type == EXPR_VARIABLE
10005 : 18 : && asis->symtree->n.sym->attr.dummy
10006 : 6 : && asis->symtree->n.sym->attr.optional)
10007 : : {
10008 : 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
10009 : 6 : asis_se.expr = build3_loc (input_location, COND_EXPR,
10010 : : logical_type_node, present,
10011 : : asis_se.expr,
10012 : : build_int_cst (logical_type_node, 0));
10013 : : }
10014 : 30 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10015 : 30 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10016 : : asis_se.expr, then_branch, else_branch);
10017 : :
10018 : 30 : gfc_add_expr_to_block (&se->pre, tmp);
10019 : :
10020 : 30 : var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
10021 : : asis_se.expr, tvar, evar);
10022 : 30 : gfc_add_expr_to_block (&se->pre, var);
10023 : :
10024 : 30 : len = fold_build3_loc (input_location, COND_EXPR, cnode,
10025 : : asis_se.expr, tlen, elen);
10026 : 30 : gfc_add_expr_to_block (&se->pre, len);
10027 : : }
10028 : : else
10029 : : {
10030 : : /* f_c_string(string) = trim(string) // c_null_char */
10031 : :
10032 : 12 : gfc_add_block_to_block (&se->pre, &lse.pre);
10033 : 12 : gfc_add_block_to_block (&se->pre, &rse.pre);
10034 : :
10035 : 12 : gfc_init_se (&tse, se);
10036 : 12 : conv_trim (&tse, &lse);
10037 : 12 : gfc_add_block_to_block (&se->pre, &tse.pre);
10038 : 12 : gfc_add_block_to_block (&se->post, &tse.post);
10039 : :
10040 : 12 : len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10041 : : fold_convert (cnode, tse.string_length),
10042 : : fold_convert (cnode, rse.string_length));
10043 : :
10044 : 12 : var = gfc_conv_string_tmp (se, pchar_type_node, len);
10045 : :
10046 : 12 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10047 : : 6, len, var,
10048 : : tse.string_length, tse.expr,
10049 : : rse.string_length, rse.expr);
10050 : 12 : gfc_add_expr_to_block (&se->pre, tmp);
10051 : : }
10052 : :
10053 : 42 : se->expr = var;
10054 : 42 : se->string_length = len;
10055 : :
10056 : : #undef cnode
10057 : : }
10058 : : else
10059 : 0 : gcc_unreachable ();
10060 : 9049 : }
10061 : :
10062 : :
10063 : : /* The following routine generates code for the intrinsic
10064 : : subroutines from the ISO_C_BINDING module:
10065 : : * C_F_POINTER
10066 : : * C_F_PROCPOINTER. */
10067 : :
10068 : : static tree
10069 : 2853 : conv_isocbinding_subroutine (gfc_code *code)
10070 : : {
10071 : 2853 : gfc_expr *cptr, *fptr, *shape, *lower;
10072 : 2853 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10073 : 2853 : gfc_ss *shape_ss, *lower_ss;
10074 : 2853 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10075 : 2853 : stmtblock_t body, block;
10076 : 2853 : gfc_loopinfo loop;
10077 : 2853 : gfc_actual_arglist *arg;
10078 : :
10079 : 2853 : arg = code->ext.actual;
10080 : 2853 : cptr = arg->expr;
10081 : 2853 : fptr = arg->next->expr;
10082 : 2853 : shape = arg->next->next ? arg->next->next->expr : NULL;
10083 : 2795 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10084 : :
10085 : 2853 : gfc_init_se (&se, NULL);
10086 : 2853 : gfc_init_se (&cptrse, NULL);
10087 : 2853 : gfc_conv_expr (&cptrse, cptr);
10088 : 2853 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10089 : 2853 : gfc_add_block_to_block (&se.post, &cptrse.post);
10090 : :
10091 : 2853 : gfc_init_se (&fptrse, NULL);
10092 : 2853 : if (fptr->rank == 0)
10093 : : {
10094 : 2368 : fptrse.want_pointer = 1;
10095 : 2368 : gfc_conv_expr (&fptrse, fptr);
10096 : 2368 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10097 : 2368 : gfc_add_block_to_block (&se.post, &fptrse.post);
10098 : 2368 : if (fptr->symtree->n.sym->attr.proc_pointer
10099 : 57 : && fptr->symtree->n.sym->attr.dummy)
10100 : 7 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10101 : 2368 : se.expr
10102 : 2368 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10103 : : fptrse.expr,
10104 : 2368 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10105 : 2368 : gfc_add_expr_to_block (&se.pre, se.expr);
10106 : 2368 : gfc_add_block_to_block (&se.pre, &se.post);
10107 : 2368 : return gfc_finish_block (&se.pre);
10108 : : }
10109 : :
10110 : 485 : gfc_start_block (&block);
10111 : :
10112 : : /* Get the descriptor of the Fortran pointer. */
10113 : 485 : fptrse.descriptor_only = 1;
10114 : 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10115 : 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10116 : 485 : desc = fptrse.expr;
10117 : :
10118 : : /* Set the span field. */
10119 : 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10120 : 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10121 : 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10122 : :
10123 : : /* Set data value, dtype, and offset. */
10124 : 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10125 : 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10126 : 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10127 : 485 : gfc_get_dtype (TREE_TYPE (desc)));
10128 : :
10129 : : /* Start scalarization of the bounds, using the shape argument. */
10130 : :
10131 : 485 : shape_ss = gfc_walk_expr (shape);
10132 : 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10133 : 485 : gfc_init_se (&shapese, NULL);
10134 : 485 : if (lower)
10135 : : {
10136 : 12 : lower_ss = gfc_walk_expr (lower);
10137 : 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10138 : 12 : gfc_init_se (&lowerse, NULL);
10139 : : }
10140 : :
10141 : 485 : gfc_init_loopinfo (&loop);
10142 : 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10143 : 485 : if (lower)
10144 : 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10145 : 485 : gfc_conv_ss_startstride (&loop);
10146 : 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10147 : 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10148 : 485 : if (lower)
10149 : 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10150 : :
10151 : 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10152 : 485 : shapese.ss = shape_ss;
10153 : 485 : if (lower)
10154 : : {
10155 : 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10156 : 12 : lowerse.ss = lower_ss;
10157 : : }
10158 : :
10159 : 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10160 : 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10161 : 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10162 : 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10163 : :
10164 : : /* Loop body. */
10165 : 485 : gfc_start_scalarized_body (&loop, &body);
10166 : :
10167 : 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10168 : : loop.loopvar[0], loop.from[0]);
10169 : :
10170 : 485 : if (lower)
10171 : : {
10172 : 12 : gfc_conv_expr (&lowerse, lower);
10173 : 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10174 : 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10175 : 12 : gfc_add_block_to_block (&body, &lowerse.post);
10176 : : }
10177 : : else
10178 : 473 : lbound = gfc_index_one_node;
10179 : :
10180 : : /* Set bounds and stride. */
10181 : 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10182 : 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10183 : :
10184 : 485 : gfc_conv_expr (&shapese, shape);
10185 : 485 : gfc_add_block_to_block (&body, &shapese.pre);
10186 : 485 : ubound = fold_build2_loc (
10187 : : input_location, MINUS_EXPR, gfc_array_index_type,
10188 : : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10189 : : fold_convert (gfc_array_index_type, shapese.expr)),
10190 : : gfc_index_one_node);
10191 : 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10192 : 485 : gfc_add_block_to_block (&body, &shapese.post);
10193 : :
10194 : : /* Calculate offset. */
10195 : 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10196 : : stride, lbound);
10197 : 485 : gfc_add_modify (&body, offset,
10198 : : fold_build2_loc (input_location, PLUS_EXPR,
10199 : : gfc_array_index_type, offset, tmp));
10200 : :
10201 : : /* Update stride. */
10202 : 485 : gfc_add_modify (
10203 : : &body, stride,
10204 : : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10205 : : fold_convert (gfc_array_index_type, shapese.expr)));
10206 : : /* Finish scalarization loop. */
10207 : 485 : gfc_trans_scalarizing_loops (&loop, &body);
10208 : 485 : gfc_add_block_to_block (&block, &loop.pre);
10209 : 485 : gfc_add_block_to_block (&block, &loop.post);
10210 : 485 : gfc_add_block_to_block (&block, &fptrse.post);
10211 : 485 : gfc_cleanup_loop (&loop);
10212 : :
10213 : 485 : gfc_add_modify (&block, offset,
10214 : : fold_build1_loc (input_location, NEGATE_EXPR,
10215 : : gfc_array_index_type, offset));
10216 : 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10217 : :
10218 : 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10219 : 485 : gfc_add_block_to_block (&se.pre, &se.post);
10220 : 485 : return gfc_finish_block (&se.pre);
10221 : : }
10222 : :
10223 : :
10224 : : /* Save and restore floating-point state. */
10225 : :
10226 : : tree
10227 : 948 : gfc_save_fp_state (stmtblock_t *block)
10228 : : {
10229 : 948 : tree type, fpstate, tmp;
10230 : :
10231 : 948 : type = build_array_type (char_type_node,
10232 : : build_range_type (size_type_node, size_zero_node,
10233 : : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10234 : 948 : fpstate = gfc_create_var (type, "fpstate");
10235 : 948 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10236 : :
10237 : 948 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10238 : : 1, fpstate);
10239 : 948 : gfc_add_expr_to_block (block, tmp);
10240 : :
10241 : 948 : return fpstate;
10242 : : }
10243 : :
10244 : :
10245 : : void
10246 : 948 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10247 : : {
10248 : 948 : tree tmp;
10249 : :
10250 : 948 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10251 : : 1, fpstate);
10252 : 948 : gfc_add_expr_to_block (block, tmp);
10253 : 948 : }
10254 : :
10255 : :
10256 : : /* Generate code for arguments of IEEE functions. */
10257 : :
10258 : : static void
10259 : 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10260 : : int nargs)
10261 : : {
10262 : 12457 : gfc_actual_arglist *actual;
10263 : 12457 : gfc_expr *e;
10264 : 12457 : gfc_se argse;
10265 : 12457 : int arg;
10266 : :
10267 : 12457 : actual = expr->value.function.actual;
10268 : 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10269 : : {
10270 : 22004 : gcc_assert (actual);
10271 : 22004 : e = actual->expr;
10272 : :
10273 : 22004 : gfc_init_se (&argse, se);
10274 : 22004 : gfc_conv_expr_val (&argse, e);
10275 : :
10276 : 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10277 : 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10278 : 22004 : argarray[arg] = argse.expr;
10279 : : }
10280 : 12457 : }
10281 : :
10282 : :
10283 : : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10284 : : and IEEE_UNORDERED, which translate directly to GCC type-generic
10285 : : built-ins. */
10286 : :
10287 : : static void
10288 : 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10289 : : enum built_in_function code, int nargs)
10290 : : {
10291 : 1062 : tree args[2];
10292 : 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10293 : :
10294 : 1062 : conv_ieee_function_args (se, expr, args, nargs);
10295 : 1062 : se->expr = build_call_expr_loc_array (input_location,
10296 : : builtin_decl_explicit (code),
10297 : : nargs, args);
10298 : 2388 : STRIP_TYPE_NOPS (se->expr);
10299 : 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10300 : 1062 : }
10301 : :
10302 : :
10303 : : /* Generate code for intrinsics IEEE_SIGNBIT. */
10304 : :
10305 : : static void
10306 : 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10307 : : {
10308 : 624 : tree arg, signbit;
10309 : :
10310 : 624 : conv_ieee_function_args (se, expr, &arg, 1);
10311 : 624 : signbit = build_call_expr_loc (input_location,
10312 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10313 : : 1, arg);
10314 : 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10315 : : signbit, integer_zero_node);
10316 : 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10317 : 624 : }
10318 : :
10319 : :
10320 : : /* Generate code for IEEE_IS_NORMAL intrinsic:
10321 : : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10322 : :
10323 : : static void
10324 : 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10325 : : {
10326 : 312 : tree arg, isnormal, iszero;
10327 : :
10328 : : /* Convert arg, evaluate it only once. */
10329 : 312 : conv_ieee_function_args (se, expr, &arg, 1);
10330 : 312 : arg = gfc_evaluate_now (arg, &se->pre);
10331 : :
10332 : 312 : isnormal = build_call_expr_loc (input_location,
10333 : : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10334 : : 1, arg);
10335 : 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10336 : 312 : build_real_from_int_cst (TREE_TYPE (arg),
10337 : 312 : integer_zero_node));
10338 : 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10339 : : logical_type_node, isnormal, iszero);
10340 : 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10341 : 312 : }
10342 : :
10343 : :
10344 : : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10345 : : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10346 : :
10347 : : static void
10348 : 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10349 : : {
10350 : 312 : tree arg, signbit, isnan;
10351 : :
10352 : : /* Convert arg, evaluate it only once. */
10353 : 312 : conv_ieee_function_args (se, expr, &arg, 1);
10354 : 312 : arg = gfc_evaluate_now (arg, &se->pre);
10355 : :
10356 : 312 : isnan = build_call_expr_loc (input_location,
10357 : : builtin_decl_explicit (BUILT_IN_ISNAN),
10358 : : 1, arg);
10359 : 936 : STRIP_TYPE_NOPS (isnan);
10360 : :
10361 : 312 : signbit = build_call_expr_loc (input_location,
10362 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10363 : : 1, arg);
10364 : 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10365 : : signbit, integer_zero_node);
10366 : :
10367 : 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10368 : : logical_type_node, signbit,
10369 : : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10370 : 312 : TREE_TYPE(isnan), isnan));
10371 : :
10372 : 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10373 : 312 : }
10374 : :
10375 : :
10376 : : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10377 : :
10378 : : static void
10379 : 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10380 : : enum built_in_function code)
10381 : : {
10382 : 240 : tree arg, decl, call, fpstate;
10383 : 240 : int argprec;
10384 : :
10385 : 240 : conv_ieee_function_args (se, expr, &arg, 1);
10386 : 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10387 : 240 : decl = builtin_decl_for_precision (code, argprec);
10388 : :
10389 : : /* Save floating-point state. */
10390 : 240 : fpstate = gfc_save_fp_state (&se->pre);
10391 : :
10392 : : /* Make the function call. */
10393 : 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10394 : 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10395 : :
10396 : : /* Restore floating-point state. */
10397 : 240 : gfc_restore_fp_state (&se->post, fpstate);
10398 : 240 : }
10399 : :
10400 : :
10401 : : /* Generate code for IEEE_REM. */
10402 : :
10403 : : static void
10404 : 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10405 : : {
10406 : 84 : tree args[2], decl, call, fpstate;
10407 : 84 : int argprec;
10408 : :
10409 : 84 : conv_ieee_function_args (se, expr, args, 2);
10410 : :
10411 : : /* If arguments have unequal size, convert them to the larger. */
10412 : 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10413 : 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10414 : 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10415 : 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10416 : 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10417 : 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10418 : :
10419 : 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10420 : 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10421 : :
10422 : : /* Save floating-point state. */
10423 : 84 : fpstate = gfc_save_fp_state (&se->pre);
10424 : :
10425 : : /* Make the function call. */
10426 : 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10427 : 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10428 : :
10429 : : /* Restore floating-point state. */
10430 : 84 : gfc_restore_fp_state (&se->post, fpstate);
10431 : 84 : }
10432 : :
10433 : :
10434 : : /* Generate code for IEEE_NEXT_AFTER. */
10435 : :
10436 : : static void
10437 : 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10438 : : {
10439 : 180 : tree args[2], decl, call, fpstate;
10440 : 180 : int argprec;
10441 : :
10442 : 180 : conv_ieee_function_args (se, expr, args, 2);
10443 : :
10444 : : /* Result has the characteristics of first argument. */
10445 : 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10446 : 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10447 : 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10448 : :
10449 : : /* Save floating-point state. */
10450 : 180 : fpstate = gfc_save_fp_state (&se->pre);
10451 : :
10452 : : /* Make the function call. */
10453 : 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10454 : 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10455 : :
10456 : : /* Restore floating-point state. */
10457 : 180 : gfc_restore_fp_state (&se->post, fpstate);
10458 : 180 : }
10459 : :
10460 : :
10461 : : /* Generate code for IEEE_SCALB. */
10462 : :
10463 : : static void
10464 : 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10465 : : {
10466 : 228 : tree args[2], decl, call, huge, type;
10467 : 228 : int argprec, n;
10468 : :
10469 : 228 : conv_ieee_function_args (se, expr, args, 2);
10470 : :
10471 : : /* Result has the characteristics of first argument. */
10472 : 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10473 : 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10474 : :
10475 : 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10476 : : {
10477 : : /* We need to fold the integer into the range of a C int. */
10478 : 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10479 : 18 : type = TREE_TYPE (args[1]);
10480 : :
10481 : 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10482 : 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10483 : : gfc_c_int_kind);
10484 : 18 : huge = fold_convert (type, huge);
10485 : 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10486 : : huge);
10487 : 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10488 : : fold_build1_loc (input_location, NEGATE_EXPR,
10489 : : type, huge));
10490 : : }
10491 : :
10492 : 228 : args[1] = fold_convert (integer_type_node, args[1]);
10493 : :
10494 : : /* Make the function call. */
10495 : 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10496 : 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10497 : 228 : }
10498 : :
10499 : :
10500 : : /* Generate code for IEEE_COPY_SIGN. */
10501 : :
10502 : : static void
10503 : 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10504 : : {
10505 : 576 : tree args[2], decl, sign;
10506 : 576 : int argprec;
10507 : :
10508 : 576 : conv_ieee_function_args (se, expr, args, 2);
10509 : :
10510 : : /* Get the sign of the second argument. */
10511 : 576 : sign = build_call_expr_loc (input_location,
10512 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10513 : : 1, args[1]);
10514 : 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10515 : : sign, integer_zero_node);
10516 : :
10517 : : /* Create a value of one, with the right sign. */
10518 : 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10519 : : sign,
10520 : : fold_build1_loc (input_location, NEGATE_EXPR,
10521 : : integer_type_node,
10522 : : integer_one_node),
10523 : : integer_one_node);
10524 : 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10525 : :
10526 : 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10527 : 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10528 : :
10529 : 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10530 : 576 : }
10531 : :
10532 : :
10533 : : /* Generate code for IEEE_CLASS. */
10534 : :
10535 : : static void
10536 : 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10537 : : {
10538 : 648 : tree arg, c, t1, t2, t3, t4;
10539 : :
10540 : : /* Convert arg, evaluate it only once. */
10541 : 648 : conv_ieee_function_args (se, expr, &arg, 1);
10542 : 648 : arg = gfc_evaluate_now (arg, &se->pre);
10543 : :
10544 : 648 : c = build_call_expr_loc (input_location,
10545 : : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10546 : : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10547 : : build_int_cst (integer_type_node,
10548 : : IEEE_POSITIVE_INF),
10549 : : build_int_cst (integer_type_node,
10550 : : IEEE_POSITIVE_NORMAL),
10551 : : build_int_cst (integer_type_node,
10552 : : IEEE_POSITIVE_DENORMAL),
10553 : : build_int_cst (integer_type_node,
10554 : : IEEE_POSITIVE_ZERO),
10555 : : arg);
10556 : 648 : c = gfc_evaluate_now (c, &se->pre);
10557 : 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10558 : : c, build_int_cst (integer_type_node,
10559 : : IEEE_QUIET_NAN));
10560 : 648 : t2 = build_call_expr_loc (input_location,
10561 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10562 : : arg);
10563 : 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10564 : 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10565 : 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10566 : : logical_type_node, t1, t2);
10567 : 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10568 : : c, build_int_cst (integer_type_node,
10569 : : IEEE_POSITIVE_ZERO));
10570 : 648 : t4 = build_call_expr_loc (input_location,
10571 : : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10572 : : arg);
10573 : 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10574 : 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10575 : 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10576 : : logical_type_node, t3, t4);
10577 : 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10578 : 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10579 : 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10580 : 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10581 : 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10582 : 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10583 : 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10584 : 648 : build_int_cst (TREE_TYPE (c), s), c);
10585 : 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10586 : : t3, t4, c);
10587 : 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10588 : 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10589 : : t3);
10590 : 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10591 : : /* Perform a quick sanity check that the return type is
10592 : : IEEE_CLASS_TYPE derived type defined in
10593 : : libgfortran/ieee/ieee_arithmetic.F90
10594 : : Primarily check that it is a derived type with a single
10595 : : member in it. */
10596 : 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10597 : 648 : tree field = NULL_TREE;
10598 : 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10599 : 648 : if (TREE_CODE (f) == FIELD_DECL)
10600 : : {
10601 : 648 : gcc_assert (field == NULL_TREE);
10602 : : field = f;
10603 : : }
10604 : 648 : gcc_assert (field);
10605 : 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10606 : 648 : se->expr = build_constructor_single (type, field, t1);
10607 : 648 : }
10608 : :
10609 : :
10610 : : /* Generate code for IEEE_VALUE. */
10611 : :
10612 : : static void
10613 : 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10614 : : {
10615 : 1111 : tree args[2], arg, ret, tmp;
10616 : 1111 : stmtblock_t body;
10617 : :
10618 : : /* Convert args, evaluate the second one only once. */
10619 : 1111 : conv_ieee_function_args (se, expr, args, 2);
10620 : 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10621 : :
10622 : 1111 : tree type = TREE_TYPE (arg);
10623 : : /* Perform a quick sanity check that the second argument's type is
10624 : : IEEE_CLASS_TYPE derived type defined in
10625 : : libgfortran/ieee/ieee_arithmetic.F90
10626 : : Primarily check that it is a derived type with a single
10627 : : member in it. */
10628 : 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10629 : 1111 : tree field = NULL_TREE;
10630 : 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10631 : 1111 : if (TREE_CODE (f) == FIELD_DECL)
10632 : : {
10633 : 1111 : gcc_assert (field == NULL_TREE);
10634 : : field = f;
10635 : : }
10636 : 1111 : gcc_assert (field);
10637 : 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10638 : : arg, field, NULL_TREE);
10639 : 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10640 : :
10641 : 1111 : type = gfc_typenode_for_spec (&expr->ts);
10642 : 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10643 : 1111 : ret = gfc_create_var (type, NULL);
10644 : :
10645 : 1111 : gfc_init_block (&body);
10646 : :
10647 : 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10648 : 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10649 : : {
10650 : 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10651 : 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10652 : 11110 : tmp = build_case_label (low, low, label);
10653 : 11110 : gfc_add_expr_to_block (&body, tmp);
10654 : :
10655 : 11110 : REAL_VALUE_TYPE real;
10656 : 11110 : int k;
10657 : 11110 : switch (c)
10658 : : {
10659 : 1111 : case IEEE_SIGNALING_NAN:
10660 : 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10661 : 1111 : break;
10662 : 1111 : case IEEE_QUIET_NAN:
10663 : 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10664 : 1111 : break;
10665 : 1111 : case IEEE_NEGATIVE_INF:
10666 : 1111 : real_inf (&real);
10667 : 1111 : real = real_value_negate (&real);
10668 : 1111 : break;
10669 : 1111 : case IEEE_NEGATIVE_NORMAL:
10670 : 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10671 : 1111 : break;
10672 : 1111 : case IEEE_NEGATIVE_DENORMAL:
10673 : 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10674 : 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10675 : : type, GFC_RND_MODE);
10676 : 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10677 : 1111 : real = real_value_negate (&real);
10678 : 1111 : break;
10679 : 1111 : case IEEE_NEGATIVE_ZERO:
10680 : 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10681 : 1111 : real = real_value_negate (&real);
10682 : 1111 : break;
10683 : 1111 : case IEEE_POSITIVE_ZERO:
10684 : : /* Make this also the default: label. The other possibility
10685 : : would be to add a separate default: label followed by
10686 : : __builtin_unreachable (). */
10687 : 1111 : label = gfc_build_label_decl (NULL_TREE);
10688 : 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10689 : 1111 : gfc_add_expr_to_block (&body, tmp);
10690 : 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10691 : 1111 : break;
10692 : 1111 : case IEEE_POSITIVE_DENORMAL:
10693 : 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10694 : 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10695 : : type, GFC_RND_MODE);
10696 : 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10697 : 1111 : break;
10698 : 1111 : case IEEE_POSITIVE_NORMAL:
10699 : 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10700 : 1111 : break;
10701 : 1111 : case IEEE_POSITIVE_INF:
10702 : 1111 : real_inf (&real);
10703 : 1111 : break;
10704 : : default:
10705 : : gcc_unreachable ();
10706 : : }
10707 : :
10708 : 11110 : tree val = build_real (type, real);
10709 : 11110 : gfc_add_modify (&body, ret, val);
10710 : :
10711 : 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10712 : 11110 : gfc_add_expr_to_block (&body, tmp);
10713 : : }
10714 : :
10715 : 1111 : tmp = gfc_finish_block (&body);
10716 : 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10717 : 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10718 : :
10719 : 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10720 : 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10721 : :
10722 : 1111 : se->expr = ret;
10723 : 1111 : }
10724 : :
10725 : :
10726 : : /* Generate code for IEEE_FMA. */
10727 : :
10728 : : static void
10729 : 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10730 : : {
10731 : 120 : tree args[3], decl, call;
10732 : 120 : int argprec;
10733 : :
10734 : 120 : conv_ieee_function_args (se, expr, args, 3);
10735 : :
10736 : : /* All three arguments should have the same type. */
10737 : 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10738 : 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10739 : :
10740 : : /* Call the type-generic FMA built-in. */
10741 : 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10742 : 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10743 : 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10744 : :
10745 : : /* Convert to the final type. */
10746 : 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10747 : 120 : }
10748 : :
10749 : :
10750 : : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10751 : :
10752 : : static void
10753 : 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10754 : : const char *name)
10755 : : {
10756 : 3072 : tree args[2], func;
10757 : 3072 : built_in_function fn;
10758 : :
10759 : 3072 : conv_ieee_function_args (se, expr, args, 2);
10760 : 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10761 : 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10762 : 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10763 : :
10764 : 3072 : if (startswith (name, "mag"))
10765 : : {
10766 : : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10767 : : fminmag() and fmaxmag(), which do not exist as built-ins.
10768 : :
10769 : : Following glibc, we emit this:
10770 : :
10771 : : fminmag (x, y) {
10772 : : ax = ABS (x);
10773 : : ay = ABS (y);
10774 : : if (isless (ax, ay))
10775 : : return x;
10776 : : else if (isgreater (ax, ay))
10777 : : return y;
10778 : : else if (ax == ay)
10779 : : return x < y ? x : y;
10780 : : else if (issignaling (x) || issignaling (y))
10781 : : return x + y;
10782 : : else
10783 : : return isnan (y) ? x : y;
10784 : : }
10785 : :
10786 : : fmaxmag (x, y) {
10787 : : ax = ABS (x);
10788 : : ay = ABS (y);
10789 : : if (isgreater (ax, ay))
10790 : : return x;
10791 : : else if (isless (ax, ay))
10792 : : return y;
10793 : : else if (ax == ay)
10794 : : return x > y ? x : y;
10795 : : else if (issignaling (x) || issignaling (y))
10796 : : return x + y;
10797 : : else
10798 : : return isnan (y) ? x : y;
10799 : : }
10800 : :
10801 : : */
10802 : :
10803 : 1536 : tree abs0, abs1, sig0, sig1;
10804 : 1536 : tree cond1, cond2, cond3, cond4, cond5;
10805 : 1536 : tree res;
10806 : 1536 : tree type = TREE_TYPE (args[0]);
10807 : :
10808 : 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10809 : 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10810 : 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10811 : 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10812 : 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10813 : :
10814 : 1536 : cond5 = build_call_expr_loc (input_location,
10815 : : builtin_decl_explicit (BUILT_IN_ISNAN),
10816 : : 1, args[1]);
10817 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10818 : : args[0], args[1]);
10819 : :
10820 : 1536 : sig0 = build_call_expr_loc (input_location,
10821 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10822 : : 1, args[0]);
10823 : 1536 : sig1 = build_call_expr_loc (input_location,
10824 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10825 : : 1, args[1]);
10826 : 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10827 : : logical_type_node, sig0, sig1);
10828 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10829 : : fold_build2_loc (input_location, PLUS_EXPR,
10830 : : type, args[0], args[1]),
10831 : : res);
10832 : :
10833 : 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10834 : : abs0, abs1);
10835 : 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10836 : : fold_build2_loc (input_location,
10837 : : max ? MAX_EXPR : MIN_EXPR,
10838 : : type, args[0], args[1]),
10839 : : res);
10840 : :
10841 : 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10842 : 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10843 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10844 : : args[1], res);
10845 : :
10846 : 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10847 : 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10848 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10849 : : args[0], res);
10850 : :
10851 : 1536 : se->expr = res;
10852 : : }
10853 : : else
10854 : : {
10855 : : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10856 : 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10857 : 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
10858 : 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10859 : : }
10860 : 3072 : }
10861 : :
10862 : :
10863 : : /* Generate code for comparison functions IEEE_QUIET_* and
10864 : : IEEE_SIGNALING_*. */
10865 : :
10866 : : static void
10867 : 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10868 : : const char *name)
10869 : : {
10870 : 3888 : tree args[2];
10871 : 3888 : tree arg1, arg2, res;
10872 : :
10873 : : /* Evaluate arguments only once. */
10874 : 3888 : conv_ieee_function_args (se, expr, args, 2);
10875 : 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
10876 : 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
10877 : :
10878 : 3888 : if (startswith (name, "eq"))
10879 : : {
10880 : 648 : if (signaling)
10881 : 324 : res = build_call_expr_loc (input_location,
10882 : : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10883 : : 2, arg1, arg2);
10884 : : else
10885 : 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10886 : : arg1, arg2);
10887 : : }
10888 : 3240 : else if (startswith (name, "ne"))
10889 : : {
10890 : 648 : if (signaling)
10891 : : {
10892 : 324 : res = build_call_expr_loc (input_location,
10893 : : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10894 : : 2, arg1, arg2);
10895 : 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10896 : : logical_type_node, res);
10897 : : }
10898 : : else
10899 : 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10900 : : arg1, arg2);
10901 : : }
10902 : 2592 : else if (startswith (name, "ge"))
10903 : : {
10904 : 648 : if (signaling)
10905 : 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10906 : : arg1, arg2);
10907 : : else
10908 : 324 : res = build_call_expr_loc (input_location,
10909 : : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
10910 : : 2, arg1, arg2);
10911 : : }
10912 : 1944 : else if (startswith (name, "gt"))
10913 : : {
10914 : 648 : if (signaling)
10915 : 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10916 : : arg1, arg2);
10917 : : else
10918 : 324 : res = build_call_expr_loc (input_location,
10919 : : builtin_decl_explicit (BUILT_IN_ISGREATER),
10920 : : 2, arg1, arg2);
10921 : : }
10922 : 1296 : else if (startswith (name, "le"))
10923 : : {
10924 : 648 : if (signaling)
10925 : 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10926 : : arg1, arg2);
10927 : : else
10928 : 324 : res = build_call_expr_loc (input_location,
10929 : : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
10930 : : 2, arg1, arg2);
10931 : : }
10932 : 648 : else if (startswith (name, "lt"))
10933 : : {
10934 : 648 : if (signaling)
10935 : 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10936 : : arg1, arg2);
10937 : : else
10938 : 324 : res = build_call_expr_loc (input_location,
10939 : : builtin_decl_explicit (BUILT_IN_ISLESS),
10940 : : 2, arg1, arg2);
10941 : : }
10942 : : else
10943 : 0 : gcc_unreachable ();
10944 : :
10945 : 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10946 : 3888 : }
10947 : :
10948 : :
10949 : : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10950 : : module. */
10951 : :
10952 : : bool
10953 : 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10954 : : {
10955 : 13939 : const char *name = expr->value.function.name;
10956 : :
10957 : 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
10958 : 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
10959 : 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
10960 : 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
10961 : 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
10962 : 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
10963 : 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
10964 : 624 : conv_intrinsic_ieee_signbit (se, expr);
10965 : 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
10966 : 312 : conv_intrinsic_ieee_is_normal (se, expr);
10967 : 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
10968 : 312 : conv_intrinsic_ieee_is_negative (se, expr);
10969 : 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
10970 : 576 : conv_intrinsic_ieee_copy_sign (se, expr);
10971 : 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
10972 : 228 : conv_intrinsic_ieee_scalb (se, expr);
10973 : 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
10974 : 180 : conv_intrinsic_ieee_next_after (se, expr);
10975 : 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
10976 : 84 : conv_intrinsic_ieee_rem (se, expr);
10977 : 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
10978 : 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
10979 : 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
10980 : 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
10981 : 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
10982 : 648 : conv_intrinsic_ieee_class (se, expr);
10983 : 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
10984 : 1111 : conv_intrinsic_ieee_value (se, expr);
10985 : 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
10986 : 120 : conv_intrinsic_ieee_fma (se, expr);
10987 : 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
10988 : 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
10989 : 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
10990 : 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
10991 : 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
10992 : 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
10993 : 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
10994 : 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
10995 : : else
10996 : : /* It is not among the functions we translate directly. We return
10997 : : false, so a library function call is emitted. */
10998 : : return false;
10999 : :
11000 : : return true;
11001 : : }
11002 : :
11003 : :
11004 : : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11005 : :
11006 : : static void
11007 : 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11008 : : {
11009 : 16 : tree arg, res, restype;
11010 : :
11011 : 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11012 : 16 : arg = fold_convert (size_type_node, arg);
11013 : 16 : res = build_call_expr_loc (input_location,
11014 : : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11015 : 16 : restype = gfc_typenode_for_spec (&expr->ts);
11016 : 16 : se->expr = fold_convert (restype, res);
11017 : 16 : }
11018 : :
11019 : :
11020 : : /* Generate code for an intrinsic function. Some map directly to library
11021 : : calls, others get special handling. In some cases the name of the function
11022 : : used depends on the type specifiers. */
11023 : :
11024 : : void
11025 : 254555 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11026 : : {
11027 : 254555 : const char *name;
11028 : 254555 : int lib, kind;
11029 : 254555 : tree fndecl;
11030 : :
11031 : 254555 : name = &expr->value.function.name[2];
11032 : :
11033 : 254555 : if (expr->rank > 0)
11034 : : {
11035 : 50907 : lib = gfc_is_intrinsic_libcall (expr);
11036 : 50907 : if (lib != 0)
11037 : : {
11038 : 19282 : if (lib == 1)
11039 : 11673 : se->ignore_optional = 1;
11040 : :
11041 : 19282 : switch (expr->value.function.isym->id)
11042 : : {
11043 : 6086 : case GFC_ISYM_EOSHIFT:
11044 : 6086 : case GFC_ISYM_PACK:
11045 : 6086 : case GFC_ISYM_RESHAPE:
11046 : 6086 : case GFC_ISYM_REDUCE:
11047 : : /* For all of those the first argument specifies the type and the
11048 : : third is optional. */
11049 : 6086 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11050 : 6086 : break;
11051 : :
11052 : 1116 : case GFC_ISYM_FINDLOC:
11053 : 1116 : gfc_conv_intrinsic_findloc (se, expr);
11054 : 1116 : break;
11055 : :
11056 : 2935 : case GFC_ISYM_MINLOC:
11057 : 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11058 : 2935 : break;
11059 : :
11060 : 2439 : case GFC_ISYM_MAXLOC:
11061 : 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11062 : 2439 : break;
11063 : :
11064 : 6706 : default:
11065 : 6706 : gfc_conv_intrinsic_funcall (se, expr);
11066 : 6706 : break;
11067 : : }
11068 : :
11069 : 19282 : return;
11070 : : }
11071 : : }
11072 : :
11073 : 235273 : switch (expr->value.function.isym->id)
11074 : : {
11075 : 0 : case GFC_ISYM_NONE:
11076 : 0 : gcc_unreachable ();
11077 : :
11078 : 529 : case GFC_ISYM_REPEAT:
11079 : 529 : gfc_conv_intrinsic_repeat (se, expr);
11080 : 529 : break;
11081 : :
11082 : 574 : case GFC_ISYM_TRIM:
11083 : 574 : gfc_conv_intrinsic_trim (se, expr);
11084 : 574 : break;
11085 : :
11086 : 42 : case GFC_ISYM_SC_KIND:
11087 : 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11088 : 42 : break;
11089 : :
11090 : 45 : case GFC_ISYM_SI_KIND:
11091 : 45 : gfc_conv_intrinsic_si_kind (se, expr);
11092 : 45 : break;
11093 : :
11094 : 6 : case GFC_ISYM_SL_KIND:
11095 : 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11096 : 6 : break;
11097 : :
11098 : 82 : case GFC_ISYM_SR_KIND:
11099 : 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11100 : 82 : break;
11101 : :
11102 : 228 : case GFC_ISYM_EXPONENT:
11103 : 228 : gfc_conv_intrinsic_exponent (se, expr);
11104 : 228 : break;
11105 : :
11106 : 316 : case GFC_ISYM_SCAN:
11107 : 316 : kind = expr->value.function.actual->expr->ts.kind;
11108 : 316 : if (kind == 1)
11109 : 250 : fndecl = gfor_fndecl_string_scan;
11110 : 66 : else if (kind == 4)
11111 : 66 : fndecl = gfor_fndecl_string_scan_char4;
11112 : : else
11113 : 0 : gcc_unreachable ();
11114 : :
11115 : 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11116 : 316 : break;
11117 : :
11118 : 94 : case GFC_ISYM_VERIFY:
11119 : 94 : kind = expr->value.function.actual->expr->ts.kind;
11120 : 94 : if (kind == 1)
11121 : 70 : fndecl = gfor_fndecl_string_verify;
11122 : 24 : else if (kind == 4)
11123 : 24 : fndecl = gfor_fndecl_string_verify_char4;
11124 : : else
11125 : 0 : gcc_unreachable ();
11126 : :
11127 : 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11128 : 94 : break;
11129 : :
11130 : 7214 : case GFC_ISYM_ALLOCATED:
11131 : 7214 : gfc_conv_allocated (se, expr);
11132 : 7214 : break;
11133 : :
11134 : 8967 : case GFC_ISYM_ASSOCIATED:
11135 : 8967 : gfc_conv_associated(se, expr);
11136 : 8967 : break;
11137 : :
11138 : 409 : case GFC_ISYM_SAME_TYPE_AS:
11139 : 409 : gfc_conv_same_type_as (se, expr);
11140 : 409 : break;
11141 : :
11142 : 7747 : case GFC_ISYM_ABS:
11143 : 7747 : gfc_conv_intrinsic_abs (se, expr);
11144 : 7747 : break;
11145 : :
11146 : 351 : case GFC_ISYM_ADJUSTL:
11147 : 351 : if (expr->ts.kind == 1)
11148 : 297 : fndecl = gfor_fndecl_adjustl;
11149 : 54 : else if (expr->ts.kind == 4)
11150 : 54 : fndecl = gfor_fndecl_adjustl_char4;
11151 : : else
11152 : 0 : gcc_unreachable ();
11153 : :
11154 : 351 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11155 : 351 : break;
11156 : :
11157 : 123 : case GFC_ISYM_ADJUSTR:
11158 : 123 : if (expr->ts.kind == 1)
11159 : 68 : fndecl = gfor_fndecl_adjustr;
11160 : 55 : else if (expr->ts.kind == 4)
11161 : 55 : fndecl = gfor_fndecl_adjustr_char4;
11162 : : else
11163 : 0 : gcc_unreachable ();
11164 : :
11165 : 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11166 : 123 : break;
11167 : :
11168 : 428 : case GFC_ISYM_AIMAG:
11169 : 428 : gfc_conv_intrinsic_imagpart (se, expr);
11170 : 428 : break;
11171 : :
11172 : 146 : case GFC_ISYM_AINT:
11173 : 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11174 : 146 : break;
11175 : :
11176 : 419 : case GFC_ISYM_ALL:
11177 : 419 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11178 : 419 : break;
11179 : :
11180 : 74 : case GFC_ISYM_ANINT:
11181 : 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11182 : 74 : break;
11183 : :
11184 : 90 : case GFC_ISYM_AND:
11185 : 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11186 : 90 : break;
11187 : :
11188 : 36880 : case GFC_ISYM_ANY:
11189 : 36880 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11190 : 36880 : break;
11191 : :
11192 : 216 : case GFC_ISYM_ACOSD:
11193 : 216 : case GFC_ISYM_ASIND:
11194 : 216 : case GFC_ISYM_ATAND:
11195 : 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11196 : 216 : break;
11197 : :
11198 : 102 : case GFC_ISYM_COTAN:
11199 : 102 : gfc_conv_intrinsic_cotan (se, expr);
11200 : 102 : break;
11201 : :
11202 : 108 : case GFC_ISYM_COTAND:
11203 : 108 : gfc_conv_intrinsic_cotand (se, expr);
11204 : 108 : break;
11205 : :
11206 : 120 : case GFC_ISYM_ATAN2D:
11207 : 120 : gfc_conv_intrinsic_atan2d (se, expr);
11208 : 120 : break;
11209 : :
11210 : 145 : case GFC_ISYM_BTEST:
11211 : 145 : gfc_conv_intrinsic_btest (se, expr);
11212 : 145 : break;
11213 : :
11214 : 54 : case GFC_ISYM_BGE:
11215 : 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11216 : 54 : break;
11217 : :
11218 : 54 : case GFC_ISYM_BGT:
11219 : 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11220 : 54 : break;
11221 : :
11222 : 54 : case GFC_ISYM_BLE:
11223 : 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11224 : 54 : break;
11225 : :
11226 : 54 : case GFC_ISYM_BLT:
11227 : 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11228 : 54 : break;
11229 : :
11230 : 9049 : case GFC_ISYM_C_ASSOCIATED:
11231 : 9049 : case GFC_ISYM_C_FUNLOC:
11232 : 9049 : case GFC_ISYM_C_LOC:
11233 : 9049 : case GFC_ISYM_F_C_STRING:
11234 : 9049 : conv_isocbinding_function (se, expr);
11235 : 9049 : break;
11236 : :
11237 : 2020 : case GFC_ISYM_ACHAR:
11238 : 2020 : case GFC_ISYM_CHAR:
11239 : 2020 : gfc_conv_intrinsic_char (se, expr);
11240 : 2020 : break;
11241 : :
11242 : 38401 : case GFC_ISYM_CONVERSION:
11243 : 38401 : case GFC_ISYM_DBLE:
11244 : 38401 : case GFC_ISYM_DFLOAT:
11245 : 38401 : case GFC_ISYM_FLOAT:
11246 : 38401 : case GFC_ISYM_LOGICAL:
11247 : 38401 : case GFC_ISYM_REAL:
11248 : 38401 : case GFC_ISYM_REALPART:
11249 : 38401 : case GFC_ISYM_SNGL:
11250 : 38401 : gfc_conv_intrinsic_conversion (se, expr);
11251 : 38401 : break;
11252 : :
11253 : : /* Integer conversions are handled separately to make sure we get the
11254 : : correct rounding mode. */
11255 : 2799 : case GFC_ISYM_INT:
11256 : 2799 : case GFC_ISYM_INT2:
11257 : 2799 : case GFC_ISYM_INT8:
11258 : 2799 : case GFC_ISYM_LONG:
11259 : 2799 : case GFC_ISYM_UINT:
11260 : 2799 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11261 : 2799 : break;
11262 : :
11263 : 162 : case GFC_ISYM_NINT:
11264 : 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11265 : 162 : break;
11266 : :
11267 : 16 : case GFC_ISYM_CEILING:
11268 : 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11269 : 16 : break;
11270 : :
11271 : 116 : case GFC_ISYM_FLOOR:
11272 : 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11273 : 116 : break;
11274 : :
11275 : 2824 : case GFC_ISYM_MOD:
11276 : 2824 : gfc_conv_intrinsic_mod (se, expr, 0);
11277 : 2824 : break;
11278 : :
11279 : 434 : case GFC_ISYM_MODULO:
11280 : 434 : gfc_conv_intrinsic_mod (se, expr, 1);
11281 : 434 : break;
11282 : :
11283 : 895 : case GFC_ISYM_CAF_GET:
11284 : 895 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11285 : 895 : break;
11286 : :
11287 : 132 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11288 : 132 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11289 : 132 : break;
11290 : :
11291 : 485 : case GFC_ISYM_CMPLX:
11292 : 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11293 : 485 : break;
11294 : :
11295 : 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11296 : 10 : gfc_conv_intrinsic_iargc (se, expr);
11297 : 10 : break;
11298 : :
11299 : 6 : case GFC_ISYM_COMPLEX:
11300 : 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11301 : 6 : break;
11302 : :
11303 : 257 : case GFC_ISYM_CONJG:
11304 : 257 : gfc_conv_intrinsic_conjg (se, expr);
11305 : 257 : break;
11306 : :
11307 : 143 : case GFC_ISYM_COUNT:
11308 : 143 : gfc_conv_intrinsic_count (se, expr);
11309 : 143 : break;
11310 : :
11311 : 0 : case GFC_ISYM_CTIME:
11312 : 0 : gfc_conv_intrinsic_ctime (se, expr);
11313 : 0 : break;
11314 : :
11315 : 96 : case GFC_ISYM_DIM:
11316 : 96 : gfc_conv_intrinsic_dim (se, expr);
11317 : 96 : break;
11318 : :
11319 : 113 : case GFC_ISYM_DOT_PRODUCT:
11320 : 113 : gfc_conv_intrinsic_dot_product (se, expr);
11321 : 113 : break;
11322 : :
11323 : 13 : case GFC_ISYM_DPROD:
11324 : 13 : gfc_conv_intrinsic_dprod (se, expr);
11325 : 13 : break;
11326 : :
11327 : 66 : case GFC_ISYM_DSHIFTL:
11328 : 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11329 : 66 : break;
11330 : :
11331 : 66 : case GFC_ISYM_DSHIFTR:
11332 : 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11333 : 66 : break;
11334 : :
11335 : 0 : case GFC_ISYM_FDATE:
11336 : 0 : gfc_conv_intrinsic_fdate (se, expr);
11337 : 0 : break;
11338 : :
11339 : 60 : case GFC_ISYM_FRACTION:
11340 : 60 : gfc_conv_intrinsic_fraction (se, expr);
11341 : 60 : break;
11342 : :
11343 : 24 : case GFC_ISYM_IALL:
11344 : 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11345 : 24 : break;
11346 : :
11347 : 600 : case GFC_ISYM_IAND:
11348 : 600 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11349 : 600 : break;
11350 : :
11351 : 12 : case GFC_ISYM_IANY:
11352 : 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11353 : 12 : break;
11354 : :
11355 : 168 : case GFC_ISYM_IBCLR:
11356 : 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11357 : 168 : break;
11358 : :
11359 : 27 : case GFC_ISYM_IBITS:
11360 : 27 : gfc_conv_intrinsic_ibits (se, expr);
11361 : 27 : break;
11362 : :
11363 : 138 : case GFC_ISYM_IBSET:
11364 : 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11365 : 138 : break;
11366 : :
11367 : 2033 : case GFC_ISYM_IACHAR:
11368 : 2033 : case GFC_ISYM_ICHAR:
11369 : : /* We assume ASCII character sequence. */
11370 : 2033 : gfc_conv_intrinsic_ichar (se, expr);
11371 : 2033 : break;
11372 : :
11373 : 2 : case GFC_ISYM_IARGC:
11374 : 2 : gfc_conv_intrinsic_iargc (se, expr);
11375 : 2 : break;
11376 : :
11377 : 688 : case GFC_ISYM_IEOR:
11378 : 688 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11379 : 688 : break;
11380 : :
11381 : 341 : case GFC_ISYM_INDEX:
11382 : 341 : kind = expr->value.function.actual->expr->ts.kind;
11383 : 341 : if (kind == 1)
11384 : 275 : fndecl = gfor_fndecl_string_index;
11385 : 66 : else if (kind == 4)
11386 : 66 : fndecl = gfor_fndecl_string_index_char4;
11387 : : else
11388 : 0 : gcc_unreachable ();
11389 : :
11390 : 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11391 : 341 : break;
11392 : :
11393 : 483 : case GFC_ISYM_IOR:
11394 : 483 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11395 : 483 : break;
11396 : :
11397 : 12 : case GFC_ISYM_IPARITY:
11398 : 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11399 : 12 : break;
11400 : :
11401 : 6 : case GFC_ISYM_IS_IOSTAT_END:
11402 : 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11403 : 6 : break;
11404 : :
11405 : 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11406 : 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11407 : 18 : break;
11408 : :
11409 : 729 : case GFC_ISYM_IS_CONTIGUOUS:
11410 : 729 : gfc_conv_intrinsic_is_contiguous (se, expr);
11411 : 729 : break;
11412 : :
11413 : 432 : case GFC_ISYM_ISNAN:
11414 : 432 : gfc_conv_intrinsic_isnan (se, expr);
11415 : 432 : break;
11416 : :
11417 : 8 : case GFC_ISYM_KILL:
11418 : 8 : conv_intrinsic_kill (se, expr);
11419 : 8 : break;
11420 : :
11421 : 90 : case GFC_ISYM_LSHIFT:
11422 : 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11423 : 90 : break;
11424 : :
11425 : 24 : case GFC_ISYM_RSHIFT:
11426 : 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11427 : 24 : break;
11428 : :
11429 : 78 : case GFC_ISYM_SHIFTA:
11430 : 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11431 : 78 : break;
11432 : :
11433 : 183 : case GFC_ISYM_SHIFTL:
11434 : 183 : gfc_conv_intrinsic_shift (se, expr, false, false);
11435 : 183 : break;
11436 : :
11437 : 66 : case GFC_ISYM_SHIFTR:
11438 : 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11439 : 66 : break;
11440 : :
11441 : 318 : case GFC_ISYM_ISHFT:
11442 : 318 : gfc_conv_intrinsic_ishft (se, expr);
11443 : 318 : break;
11444 : :
11445 : 658 : case GFC_ISYM_ISHFTC:
11446 : 658 : gfc_conv_intrinsic_ishftc (se, expr);
11447 : 658 : break;
11448 : :
11449 : 270 : case GFC_ISYM_LEADZ:
11450 : 270 : gfc_conv_intrinsic_leadz (se, expr);
11451 : 270 : break;
11452 : :
11453 : 282 : case GFC_ISYM_TRAILZ:
11454 : 282 : gfc_conv_intrinsic_trailz (se, expr);
11455 : 282 : break;
11456 : :
11457 : 103 : case GFC_ISYM_POPCNT:
11458 : 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11459 : 103 : break;
11460 : :
11461 : 31 : case GFC_ISYM_POPPAR:
11462 : 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11463 : 31 : break;
11464 : :
11465 : 5500 : case GFC_ISYM_LBOUND:
11466 : 5500 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11467 : 5500 : break;
11468 : :
11469 : 178 : case GFC_ISYM_LCOBOUND:
11470 : 178 : conv_intrinsic_cobound (se, expr);
11471 : 178 : break;
11472 : :
11473 : 744 : case GFC_ISYM_TRANSPOSE:
11474 : : /* The scalarizer has already been set up for reversed dimension access
11475 : : order ; now we just get the argument value normally. */
11476 : 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
11477 : 744 : break;
11478 : :
11479 : 5643 : case GFC_ISYM_LEN:
11480 : 5643 : gfc_conv_intrinsic_len (se, expr);
11481 : 5643 : break;
11482 : :
11483 : 2321 : case GFC_ISYM_LEN_TRIM:
11484 : 2321 : gfc_conv_intrinsic_len_trim (se, expr);
11485 : 2321 : break;
11486 : :
11487 : 18 : case GFC_ISYM_LGE:
11488 : 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11489 : 18 : break;
11490 : :
11491 : 36 : case GFC_ISYM_LGT:
11492 : 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11493 : 36 : break;
11494 : :
11495 : 18 : case GFC_ISYM_LLE:
11496 : 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11497 : 18 : break;
11498 : :
11499 : 27 : case GFC_ISYM_LLT:
11500 : 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11501 : 27 : break;
11502 : :
11503 : 16 : case GFC_ISYM_MALLOC:
11504 : 16 : gfc_conv_intrinsic_malloc (se, expr);
11505 : 16 : break;
11506 : :
11507 : 32 : case GFC_ISYM_MASKL:
11508 : 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11509 : 32 : break;
11510 : :
11511 : 32 : case GFC_ISYM_MASKR:
11512 : 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11513 : 32 : break;
11514 : :
11515 : 1051 : case GFC_ISYM_MAX:
11516 : 1051 : if (expr->ts.type == BT_CHARACTER)
11517 : 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11518 : : else
11519 : 913 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11520 : : break;
11521 : :
11522 : 6348 : case GFC_ISYM_MAXLOC:
11523 : 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11524 : 6348 : break;
11525 : :
11526 : 216 : case GFC_ISYM_FINDLOC:
11527 : 216 : gfc_conv_intrinsic_findloc (se, expr);
11528 : 216 : break;
11529 : :
11530 : 1100 : case GFC_ISYM_MAXVAL:
11531 : 1100 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11532 : 1100 : break;
11533 : :
11534 : 949 : case GFC_ISYM_MERGE:
11535 : 949 : gfc_conv_intrinsic_merge (se, expr);
11536 : 949 : break;
11537 : :
11538 : 42 : case GFC_ISYM_MERGE_BITS:
11539 : 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11540 : 42 : break;
11541 : :
11542 : 551 : case GFC_ISYM_MIN:
11543 : 551 : if (expr->ts.type == BT_CHARACTER)
11544 : 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11545 : : else
11546 : 407 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11547 : : break;
11548 : :
11549 : 7176 : case GFC_ISYM_MINLOC:
11550 : 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11551 : 7176 : break;
11552 : :
11553 : 1316 : case GFC_ISYM_MINVAL:
11554 : 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11555 : 1316 : break;
11556 : :
11557 : 1595 : case GFC_ISYM_NEAREST:
11558 : 1595 : gfc_conv_intrinsic_nearest (se, expr);
11559 : 1595 : break;
11560 : :
11561 : 68 : case GFC_ISYM_NORM2:
11562 : 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11563 : 68 : break;
11564 : :
11565 : 230 : case GFC_ISYM_NOT:
11566 : 230 : gfc_conv_intrinsic_not (se, expr);
11567 : 230 : break;
11568 : :
11569 : 12 : case GFC_ISYM_OR:
11570 : 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11571 : 12 : break;
11572 : :
11573 : 468 : case GFC_ISYM_OUT_OF_RANGE:
11574 : 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11575 : 468 : break;
11576 : :
11577 : 36 : case GFC_ISYM_PARITY:
11578 : 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11579 : 36 : break;
11580 : :
11581 : 5070 : case GFC_ISYM_PRESENT:
11582 : 5070 : gfc_conv_intrinsic_present (se, expr);
11583 : 5070 : break;
11584 : :
11585 : 344 : case GFC_ISYM_PRODUCT:
11586 : 344 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11587 : 344 : break;
11588 : :
11589 : 10970 : case GFC_ISYM_RANK:
11590 : 10970 : gfc_conv_intrinsic_rank (se, expr);
11591 : 10970 : break;
11592 : :
11593 : 48 : case GFC_ISYM_RRSPACING:
11594 : 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11595 : 48 : break;
11596 : :
11597 : 262 : case GFC_ISYM_SET_EXPONENT:
11598 : 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11599 : 262 : break;
11600 : :
11601 : 72 : case GFC_ISYM_SCALE:
11602 : 72 : gfc_conv_intrinsic_scale (se, expr);
11603 : 72 : break;
11604 : :
11605 : 4823 : case GFC_ISYM_SHAPE:
11606 : 4823 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11607 : 4823 : break;
11608 : :
11609 : 424 : case GFC_ISYM_SIGN:
11610 : 424 : gfc_conv_intrinsic_sign (se, expr);
11611 : 424 : break;
11612 : :
11613 : 14745 : case GFC_ISYM_SIZE:
11614 : 14745 : gfc_conv_intrinsic_size (se, expr);
11615 : 14745 : break;
11616 : :
11617 : 1304 : case GFC_ISYM_SIZEOF:
11618 : 1304 : case GFC_ISYM_C_SIZEOF:
11619 : 1304 : gfc_conv_intrinsic_sizeof (se, expr);
11620 : 1304 : break;
11621 : :
11622 : 802 : case GFC_ISYM_STORAGE_SIZE:
11623 : 802 : gfc_conv_intrinsic_storage_size (se, expr);
11624 : 802 : break;
11625 : :
11626 : 70 : case GFC_ISYM_SPACING:
11627 : 70 : gfc_conv_intrinsic_spacing (se, expr);
11628 : 70 : break;
11629 : :
11630 : 1966 : case GFC_ISYM_STRIDE:
11631 : 1966 : conv_intrinsic_stride (se, expr);
11632 : 1966 : break;
11633 : :
11634 : 2003 : case GFC_ISYM_SUM:
11635 : 2003 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11636 : 2003 : break;
11637 : :
11638 : 19 : case GFC_ISYM_TEAM_NUMBER:
11639 : 19 : conv_intrinsic_team_number (se, expr);
11640 : 19 : break;
11641 : :
11642 : 3690 : case GFC_ISYM_TRANSFER:
11643 : 3690 : if (se->ss && se->ss->info->useflags)
11644 : : /* Access the previously obtained result. */
11645 : 281 : gfc_conv_tmp_array_ref (se);
11646 : : else
11647 : 3409 : gfc_conv_intrinsic_transfer (se, expr);
11648 : : break;
11649 : :
11650 : 0 : case GFC_ISYM_TTYNAM:
11651 : 0 : gfc_conv_intrinsic_ttynam (se, expr);
11652 : 0 : break;
11653 : :
11654 : 5679 : case GFC_ISYM_UBOUND:
11655 : 5679 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11656 : 5679 : break;
11657 : :
11658 : 191 : case GFC_ISYM_UCOBOUND:
11659 : 191 : conv_intrinsic_cobound (se, expr);
11660 : 191 : break;
11661 : :
11662 : 18 : case GFC_ISYM_XOR:
11663 : 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11664 : 18 : break;
11665 : :
11666 : 8642 : case GFC_ISYM_LOC:
11667 : 8642 : gfc_conv_intrinsic_loc (se, expr);
11668 : 8642 : break;
11669 : :
11670 : 935 : case GFC_ISYM_THIS_IMAGE:
11671 : : /* For num_images() == 1, handle as LCOBOUND. */
11672 : 935 : if (expr->value.function.actual->expr
11673 : 379 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11674 : 208 : conv_intrinsic_cobound (se, expr);
11675 : : else
11676 : 727 : trans_this_image (se, expr);
11677 : : break;
11678 : :
11679 : 152 : case GFC_ISYM_IMAGE_INDEX:
11680 : 152 : trans_image_index (se, expr);
11681 : 152 : break;
11682 : :
11683 : 16 : case GFC_ISYM_IMAGE_STATUS:
11684 : 16 : conv_intrinsic_image_status (se, expr);
11685 : 16 : break;
11686 : :
11687 : 429 : case GFC_ISYM_NUM_IMAGES:
11688 : 429 : trans_num_images (se, expr);
11689 : 429 : break;
11690 : :
11691 : 1372 : case GFC_ISYM_ACCESS:
11692 : 1372 : case GFC_ISYM_CHDIR:
11693 : 1372 : case GFC_ISYM_CHMOD:
11694 : 1372 : case GFC_ISYM_DTIME:
11695 : 1372 : case GFC_ISYM_ETIME:
11696 : 1372 : case GFC_ISYM_EXTENDS_TYPE_OF:
11697 : 1372 : case GFC_ISYM_FGET:
11698 : 1372 : case GFC_ISYM_FGETC:
11699 : 1372 : case GFC_ISYM_FNUM:
11700 : 1372 : case GFC_ISYM_FPUT:
11701 : 1372 : case GFC_ISYM_FPUTC:
11702 : 1372 : case GFC_ISYM_FSTAT:
11703 : 1372 : case GFC_ISYM_FTELL:
11704 : 1372 : case GFC_ISYM_GETCWD:
11705 : 1372 : case GFC_ISYM_GETGID:
11706 : 1372 : case GFC_ISYM_GETPID:
11707 : 1372 : case GFC_ISYM_GETUID:
11708 : 1372 : case GFC_ISYM_GET_TEAM:
11709 : 1372 : case GFC_ISYM_HOSTNM:
11710 : 1372 : case GFC_ISYM_IERRNO:
11711 : 1372 : case GFC_ISYM_IRAND:
11712 : 1372 : case GFC_ISYM_ISATTY:
11713 : 1372 : case GFC_ISYM_JN2:
11714 : 1372 : case GFC_ISYM_LINK:
11715 : 1372 : case GFC_ISYM_LSTAT:
11716 : 1372 : case GFC_ISYM_MATMUL:
11717 : 1372 : case GFC_ISYM_MCLOCK:
11718 : 1372 : case GFC_ISYM_MCLOCK8:
11719 : 1372 : case GFC_ISYM_RAND:
11720 : 1372 : case GFC_ISYM_REDUCE:
11721 : 1372 : case GFC_ISYM_RENAME:
11722 : 1372 : case GFC_ISYM_SECOND:
11723 : 1372 : case GFC_ISYM_SECNDS:
11724 : 1372 : case GFC_ISYM_SIGNAL:
11725 : 1372 : case GFC_ISYM_STAT:
11726 : 1372 : case GFC_ISYM_SYMLNK:
11727 : 1372 : case GFC_ISYM_SYSTEM:
11728 : 1372 : case GFC_ISYM_TIME:
11729 : 1372 : case GFC_ISYM_TIME8:
11730 : 1372 : case GFC_ISYM_UMASK:
11731 : 1372 : case GFC_ISYM_UNLINK:
11732 : 1372 : case GFC_ISYM_YN2:
11733 : 1372 : gfc_conv_intrinsic_funcall (se, expr);
11734 : 1372 : break;
11735 : :
11736 : 0 : case GFC_ISYM_EOSHIFT:
11737 : 0 : case GFC_ISYM_PACK:
11738 : 0 : case GFC_ISYM_RESHAPE:
11739 : : /* For those, expr->rank should always be >0 and thus the if above the
11740 : : switch should have matched. */
11741 : 0 : gcc_unreachable ();
11742 : 3846 : break;
11743 : :
11744 : 3846 : default:
11745 : 3846 : gfc_conv_intrinsic_lib_function (se, expr);
11746 : 3846 : break;
11747 : : }
11748 : : }
11749 : :
11750 : :
11751 : : static gfc_ss *
11752 : 1560 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11753 : : {
11754 : 1560 : gfc_ss *arg_ss, *tmp_ss;
11755 : 1560 : gfc_actual_arglist *arg;
11756 : :
11757 : 1560 : arg = expr->value.function.actual;
11758 : :
11759 : 1560 : gcc_assert (arg->expr);
11760 : :
11761 : 1560 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11762 : 1560 : gcc_assert (arg_ss != gfc_ss_terminator);
11763 : :
11764 : : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11765 : : {
11766 : 1665 : if (tmp_ss->info->type != GFC_SS_SCALAR
11767 : : && tmp_ss->info->type != GFC_SS_REFERENCE)
11768 : : {
11769 : 1628 : gcc_assert (tmp_ss->dimen == 2);
11770 : :
11771 : : /* We just invert dimensions. */
11772 : 1628 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11773 : : }
11774 : :
11775 : : /* Stop when tmp_ss points to the last valid element of the chain... */
11776 : 1665 : if (tmp_ss->next == gfc_ss_terminator)
11777 : : break;
11778 : : }
11779 : :
11780 : : /* ... so that we can attach the rest of the chain to it. */
11781 : 1560 : tmp_ss->next = ss;
11782 : :
11783 : 1560 : return arg_ss;
11784 : : }
11785 : :
11786 : :
11787 : : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11788 : : This has the side effect of reversing the nested list, so there is no
11789 : : need to call gfc_reverse_ss on it (the given list is assumed not to be
11790 : : reversed yet). */
11791 : :
11792 : : static gfc_ss *
11793 : 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11794 : : {
11795 : 3371 : int ss_dim, i;
11796 : 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11797 : 3371 : gfc_loopinfo *new_loop;
11798 : :
11799 : 3371 : gcc_assert (ss != gfc_ss_terminator);
11800 : :
11801 : 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11802 : : {
11803 : 4747 : new_ss = gfc_get_ss ();
11804 : 4747 : new_ss->next = prev_ss;
11805 : 4747 : new_ss->parent = ss;
11806 : 4747 : new_ss->info = ss->info;
11807 : 4747 : new_ss->info->refcount++;
11808 : 4747 : if (ss->dimen != 0)
11809 : : {
11810 : 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11811 : : && ss->info->type != GFC_SS_REFERENCE);
11812 : :
11813 : 4684 : new_ss->dimen = 1;
11814 : 4684 : new_ss->dim[0] = ss->dim[dim];
11815 : :
11816 : 4684 : gcc_assert (dim < ss->dimen);
11817 : :
11818 : 4684 : ss_dim = --ss->dimen;
11819 : 10430 : for (i = dim; i < ss_dim; i++)
11820 : 5746 : ss->dim[i] = ss->dim[i + 1];
11821 : :
11822 : 4684 : ss->dim[ss_dim] = 0;
11823 : : }
11824 : 4747 : prev_ss = new_ss;
11825 : :
11826 : 4747 : if (ss->nested_ss)
11827 : : {
11828 : 81 : ss->nested_ss->parent = new_ss;
11829 : 81 : new_ss->nested_ss = ss->nested_ss;
11830 : : }
11831 : 4747 : ss->nested_ss = new_ss;
11832 : : }
11833 : :
11834 : 3371 : new_loop = gfc_get_loopinfo ();
11835 : 3371 : gfc_init_loopinfo (new_loop);
11836 : :
11837 : 3371 : gcc_assert (prev_ss != NULL);
11838 : 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
11839 : 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
11840 : 3371 : return new_ss->parent;
11841 : : }
11842 : :
11843 : :
11844 : : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11845 : : is to be inlined. */
11846 : :
11847 : : static gfc_ss *
11848 : 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11849 : : {
11850 : 575 : gfc_ss *tmp_ss, *tail, *array_ss;
11851 : 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
11852 : 575 : int sum_dim;
11853 : 575 : bool scalar_mask = false;
11854 : :
11855 : : /* The rank of the result will be determined later. */
11856 : 575 : arg1 = expr->value.function.actual;
11857 : 575 : arg2 = arg1->next;
11858 : 575 : arg3 = arg2->next;
11859 : 575 : gcc_assert (arg3 != NULL);
11860 : :
11861 : 575 : if (expr->rank == 0)
11862 : : return ss;
11863 : :
11864 : 575 : tmp_ss = gfc_ss_terminator;
11865 : :
11866 : 575 : if (arg3->expr)
11867 : : {
11868 : 118 : gfc_ss *mask_ss;
11869 : :
11870 : 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11871 : 118 : if (mask_ss == tmp_ss)
11872 : 34 : scalar_mask = 1;
11873 : :
11874 : : tmp_ss = mask_ss;
11875 : : }
11876 : :
11877 : 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11878 : 575 : gcc_assert (array_ss != tmp_ss);
11879 : :
11880 : : /* Odd thing: If the mask is scalar, it is used by the frontend after
11881 : : the array (to make an if around the nested loop). Thus it shall
11882 : : be after array_ss once the gfc_ss list is reversed. */
11883 : 575 : if (scalar_mask)
11884 : 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11885 : : else
11886 : : tmp_ss = array_ss;
11887 : :
11888 : : /* "Hide" the dimension on which we will sum in the first arg's scalarization
11889 : : chain. */
11890 : 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11891 : 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
11892 : 575 : tail->next = ss;
11893 : :
11894 : 575 : return tmp_ss;
11895 : : }
11896 : :
11897 : :
11898 : : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
11899 : : function is to be inlined. */
11900 : :
11901 : : static gfc_ss *
11902 : 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
11903 : : {
11904 : 6085 : if (expr->rank == 0)
11905 : : return ss;
11906 : :
11907 : 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
11908 : 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
11909 : 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
11910 : 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
11911 : 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
11912 : :
11913 : 6085 : gfc_expr *array = array_arg->expr;
11914 : 6085 : gfc_expr *dim = dim_arg->expr;
11915 : 6085 : gfc_expr *mask = mask_arg->expr;
11916 : 6085 : gfc_expr *back = back_arg->expr;
11917 : :
11918 : 6085 : if (dim == nullptr)
11919 : 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11920 : :
11921 : 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
11922 : :
11923 : 2796 : bool scalar_mask = false;
11924 : 2796 : if (mask)
11925 : : {
11926 : 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
11927 : 1866 : if (mask_ss == tmp_ss)
11928 : : scalar_mask = true;
11929 : 1174 : else if (maybe_absent_optional_variable (mask))
11930 : 20 : mask_ss->info->can_be_null_ref = true;
11931 : :
11932 : : tmp_ss = mask_ss;
11933 : : }
11934 : :
11935 : 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
11936 : 2796 : gcc_assert (array_ss != tmp_ss);
11937 : :
11938 : 2796 : tmp_ss = array_ss;
11939 : :
11940 : : /* Move the dimension on which we will sum to a separate nested scalarization
11941 : : chain, "hiding" that dimension from the outer scalarization. */
11942 : 2796 : int dim_val = mpz_get_si (dim->value.integer);
11943 : 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
11944 : :
11945 : 2796 : if (back && array->rank > 1)
11946 : : {
11947 : : /* If there are nested scalarization loops, include BACK in the
11948 : : scalarization chains to avoid evaluating it multiple times in a loop.
11949 : : Otherwise, prefer to handle it outside of scalarization. */
11950 : 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
11951 : 2796 : back_ss->info->type = GFC_SS_REFERENCE;
11952 : 2796 : if (maybe_absent_optional_variable (back))
11953 : 16 : back_ss->info->can_be_null_ref = true;
11954 : :
11955 : 2796 : tail->next = back_ss;
11956 : 2796 : }
11957 : : else
11958 : 0 : tail->next = ss;
11959 : :
11960 : 2796 : if (scalar_mask)
11961 : : {
11962 : 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
11963 : : /* MASK can be a forwarded optional argument, so make the necessary setup
11964 : : to avoid the scalarizer generating any unguarded pointer dereference in
11965 : : that case. */
11966 : 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
11967 : 692 : if (maybe_absent_optional_variable (mask))
11968 : 4 : tmp_ss->info->can_be_null_ref = true;
11969 : : }
11970 : :
11971 : : return tmp_ss;
11972 : : }
11973 : :
11974 : :
11975 : : static gfc_ss *
11976 : 8220 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
11977 : : {
11978 : :
11979 : 8220 : switch (expr->value.function.isym->id)
11980 : : {
11981 : 575 : case GFC_ISYM_PRODUCT:
11982 : 575 : case GFC_ISYM_SUM:
11983 : 575 : return walk_inline_intrinsic_arith (ss, expr);
11984 : :
11985 : 1560 : case GFC_ISYM_TRANSPOSE:
11986 : 1560 : return walk_inline_intrinsic_transpose (ss, expr);
11987 : :
11988 : 6085 : case GFC_ISYM_MAXLOC:
11989 : 6085 : case GFC_ISYM_MINLOC:
11990 : 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
11991 : :
11992 : 0 : default:
11993 : 0 : gcc_unreachable ();
11994 : : }
11995 : : gcc_unreachable ();
11996 : : }
11997 : :
11998 : :
11999 : : /* This generates code to execute before entering the scalarization loop.
12000 : : Currently does nothing. */
12001 : :
12002 : : void
12003 : 11333 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12004 : : {
12005 : 11333 : switch (ss->info->expr->value.function.isym->id)
12006 : : {
12007 : 11333 : case GFC_ISYM_UBOUND:
12008 : 11333 : case GFC_ISYM_LBOUND:
12009 : 11333 : case GFC_ISYM_UCOBOUND:
12010 : 11333 : case GFC_ISYM_LCOBOUND:
12011 : 11333 : case GFC_ISYM_MAXLOC:
12012 : 11333 : case GFC_ISYM_MINLOC:
12013 : 11333 : case GFC_ISYM_THIS_IMAGE:
12014 : 11333 : case GFC_ISYM_SHAPE:
12015 : 11333 : break;
12016 : :
12017 : 0 : default:
12018 : 0 : gcc_unreachable ();
12019 : : }
12020 : 11333 : }
12021 : :
12022 : :
12023 : : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12024 : : one parameter are expanded into code inside the scalarization loop. */
12025 : :
12026 : : static gfc_ss *
12027 : 9886 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12028 : : {
12029 : 9886 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12030 : 410 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12031 : :
12032 : : /* The two argument version returns a scalar. */
12033 : 9886 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12034 : 3439 : && expr->value.function.actual->next->expr)
12035 : : return ss;
12036 : :
12037 : 9886 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12038 : : }
12039 : :
12040 : :
12041 : : /* Walk an intrinsic array libcall. */
12042 : :
12043 : : static gfc_ss *
12044 : 14579 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12045 : : {
12046 : 14579 : gcc_assert (expr->rank > 0);
12047 : 14579 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12048 : : }
12049 : :
12050 : :
12051 : : /* Return whether the function call expression EXPR will be expanded
12052 : : inline by gfc_conv_intrinsic_function. */
12053 : :
12054 : : bool
12055 : 295980 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12056 : : {
12057 : 295980 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12058 : 295980 : gfc_expr *maskexpr;
12059 : :
12060 : 295980 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12061 : 295980 : if (!isym)
12062 : : return false;
12063 : :
12064 : 295938 : switch (isym->id)
12065 : : {
12066 : 5102 : case GFC_ISYM_PRODUCT:
12067 : 5102 : case GFC_ISYM_SUM:
12068 : : /* Disable inline expansion if code size matters. */
12069 : 5102 : if (optimize_size)
12070 : : return false;
12071 : :
12072 : 4247 : args = expr->value.function.actual;
12073 : 4247 : dim_arg = args->next;
12074 : :
12075 : : /* We need to be able to subset the SUM argument at compile-time. */
12076 : 4247 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12077 : : return false;
12078 : :
12079 : : /* FIXME: If MASK is optional for a more than two-dimensional
12080 : : argument, the scalarizer gets confused if the mask is
12081 : : absent. See PR 82995. For now, fall back to the library
12082 : : function. */
12083 : :
12084 : 3635 : mask_arg = dim_arg->next;
12085 : 3635 : maskexpr = mask_arg->expr;
12086 : :
12087 : 3635 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12088 : 276 : && maskexpr->symtree->n.sym->attr.dummy
12089 : 48 : && maskexpr->symtree->n.sym->attr.optional)
12090 : : return false;
12091 : :
12092 : : return true;
12093 : :
12094 : : case GFC_ISYM_TRANSPOSE:
12095 : : return true;
12096 : :
12097 : 57188 : case GFC_ISYM_MINLOC:
12098 : 57188 : case GFC_ISYM_MAXLOC:
12099 : 57188 : {
12100 : 57188 : if ((isym->id == GFC_ISYM_MINLOC
12101 : 30521 : && (flag_inline_intrinsics
12102 : 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12103 : 46611 : || (isym->id == GFC_ISYM_MAXLOC
12104 : 26667 : && (flag_inline_intrinsics
12105 : 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12106 : : return false;
12107 : :
12108 : 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12109 : 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12110 : :
12111 : 37638 : gfc_expr *array = array_arg->expr;
12112 : 37638 : gfc_expr *dim = dim_arg->expr;
12113 : :
12114 : 37638 : if (!(array->ts.type == BT_INTEGER
12115 : : || array->ts.type == BT_REAL))
12116 : : return false;
12117 : :
12118 : 34658 : if (array->rank == 1)
12119 : : return true;
12120 : :
12121 : 20711 : if (dim != nullptr
12122 : 13372 : && dim->expr_type != EXPR_CONSTANT)
12123 : : return false;
12124 : :
12125 : : return true;
12126 : : }
12127 : :
12128 : : default:
12129 : : return false;
12130 : : }
12131 : : }
12132 : :
12133 : :
12134 : : /* Returns nonzero if the specified intrinsic function call maps directly to
12135 : : an external library call. Should only be used for functions that return
12136 : : arrays. */
12137 : :
12138 : : int
12139 : 88397 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12140 : : {
12141 : 88397 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12142 : 88397 : gcc_assert (expr->rank > 0);
12143 : :
12144 : 88397 : if (gfc_inline_intrinsic_function_p (expr))
12145 : : return 0;
12146 : :
12147 : 73815 : switch (expr->value.function.isym->id)
12148 : : {
12149 : : case GFC_ISYM_ALL:
12150 : : case GFC_ISYM_ANY:
12151 : : case GFC_ISYM_COUNT:
12152 : : case GFC_ISYM_FINDLOC:
12153 : : case GFC_ISYM_JN2:
12154 : : case GFC_ISYM_IANY:
12155 : : case GFC_ISYM_IALL:
12156 : : case GFC_ISYM_IPARITY:
12157 : : case GFC_ISYM_MATMUL:
12158 : : case GFC_ISYM_MAXLOC:
12159 : : case GFC_ISYM_MAXVAL:
12160 : : case GFC_ISYM_MINLOC:
12161 : : case GFC_ISYM_MINVAL:
12162 : : case GFC_ISYM_NORM2:
12163 : : case GFC_ISYM_PARITY:
12164 : : case GFC_ISYM_PRODUCT:
12165 : : case GFC_ISYM_SUM:
12166 : : case GFC_ISYM_SPREAD:
12167 : : case GFC_ISYM_YN2:
12168 : : /* Ignore absent optional parameters. */
12169 : : return 1;
12170 : :
12171 : 16471 : case GFC_ISYM_CSHIFT:
12172 : 16471 : case GFC_ISYM_EOSHIFT:
12173 : 16471 : case GFC_ISYM_GET_TEAM:
12174 : 16471 : case GFC_ISYM_FAILED_IMAGES:
12175 : 16471 : case GFC_ISYM_STOPPED_IMAGES:
12176 : 16471 : case GFC_ISYM_PACK:
12177 : 16471 : case GFC_ISYM_REDUCE:
12178 : 16471 : case GFC_ISYM_RESHAPE:
12179 : 16471 : case GFC_ISYM_UNPACK:
12180 : : /* Pass absent optional parameters. */
12181 : 16471 : return 2;
12182 : :
12183 : : default:
12184 : : return 0;
12185 : : }
12186 : : }
12187 : :
12188 : : /* Walk an intrinsic function. */
12189 : : gfc_ss *
12190 : 55995 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12191 : : gfc_intrinsic_sym * isym)
12192 : : {
12193 : 55995 : gcc_assert (isym);
12194 : :
12195 : 55995 : if (isym->elemental)
12196 : 18932 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12197 : : expr->value.function.isym,
12198 : 18932 : GFC_SS_SCALAR);
12199 : :
12200 : 37063 : if (expr->rank == 0 && expr->corank == 0)
12201 : : return ss;
12202 : :
12203 : 32685 : if (gfc_inline_intrinsic_function_p (expr))
12204 : 8220 : return walk_inline_intrinsic_function (ss, expr);
12205 : :
12206 : 24465 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12207 : 13625 : return gfc_walk_intrinsic_libfunc (ss, expr);
12208 : :
12209 : : /* Special cases. */
12210 : 10840 : switch (isym->id)
12211 : : {
12212 : 9886 : case GFC_ISYM_LBOUND:
12213 : 9886 : case GFC_ISYM_LCOBOUND:
12214 : 9886 : case GFC_ISYM_UBOUND:
12215 : 9886 : case GFC_ISYM_UCOBOUND:
12216 : 9886 : case GFC_ISYM_THIS_IMAGE:
12217 : 9886 : case GFC_ISYM_SHAPE:
12218 : 9886 : return gfc_walk_intrinsic_bound (ss, expr);
12219 : :
12220 : 954 : case GFC_ISYM_TRANSFER:
12221 : 954 : case GFC_ISYM_CAF_GET:
12222 : 954 : return gfc_walk_intrinsic_libfunc (ss, expr);
12223 : :
12224 : 0 : default:
12225 : : /* This probably meant someone forgot to add an intrinsic to the above
12226 : : list(s) when they implemented it, or something's gone horribly
12227 : : wrong. */
12228 : 0 : gcc_unreachable ();
12229 : : }
12230 : : }
12231 : :
12232 : : static tree
12233 : 63 : conv_co_collective (gfc_code *code)
12234 : : {
12235 : 63 : gfc_se argse;
12236 : 63 : stmtblock_t block, post_block;
12237 : 63 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12238 : 63 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12239 : :
12240 : 63 : gfc_start_block (&block);
12241 : 63 : gfc_init_block (&post_block);
12242 : :
12243 : 63 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12244 : : {
12245 : 7 : opr_expr = code->ext.actual->next->expr;
12246 : 7 : image_idx_expr = code->ext.actual->next->next->expr;
12247 : 7 : stat_expr = code->ext.actual->next->next->next->expr;
12248 : 7 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12249 : : }
12250 : : else
12251 : : {
12252 : 56 : opr_expr = NULL;
12253 : 56 : image_idx_expr = code->ext.actual->next->expr;
12254 : 56 : stat_expr = code->ext.actual->next->next->expr;
12255 : 56 : errmsg_expr = code->ext.actual->next->next->next->expr;
12256 : : }
12257 : :
12258 : : /* stat. */
12259 : 63 : if (stat_expr)
12260 : : {
12261 : 49 : gfc_init_se (&argse, NULL);
12262 : 49 : gfc_conv_expr (&argse, stat_expr);
12263 : 49 : gfc_add_block_to_block (&block, &argse.pre);
12264 : 49 : gfc_add_block_to_block (&post_block, &argse.post);
12265 : 49 : stat = argse.expr;
12266 : 49 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12267 : 22 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12268 : : }
12269 : 14 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12270 : : stat = NULL_TREE;
12271 : : else
12272 : 8 : stat = null_pointer_node;
12273 : :
12274 : : /* Early exit for GFC_FCOARRAY_SINGLE. */
12275 : 63 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12276 : : {
12277 : 33 : if (stat != NULL_TREE)
12278 : : {
12279 : : /* For optional stats, check the pointer is valid before zero'ing. */
12280 : 27 : if (gfc_expr_attr (stat_expr).optional)
12281 : : {
12282 : 12 : tree tmp;
12283 : 12 : stmtblock_t ass_block;
12284 : 12 : gfc_start_block (&ass_block);
12285 : 12 : gfc_add_modify (&ass_block, stat,
12286 : 12 : fold_convert (TREE_TYPE (stat),
12287 : : integer_zero_node));
12288 : 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12289 : : gfc_build_addr_expr (NULL_TREE, stat),
12290 : : null_pointer_node);
12291 : 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12292 : : gfc_finish_block (&ass_block),
12293 : : build_empty_stmt (input_location));
12294 : 12 : gfc_add_expr_to_block (&block, tmp);
12295 : : }
12296 : : else
12297 : 15 : gfc_add_modify (&block, stat,
12298 : 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12299 : : }
12300 : 33 : return gfc_finish_block (&block);
12301 : : }
12302 : :
12303 : 3 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12304 : 30 : ? code->ext.actual->expr->ts.u.derived : NULL;
12305 : :
12306 : : /* Handle the array. */
12307 : 30 : gfc_init_se (&argse, NULL);
12308 : 30 : if (!derived || !derived->attr.alloc_comp
12309 : 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12310 : : {
12311 : 29 : if (code->ext.actual->expr->rank == 0)
12312 : : {
12313 : 16 : symbol_attribute attr;
12314 : 16 : gfc_clear_attr (&attr);
12315 : 16 : gfc_init_se (&argse, NULL);
12316 : 16 : gfc_conv_expr (&argse, code->ext.actual->expr);
12317 : 16 : gfc_add_block_to_block (&block, &argse.pre);
12318 : 16 : gfc_add_block_to_block (&post_block, &argse.post);
12319 : 16 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12320 : 16 : array = gfc_build_addr_expr (NULL_TREE, array);
12321 : : }
12322 : : else
12323 : : {
12324 : 13 : argse.want_pointer = 1;
12325 : 13 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12326 : 13 : array = argse.expr;
12327 : : }
12328 : : }
12329 : :
12330 : 30 : gfc_add_block_to_block (&block, &argse.pre);
12331 : 30 : gfc_add_block_to_block (&post_block, &argse.post);
12332 : :
12333 : 30 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12334 : 6 : strlen = argse.string_length;
12335 : : else
12336 : 24 : strlen = integer_zero_node;
12337 : :
12338 : : /* image_index. */
12339 : 30 : if (image_idx_expr)
12340 : : {
12341 : 22 : gfc_init_se (&argse, NULL);
12342 : 22 : gfc_conv_expr (&argse, image_idx_expr);
12343 : 22 : gfc_add_block_to_block (&block, &argse.pre);
12344 : 22 : gfc_add_block_to_block (&post_block, &argse.post);
12345 : 22 : image_index = fold_convert (integer_type_node, argse.expr);
12346 : : }
12347 : : else
12348 : 8 : image_index = integer_zero_node;
12349 : :
12350 : : /* errmsg. */
12351 : 30 : if (errmsg_expr)
12352 : : {
12353 : 17 : gfc_init_se (&argse, NULL);
12354 : 17 : gfc_conv_expr (&argse, errmsg_expr);
12355 : 17 : gfc_add_block_to_block (&block, &argse.pre);
12356 : 17 : gfc_add_block_to_block (&post_block, &argse.post);
12357 : 17 : errmsg = argse.expr;
12358 : 17 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12359 : : }
12360 : : else
12361 : : {
12362 : 13 : errmsg = null_pointer_node;
12363 : 13 : errmsg_len = build_zero_cst (size_type_node);
12364 : : }
12365 : :
12366 : : /* Generate the function call. */
12367 : 30 : switch (code->resolved_isym->id)
12368 : : {
12369 : 12 : case GFC_ISYM_CO_BROADCAST:
12370 : 12 : fndecl = gfor_fndecl_co_broadcast;
12371 : 12 : break;
12372 : 5 : case GFC_ISYM_CO_MAX:
12373 : 5 : fndecl = gfor_fndecl_co_max;
12374 : 5 : break;
12375 : 4 : case GFC_ISYM_CO_MIN:
12376 : 4 : fndecl = gfor_fndecl_co_min;
12377 : 4 : break;
12378 : 5 : case GFC_ISYM_CO_REDUCE:
12379 : 5 : fndecl = gfor_fndecl_co_reduce;
12380 : 5 : break;
12381 : 4 : case GFC_ISYM_CO_SUM:
12382 : 4 : fndecl = gfor_fndecl_co_sum;
12383 : 4 : break;
12384 : 0 : default:
12385 : 0 : gcc_unreachable ();
12386 : : }
12387 : :
12388 : 30 : if (derived && derived->attr.alloc_comp
12389 : 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12390 : : /* The derived type has the attribute 'alloc_comp'. */
12391 : : {
12392 : 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12393 : 1 : code->ext.actual->expr->rank,
12394 : : image_index, stat, errmsg, errmsg_len);
12395 : 1 : gfc_add_expr_to_block (&block, tmp);
12396 : 1 : }
12397 : : else
12398 : : {
12399 : 29 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12400 : 25 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12401 : 15 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12402 : : image_index, stat, errmsg, errmsg_len);
12403 : 14 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12404 : 9 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12405 : : image_index, stat, errmsg,
12406 : : strlen, errmsg_len);
12407 : : else
12408 : : {
12409 : 5 : tree opr, opr_flags;
12410 : :
12411 : : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12412 : 5 : int opr_flag_int;
12413 : 5 : if (gfc_is_proc_ptr_comp (opr_expr))
12414 : : {
12415 : 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12416 : 0 : opr_flag_int = sym->attr.dimension
12417 : 0 : || (sym->ts.type == BT_CHARACTER
12418 : 0 : && !sym->attr.is_bind_c)
12419 : 0 : ? GFC_CAF_BYREF : 0;
12420 : 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12421 : 0 : && !sym->attr.is_bind_c
12422 : 0 : ? GFC_CAF_HIDDENLEN : 0;
12423 : 0 : opr_flag_int |= sym->formal->sym->attr.value
12424 : 0 : ? GFC_CAF_ARG_VALUE : 0;
12425 : : }
12426 : : else
12427 : : {
12428 : 5 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12429 : 5 : ? GFC_CAF_BYREF : 0;
12430 : 10 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12431 : 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12432 : 5 : ? GFC_CAF_HIDDENLEN : 0;
12433 : 5 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12434 : 5 : ? GFC_CAF_ARG_VALUE : 0;
12435 : : }
12436 : 5 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12437 : 5 : gfc_conv_expr (&argse, opr_expr);
12438 : 5 : opr = argse.expr;
12439 : 5 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12440 : : opr_flags, image_index, stat, errmsg,
12441 : : strlen, errmsg_len);
12442 : : }
12443 : : }
12444 : :
12445 : 30 : gfc_add_expr_to_block (&block, fndecl);
12446 : 30 : gfc_add_block_to_block (&block, &post_block);
12447 : :
12448 : 30 : return gfc_finish_block (&block);
12449 : : }
12450 : :
12451 : :
12452 : : static tree
12453 : 68 : conv_intrinsic_atomic_op (gfc_code *code)
12454 : : {
12455 : 68 : gfc_se argse;
12456 : 68 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12457 : 68 : stmtblock_t block, post_block;
12458 : 68 : gfc_expr *atom_expr = code->ext.actual->expr;
12459 : 68 : gfc_expr *stat_expr;
12460 : 68 : built_in_function fn;
12461 : :
12462 : 68 : if (atom_expr->expr_type == EXPR_FUNCTION
12463 : 0 : && atom_expr->value.function.isym
12464 : 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12465 : 0 : atom_expr = atom_expr->value.function.actual->expr;
12466 : :
12467 : 68 : gfc_start_block (&block);
12468 : 68 : gfc_init_block (&post_block);
12469 : :
12470 : 68 : gfc_init_se (&argse, NULL);
12471 : 68 : argse.want_pointer = 1;
12472 : 68 : gfc_conv_expr (&argse, atom_expr);
12473 : 68 : gfc_add_block_to_block (&block, &argse.pre);
12474 : 68 : gfc_add_block_to_block (&post_block, &argse.post);
12475 : 68 : atom = argse.expr;
12476 : :
12477 : 68 : gfc_init_se (&argse, NULL);
12478 : 68 : if (flag_coarray == GFC_FCOARRAY_LIB
12479 : 29 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12480 : 28 : argse.want_pointer = 1;
12481 : 68 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12482 : 68 : gfc_add_block_to_block (&block, &argse.pre);
12483 : 68 : gfc_add_block_to_block (&post_block, &argse.post);
12484 : 68 : value = argse.expr;
12485 : :
12486 : 68 : switch (code->resolved_isym->id)
12487 : : {
12488 : 42 : case GFC_ISYM_ATOMIC_ADD:
12489 : 42 : case GFC_ISYM_ATOMIC_AND:
12490 : 42 : case GFC_ISYM_ATOMIC_DEF:
12491 : 42 : case GFC_ISYM_ATOMIC_OR:
12492 : 42 : case GFC_ISYM_ATOMIC_XOR:
12493 : 42 : stat_expr = code->ext.actual->next->next->expr;
12494 : 42 : if (flag_coarray == GFC_FCOARRAY_LIB)
12495 : 18 : old = null_pointer_node;
12496 : : break;
12497 : 26 : default:
12498 : 26 : gfc_init_se (&argse, NULL);
12499 : 26 : if (flag_coarray == GFC_FCOARRAY_LIB)
12500 : 11 : argse.want_pointer = 1;
12501 : 26 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12502 : 26 : gfc_add_block_to_block (&block, &argse.pre);
12503 : 26 : gfc_add_block_to_block (&post_block, &argse.post);
12504 : 26 : old = argse.expr;
12505 : 26 : stat_expr = code->ext.actual->next->next->next->expr;
12506 : : }
12507 : :
12508 : : /* STAT= */
12509 : 68 : if (stat_expr != NULL)
12510 : : {
12511 : 58 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12512 : 58 : gfc_init_se (&argse, NULL);
12513 : 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12514 : 24 : argse.want_pointer = 1;
12515 : 58 : gfc_conv_expr_val (&argse, stat_expr);
12516 : 58 : gfc_add_block_to_block (&block, &argse.pre);
12517 : 58 : gfc_add_block_to_block (&post_block, &argse.post);
12518 : 58 : stat = argse.expr;
12519 : : }
12520 : 10 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12521 : 5 : stat = null_pointer_node;
12522 : :
12523 : 68 : if (flag_coarray == GFC_FCOARRAY_LIB)
12524 : : {
12525 : 29 : tree image_index, caf_decl, offset, token;
12526 : 29 : int op;
12527 : :
12528 : 29 : switch (code->resolved_isym->id)
12529 : : {
12530 : : case GFC_ISYM_ATOMIC_ADD:
12531 : : case GFC_ISYM_ATOMIC_FETCH_ADD:
12532 : : op = (int) GFC_CAF_ATOMIC_ADD;
12533 : : break;
12534 : 6 : case GFC_ISYM_ATOMIC_AND:
12535 : 6 : case GFC_ISYM_ATOMIC_FETCH_AND:
12536 : 6 : op = (int) GFC_CAF_ATOMIC_AND;
12537 : 6 : break;
12538 : 6 : case GFC_ISYM_ATOMIC_OR:
12539 : 6 : case GFC_ISYM_ATOMIC_FETCH_OR:
12540 : 6 : op = (int) GFC_CAF_ATOMIC_OR;
12541 : 6 : break;
12542 : 6 : case GFC_ISYM_ATOMIC_XOR:
12543 : 6 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12544 : 6 : op = (int) GFC_CAF_ATOMIC_XOR;
12545 : 6 : break;
12546 : 6 : case GFC_ISYM_ATOMIC_DEF:
12547 : 6 : op = 0; /* Unused. */
12548 : 6 : break;
12549 : 0 : default:
12550 : 0 : gcc_unreachable ();
12551 : : }
12552 : :
12553 : 29 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12554 : 29 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12555 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12556 : :
12557 : 29 : if (gfc_is_coindexed (atom_expr))
12558 : 25 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12559 : : else
12560 : 4 : image_index = integer_zero_node;
12561 : :
12562 : : /* Ensure VALUE names addressable storage: taking the address of a
12563 : : constant is invalid in C, and scalars need a temporary as well. */
12564 : 29 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12565 : : {
12566 : 21 : tree elem
12567 : 21 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12568 : 21 : elem = gfc_trans_force_lval (&block, elem);
12569 : 21 : value = gfc_build_addr_expr (NULL_TREE, elem);
12570 : : }
12571 : 8 : else if (TREE_CODE (value) == ADDR_EXPR
12572 : 8 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12573 : : {
12574 : 0 : tree elem
12575 : 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12576 : : build_fold_indirect_ref (value));
12577 : 0 : elem = gfc_trans_force_lval (&block, elem);
12578 : 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12579 : : }
12580 : :
12581 : 29 : gfc_init_se (&argse, NULL);
12582 : 29 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12583 : : atom_expr);
12584 : :
12585 : 29 : gfc_add_block_to_block (&block, &argse.pre);
12586 : 29 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12587 : 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12588 : : token, offset, image_index, value, stat,
12589 : : build_int_cst (integer_type_node,
12590 : 6 : (int) atom_expr->ts.type),
12591 : : build_int_cst (integer_type_node,
12592 : 6 : (int) atom_expr->ts.kind));
12593 : : else
12594 : 23 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12595 : 23 : build_int_cst (integer_type_node, op),
12596 : : token, offset, image_index, value, old, stat,
12597 : : build_int_cst (integer_type_node,
12598 : 23 : (int) atom_expr->ts.type),
12599 : : build_int_cst (integer_type_node,
12600 : 23 : (int) atom_expr->ts.kind));
12601 : :
12602 : 29 : gfc_add_expr_to_block (&block, tmp);
12603 : 29 : gfc_add_block_to_block (&block, &argse.post);
12604 : 29 : gfc_add_block_to_block (&block, &post_block);
12605 : 29 : return gfc_finish_block (&block);
12606 : : }
12607 : :
12608 : :
12609 : 39 : switch (code->resolved_isym->id)
12610 : : {
12611 : : case GFC_ISYM_ATOMIC_ADD:
12612 : : case GFC_ISYM_ATOMIC_FETCH_ADD:
12613 : : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12614 : : break;
12615 : 8 : case GFC_ISYM_ATOMIC_AND:
12616 : 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12617 : 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12618 : 8 : break;
12619 : 9 : case GFC_ISYM_ATOMIC_DEF:
12620 : 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12621 : 9 : break;
12622 : 8 : case GFC_ISYM_ATOMIC_OR:
12623 : 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12624 : 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12625 : 8 : break;
12626 : 8 : case GFC_ISYM_ATOMIC_XOR:
12627 : 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12628 : 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12629 : 8 : break;
12630 : 0 : default:
12631 : 0 : gcc_unreachable ();
12632 : : }
12633 : :
12634 : 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12635 : 78 : fn = (built_in_function) ((int) fn
12636 : 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12637 : 39 : + 1);
12638 : 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12639 : 39 : tmp = builtin_decl_explicit (fn);
12640 : :
12641 : 39 : switch (code->resolved_isym->id)
12642 : : {
12643 : 24 : case GFC_ISYM_ATOMIC_ADD:
12644 : 24 : case GFC_ISYM_ATOMIC_AND:
12645 : 24 : case GFC_ISYM_ATOMIC_DEF:
12646 : 24 : case GFC_ISYM_ATOMIC_OR:
12647 : 24 : case GFC_ISYM_ATOMIC_XOR:
12648 : 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12649 : : fold_convert (itype, value),
12650 : : build_int_cst (NULL, MEMMODEL_RELAXED));
12651 : 24 : gfc_add_expr_to_block (&block, tmp);
12652 : 24 : break;
12653 : 15 : default:
12654 : 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12655 : : fold_convert (itype, value),
12656 : : build_int_cst (NULL, MEMMODEL_RELAXED));
12657 : 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12658 : 15 : break;
12659 : : }
12660 : :
12661 : 39 : if (stat != NULL_TREE)
12662 : 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12663 : 39 : gfc_add_block_to_block (&block, &post_block);
12664 : 39 : return gfc_finish_block (&block);
12665 : : }
12666 : :
12667 : :
12668 : : static tree
12669 : 119 : conv_intrinsic_atomic_ref (gfc_code *code)
12670 : : {
12671 : 119 : gfc_se argse;
12672 : 119 : tree tmp, atom, value, stat = NULL_TREE;
12673 : 119 : stmtblock_t block, post_block;
12674 : 119 : built_in_function fn;
12675 : 119 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12676 : :
12677 : 119 : if (atom_expr->expr_type == EXPR_FUNCTION
12678 : 0 : && atom_expr->value.function.isym
12679 : 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12680 : 0 : atom_expr = atom_expr->value.function.actual->expr;
12681 : :
12682 : 119 : gfc_start_block (&block);
12683 : 119 : gfc_init_block (&post_block);
12684 : 119 : gfc_init_se (&argse, NULL);
12685 : 119 : argse.want_pointer = 1;
12686 : 119 : gfc_conv_expr (&argse, atom_expr);
12687 : 119 : gfc_add_block_to_block (&block, &argse.pre);
12688 : 119 : gfc_add_block_to_block (&post_block, &argse.post);
12689 : 119 : atom = argse.expr;
12690 : :
12691 : 119 : gfc_init_se (&argse, NULL);
12692 : 119 : if (flag_coarray == GFC_FCOARRAY_LIB
12693 : 58 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12694 : 55 : argse.want_pointer = 1;
12695 : 119 : gfc_conv_expr (&argse, code->ext.actual->expr);
12696 : 119 : gfc_add_block_to_block (&block, &argse.pre);
12697 : 119 : gfc_add_block_to_block (&post_block, &argse.post);
12698 : 119 : value = argse.expr;
12699 : :
12700 : : /* STAT= */
12701 : 119 : if (code->ext.actual->next->next->expr != NULL)
12702 : : {
12703 : 110 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12704 : : == EXPR_VARIABLE);
12705 : 110 : gfc_init_se (&argse, NULL);
12706 : 110 : if (flag_coarray == GFC_FCOARRAY_LIB)
12707 : 54 : argse.want_pointer = 1;
12708 : 110 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12709 : 110 : gfc_add_block_to_block (&block, &argse.pre);
12710 : 110 : gfc_add_block_to_block (&post_block, &argse.post);
12711 : 110 : stat = argse.expr;
12712 : : }
12713 : 9 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12714 : 4 : stat = null_pointer_node;
12715 : :
12716 : 119 : if (flag_coarray == GFC_FCOARRAY_LIB)
12717 : : {
12718 : 58 : tree image_index, caf_decl, offset, token;
12719 : 58 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12720 : :
12721 : 58 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12722 : 58 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12723 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12724 : :
12725 : 58 : if (gfc_is_coindexed (atom_expr))
12726 : 52 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12727 : : else
12728 : 6 : image_index = integer_zero_node;
12729 : :
12730 : 58 : gfc_init_se (&argse, NULL);
12731 : 58 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12732 : : atom_expr);
12733 : 58 : gfc_add_block_to_block (&block, &argse.pre);
12734 : :
12735 : : /* Different type, need type conversion. */
12736 : 58 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12737 : : {
12738 : 3 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12739 : 3 : orig_value = value;
12740 : 3 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12741 : : }
12742 : :
12743 : 58 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12744 : : token, offset, image_index, value, stat,
12745 : : build_int_cst (integer_type_node,
12746 : 58 : (int) atom_expr->ts.type),
12747 : : build_int_cst (integer_type_node,
12748 : 58 : (int) atom_expr->ts.kind));
12749 : 58 : gfc_add_expr_to_block (&block, tmp);
12750 : 58 : if (vardecl != NULL_TREE)
12751 : 3 : gfc_add_modify (&block, orig_value,
12752 : 3 : fold_convert (TREE_TYPE (orig_value), vardecl));
12753 : 58 : gfc_add_block_to_block (&block, &argse.post);
12754 : 58 : gfc_add_block_to_block (&block, &post_block);
12755 : 58 : return gfc_finish_block (&block);
12756 : : }
12757 : :
12758 : 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12759 : 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12760 : 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12761 : 61 : + 1);
12762 : 61 : tmp = builtin_decl_explicit (fn);
12763 : 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12764 : : build_int_cst (integer_type_node,
12765 : : MEMMODEL_RELAXED));
12766 : 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12767 : :
12768 : 61 : if (stat != NULL_TREE)
12769 : 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12770 : 61 : gfc_add_block_to_block (&block, &post_block);
12771 : 61 : return gfc_finish_block (&block);
12772 : : }
12773 : :
12774 : :
12775 : : static tree
12776 : 10 : conv_intrinsic_atomic_cas (gfc_code *code)
12777 : : {
12778 : 10 : gfc_se argse;
12779 : 10 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12780 : 10 : stmtblock_t block, post_block;
12781 : 10 : built_in_function fn;
12782 : 10 : gfc_expr *atom_expr = code->ext.actual->expr;
12783 : :
12784 : 10 : if (atom_expr->expr_type == EXPR_FUNCTION
12785 : 0 : && atom_expr->value.function.isym
12786 : 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12787 : 0 : atom_expr = atom_expr->value.function.actual->expr;
12788 : :
12789 : 10 : gfc_init_block (&block);
12790 : 10 : gfc_init_block (&post_block);
12791 : 10 : gfc_init_se (&argse, NULL);
12792 : 10 : argse.want_pointer = 1;
12793 : 10 : gfc_conv_expr (&argse, atom_expr);
12794 : 10 : atom = argse.expr;
12795 : :
12796 : 10 : gfc_init_se (&argse, NULL);
12797 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12798 : 4 : argse.want_pointer = 1;
12799 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12800 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12801 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12802 : 10 : old = argse.expr;
12803 : :
12804 : 10 : gfc_init_se (&argse, NULL);
12805 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12806 : 4 : argse.want_pointer = 1;
12807 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12808 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12809 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12810 : 10 : comp = argse.expr;
12811 : :
12812 : 10 : gfc_init_se (&argse, NULL);
12813 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB
12814 : 4 : && code->ext.actual->next->next->next->expr->ts.kind
12815 : 4 : == atom_expr->ts.kind)
12816 : 4 : argse.want_pointer = 1;
12817 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
12818 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12819 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12820 : 10 : new_val = argse.expr;
12821 : :
12822 : : /* STAT= */
12823 : 10 : if (code->ext.actual->next->next->next->next->expr != NULL)
12824 : : {
12825 : 10 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12826 : : == EXPR_VARIABLE);
12827 : 10 : gfc_init_se (&argse, NULL);
12828 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12829 : 4 : argse.want_pointer = 1;
12830 : 10 : gfc_conv_expr_val (&argse,
12831 : 10 : code->ext.actual->next->next->next->next->expr);
12832 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12833 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12834 : 10 : stat = argse.expr;
12835 : : }
12836 : 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12837 : 0 : stat = null_pointer_node;
12838 : :
12839 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12840 : : {
12841 : 4 : tree image_index, caf_decl, offset, token;
12842 : :
12843 : 4 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12844 : 4 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12845 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12846 : :
12847 : 4 : if (gfc_is_coindexed (atom_expr))
12848 : 4 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12849 : : else
12850 : 0 : image_index = integer_zero_node;
12851 : :
12852 : 4 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12853 : : {
12854 : 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12855 : 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12856 : 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12857 : : }
12858 : :
12859 : 4 : gfc_init_se (&argse, NULL);
12860 : 4 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12861 : : atom_expr);
12862 : 4 : gfc_add_block_to_block (&block, &argse.pre);
12863 : :
12864 : 4 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12865 : : token, offset, image_index, old, comp, new_val,
12866 : : stat, build_int_cst (integer_type_node,
12867 : 4 : (int) atom_expr->ts.type),
12868 : : build_int_cst (integer_type_node,
12869 : 4 : (int) atom_expr->ts.kind));
12870 : 4 : gfc_add_expr_to_block (&block, tmp);
12871 : 4 : gfc_add_block_to_block (&block, &argse.post);
12872 : 4 : gfc_add_block_to_block (&block, &post_block);
12873 : 4 : return gfc_finish_block (&block);
12874 : : }
12875 : :
12876 : 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
12877 : 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12878 : 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12879 : 6 : + 1);
12880 : 6 : tmp = builtin_decl_explicit (fn);
12881 : :
12882 : 6 : gfc_add_modify (&block, old, comp);
12883 : 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12884 : : gfc_build_addr_expr (NULL, old),
12885 : 6 : fold_convert (TREE_TYPE (old), new_val),
12886 : : boolean_false_node,
12887 : : build_int_cst (NULL, MEMMODEL_RELAXED),
12888 : : build_int_cst (NULL, MEMMODEL_RELAXED));
12889 : 6 : gfc_add_expr_to_block (&block, tmp);
12890 : :
12891 : 6 : if (stat != NULL_TREE)
12892 : 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12893 : 6 : gfc_add_block_to_block (&block, &post_block);
12894 : 6 : return gfc_finish_block (&block);
12895 : : }
12896 : :
12897 : : static tree
12898 : 70 : conv_intrinsic_event_query (gfc_code *code)
12899 : : {
12900 : 70 : gfc_se se, argse;
12901 : 70 : tree stat = NULL_TREE, stat2 = NULL_TREE;
12902 : 70 : tree count = NULL_TREE, count2 = NULL_TREE;
12903 : :
12904 : 70 : gfc_expr *event_expr = code->ext.actual->expr;
12905 : :
12906 : 70 : if (code->ext.actual->next->next->expr)
12907 : : {
12908 : 12 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12909 : : == EXPR_VARIABLE);
12910 : 12 : gfc_init_se (&argse, NULL);
12911 : 12 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12912 : 12 : stat = argse.expr;
12913 : : }
12914 : 58 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12915 : 29 : stat = null_pointer_node;
12916 : :
12917 : 70 : if (code->ext.actual->next->expr)
12918 : : {
12919 : 70 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12920 : 70 : gfc_init_se (&argse, NULL);
12921 : 70 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
12922 : 70 : count = argse.expr;
12923 : : }
12924 : :
12925 : 70 : gfc_start_block (&se.pre);
12926 : 70 : if (flag_coarray == GFC_FCOARRAY_LIB)
12927 : : {
12928 : 35 : tree tmp, token, image_index;
12929 : 35 : tree index = build_zero_cst (gfc_array_index_type);
12930 : :
12931 : 35 : if (event_expr->expr_type == EXPR_FUNCTION
12932 : 0 : && event_expr->value.function.isym
12933 : 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12934 : 0 : event_expr = event_expr->value.function.actual->expr;
12935 : :
12936 : 35 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12937 : :
12938 : 35 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12939 : 35 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
12940 : : != INTMOD_ISO_FORTRAN_ENV
12941 : 35 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12942 : : != ISOFORTRAN_EVENT_TYPE)
12943 : : {
12944 : 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
12945 : : "yet supported", &event_expr->where);
12946 : 0 : return NULL_TREE;
12947 : : }
12948 : :
12949 : 35 : if (gfc_is_coindexed (event_expr))
12950 : : {
12951 : 0 : gfc_error ("The event variable at %L shall not be coindexed",
12952 : : &event_expr->where);
12953 : 0 : return NULL_TREE;
12954 : : }
12955 : :
12956 : 35 : image_index = integer_zero_node;
12957 : :
12958 : 35 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
12959 : : event_expr);
12960 : :
12961 : : /* For arrays, obtain the array index. */
12962 : 35 : if (gfc_expr_attr (event_expr).dimension)
12963 : : {
12964 : 26 : tree desc, tmp, extent, lbound, ubound;
12965 : 26 : gfc_array_ref *ar, ar2;
12966 : 26 : int i;
12967 : :
12968 : : /* TODO: Extend this, once DT components are supported. */
12969 : 26 : ar = &event_expr->ref->u.ar;
12970 : 26 : ar2 = *ar;
12971 : 26 : memset (ar, '\0', sizeof (*ar));
12972 : 26 : ar->as = ar2.as;
12973 : 26 : ar->type = AR_FULL;
12974 : :
12975 : 26 : gfc_init_se (&argse, NULL);
12976 : 26 : argse.descriptor_only = 1;
12977 : 26 : gfc_conv_expr_descriptor (&argse, event_expr);
12978 : 26 : gfc_add_block_to_block (&se.pre, &argse.pre);
12979 : 26 : desc = argse.expr;
12980 : 26 : *ar = ar2;
12981 : :
12982 : 26 : extent = build_one_cst (gfc_array_index_type);
12983 : 78 : for (i = 0; i < ar->dimen; i++)
12984 : : {
12985 : 26 : gfc_init_se (&argse, NULL);
12986 : 26 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
12987 : 26 : gfc_add_block_to_block (&argse.pre, &argse.pre);
12988 : 26 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
12989 : 26 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12990 : 26 : TREE_TYPE (lbound), argse.expr, lbound);
12991 : 26 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12992 : 26 : TREE_TYPE (tmp), extent, tmp);
12993 : 26 : index = fold_build2_loc (input_location, PLUS_EXPR,
12994 : 26 : TREE_TYPE (tmp), index, tmp);
12995 : 26 : if (i < ar->dimen - 1)
12996 : : {
12997 : 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
12998 : 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12999 : 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13000 : 0 : TREE_TYPE (tmp), extent, tmp);
13001 : : }
13002 : : }
13003 : : }
13004 : :
13005 : 35 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13006 : : {
13007 : 0 : count2 = count;
13008 : 0 : count = gfc_create_var (integer_type_node, "count");
13009 : : }
13010 : :
13011 : 35 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13012 : : {
13013 : 0 : stat2 = stat;
13014 : 0 : stat = gfc_create_var (integer_type_node, "stat");
13015 : : }
13016 : :
13017 : 35 : index = fold_convert (size_type_node, index);
13018 : 70 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13019 : : token, index, image_index, count
13020 : 35 : ? gfc_build_addr_expr (NULL, count) : count,
13021 : 35 : stat != null_pointer_node
13022 : 6 : ? gfc_build_addr_expr (NULL, stat) : stat);
13023 : 35 : gfc_add_expr_to_block (&se.pre, tmp);
13024 : :
13025 : 35 : if (count2 != NULL_TREE)
13026 : 0 : gfc_add_modify (&se.pre, count2,
13027 : 0 : fold_convert (TREE_TYPE (count2), count));
13028 : :
13029 : 35 : if (stat2 != NULL_TREE)
13030 : 0 : gfc_add_modify (&se.pre, stat2,
13031 : 0 : fold_convert (TREE_TYPE (stat2), stat));
13032 : :
13033 : 35 : return gfc_finish_block (&se.pre);
13034 : : }
13035 : :
13036 : 35 : gfc_init_se (&argse, NULL);
13037 : 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13038 : 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13039 : :
13040 : 35 : if (stat != NULL_TREE)
13041 : 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13042 : :
13043 : 35 : return gfc_finish_block (&se.pre);
13044 : : }
13045 : :
13046 : :
13047 : : /* This is a peculiar case because of the need to do dependency checking.
13048 : : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13049 : : a special case and this function called instead of
13050 : : gfc_conv_procedure_call. */
13051 : : void
13052 : 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13053 : : gfc_loopinfo *loop)
13054 : : {
13055 : 197 : gfc_actual_arglist *actual;
13056 : 197 : gfc_se argse[5];
13057 : 197 : gfc_expr *arg[5];
13058 : 197 : gfc_ss *lss;
13059 : 197 : int n;
13060 : :
13061 : 197 : tree from, frompos, len, to, topos;
13062 : 197 : tree lenmask, oldbits, newbits, bitsize;
13063 : 197 : tree type, utype, above, mask1, mask2;
13064 : :
13065 : 197 : if (loop)
13066 : 67 : lss = loop->ss;
13067 : : else
13068 : 130 : lss = gfc_ss_terminator;
13069 : :
13070 : : actual = actual_args;
13071 : 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13072 : : {
13073 : 985 : arg[n] = actual->expr;
13074 : 985 : gfc_init_se (&argse[n], NULL);
13075 : :
13076 : 985 : if (lss != gfc_ss_terminator)
13077 : : {
13078 : 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13079 : : /* Find the ss for the expression if it is there. */
13080 : 335 : argse[n].ss = lss;
13081 : 335 : gfc_mark_ss_chain_used (lss, 1);
13082 : : }
13083 : :
13084 : 985 : gfc_conv_expr (&argse[n], arg[n]);
13085 : :
13086 : 985 : if (loop)
13087 : 335 : lss = argse[n].ss;
13088 : : }
13089 : :
13090 : 197 : from = argse[0].expr;
13091 : 197 : frompos = argse[1].expr;
13092 : 197 : len = argse[2].expr;
13093 : 197 : to = argse[3].expr;
13094 : 197 : topos = argse[4].expr;
13095 : :
13096 : : /* The type of the result (TO). */
13097 : 197 : type = TREE_TYPE (to);
13098 : 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13099 : :
13100 : : /* Optionally generate code for runtime argument check. */
13101 : 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13102 : : {
13103 : 18 : tree nbits, below, ccond;
13104 : 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13105 : 18 : tree ln = fold_convert (long_integer_type_node, len);
13106 : 18 : tree tp = fold_convert (long_integer_type_node, topos);
13107 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
13108 : : logical_type_node, frompos,
13109 : 18 : build_int_cst (TREE_TYPE (frompos), 0));
13110 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
13111 : : logical_type_node, frompos,
13112 : 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13113 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13114 : : logical_type_node, below, above);
13115 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13116 : 18 : &arg[1]->where,
13117 : : "FROMPOS argument (%ld) out of range 0:%d "
13118 : : "in intrinsic MVBITS", fp, bitsize);
13119 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
13120 : : logical_type_node, len,
13121 : 18 : build_int_cst (TREE_TYPE (len), 0));
13122 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
13123 : : logical_type_node, len,
13124 : 18 : fold_convert (TREE_TYPE (len), bitsize));
13125 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13126 : : logical_type_node, below, above);
13127 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13128 : 18 : &arg[2]->where,
13129 : : "LEN argument (%ld) out of range 0:%d "
13130 : : "in intrinsic MVBITS", ln, bitsize);
13131 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
13132 : : logical_type_node, topos,
13133 : 18 : build_int_cst (TREE_TYPE (topos), 0));
13134 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
13135 : : logical_type_node, topos,
13136 : 18 : fold_convert (TREE_TYPE (topos), bitsize));
13137 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13138 : : logical_type_node, below, above);
13139 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13140 : 18 : &arg[4]->where,
13141 : : "TOPOS argument (%ld) out of range 0:%d "
13142 : : "in intrinsic MVBITS", tp, bitsize);
13143 : :
13144 : : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13145 : : integers. Additions below cannot overflow. */
13146 : 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13147 : 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13148 : : long_integer_type_node, fp, ln);
13149 : 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13150 : : logical_type_node, above, nbits);
13151 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13152 : : &arg[1]->where,
13153 : : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13154 : : "in intrinsic MVBITS", fp, ln, bitsize);
13155 : 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13156 : : long_integer_type_node, tp, ln);
13157 : 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13158 : : logical_type_node, above, nbits);
13159 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13160 : : &arg[4]->where,
13161 : : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13162 : : "in intrinsic MVBITS", tp, ln, bitsize);
13163 : : }
13164 : :
13165 : 1182 : for (n = 0; n < 5; n++)
13166 : : {
13167 : 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13168 : 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13169 : : }
13170 : :
13171 : : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13172 : 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13173 : 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13174 : 197 : mask1 = build_int_cst (type, -1);
13175 : 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13176 : : build_int_cst (type, 1), len);
13177 : 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13178 : : mask2, build_int_cst (type, 1));
13179 : 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13180 : : above, mask1, mask2);
13181 : :
13182 : : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13183 : : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13184 : : * not strictly necessary; artificial bits from rshift will be masked. */
13185 : 197 : utype = unsigned_type_for (type);
13186 : 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13187 : : fold_convert (utype, from), frompos);
13188 : 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13189 : : fold_convert (type, newbits), lenmask);
13190 : 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13191 : : newbits, topos);
13192 : :
13193 : : /* oldbits = TO & (~(lenmask << TOPOS)). */
13194 : 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13195 : : lenmask, topos);
13196 : 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13197 : 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13198 : :
13199 : : /* TO = newbits | oldbits. */
13200 : 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13201 : : oldbits, newbits);
13202 : :
13203 : : /* Return the assignment. */
13204 : 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13205 : : void_type_node, to, se->expr);
13206 : 197 : }
13207 : :
13208 : : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13209 : : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13210 : : tree *stat, tree *errmsg, tree *errmsg_len);
13211 : :
13212 : : static tree
13213 : 260 : conv_intrinsic_move_alloc (gfc_code *code)
13214 : : {
13215 : 260 : stmtblock_t block;
13216 : 260 : gfc_expr *from_expr, *to_expr;
13217 : 260 : gfc_se from_se, to_se;
13218 : 260 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13219 : 260 : bool coarray, from_is_class, from_is_scalar;
13220 : 260 : gfc_actual_arglist *arg = code->ext.actual;
13221 : 260 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13222 : :
13223 : 260 : gfc_start_block (&block);
13224 : :
13225 : 260 : from_expr = arg->expr;
13226 : 260 : arg = arg->next;
13227 : 260 : to_expr = arg->expr;
13228 : 260 : arg = arg->next;
13229 : :
13230 : 780 : while (arg)
13231 : : {
13232 : 520 : if (arg->expr)
13233 : : {
13234 : 0 : if (!strcmp ("stat", arg->name))
13235 : 0 : tmp_sync_stat.stat = arg->expr;
13236 : 0 : else if (!strcmp ("errmsg", arg->name))
13237 : 0 : tmp_sync_stat.errmsg = arg->expr;
13238 : : }
13239 : 520 : arg = arg->next;
13240 : : }
13241 : :
13242 : 260 : gfc_init_se (&from_se, NULL);
13243 : 260 : gfc_init_se (&to_se, NULL);
13244 : :
13245 : 260 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13246 : 260 : if (stat != null_pointer_node)
13247 : 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13248 : :
13249 : 260 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13250 : 260 : coarray = from_expr->corank != 0;
13251 : :
13252 : 260 : from_is_class = from_expr->ts.type == BT_CLASS;
13253 : 260 : from_is_scalar = from_expr->rank == 0 && !coarray;
13254 : 260 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13255 : : {
13256 : 163 : from_se.want_pointer = 1;
13257 : 163 : if (from_is_scalar)
13258 : 115 : gfc_conv_expr (&from_se, from_expr);
13259 : : else
13260 : 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13261 : 163 : if (from_is_class)
13262 : 64 : from_tree = gfc_class_data_get (from_se.expr);
13263 : : else
13264 : : {
13265 : 99 : gfc_symbol *vtab;
13266 : 99 : from_tree = from_se.expr;
13267 : :
13268 : 99 : if (to_expr->ts.type == BT_CLASS)
13269 : : {
13270 : 36 : vtab = gfc_find_vtab (&from_expr->ts);
13271 : 36 : gcc_assert (vtab);
13272 : 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13273 : : }
13274 : : }
13275 : 163 : gfc_add_block_to_block (&block, &from_se.pre);
13276 : :
13277 : 163 : to_se.want_pointer = 1;
13278 : 163 : if (to_expr->rank == 0)
13279 : 115 : gfc_conv_expr (&to_se, to_expr);
13280 : : else
13281 : 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13282 : 163 : if (to_expr->ts.type == BT_CLASS)
13283 : 100 : to_tree = gfc_class_data_get (to_se.expr);
13284 : : else
13285 : 63 : to_tree = to_se.expr;
13286 : 163 : gfc_add_block_to_block (&block, &to_se.pre);
13287 : :
13288 : : /* Deallocate "to". */
13289 : 163 : if (to_expr->rank == 0)
13290 : : {
13291 : 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13292 : : true, to_expr, to_expr->ts,
13293 : : NULL_TREE, false, true,
13294 : : errmsg, errmsg_len);
13295 : 115 : gfc_add_expr_to_block (&block, tmp);
13296 : : }
13297 : :
13298 : 163 : if (from_is_scalar)
13299 : : {
13300 : : /* Assign (_data) pointers. */
13301 : 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13302 : 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13303 : :
13304 : : /* Set "from" to NULL. */
13305 : 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13306 : 115 : fold_convert (TREE_TYPE (from_tree),
13307 : : null_pointer_node));
13308 : :
13309 : 115 : gfc_add_block_to_block (&block, &from_se.post);
13310 : : }
13311 : 163 : gfc_add_block_to_block (&block, &to_se.post);
13312 : :
13313 : : /* Set _vptr. */
13314 : 163 : if (to_expr->ts.type == BT_CLASS)
13315 : : {
13316 : 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13317 : 100 : if (from_is_class)
13318 : 64 : gfc_reset_vptr (&block, from_expr);
13319 : 100 : if (UNLIMITED_POLY (to_expr))
13320 : : {
13321 : 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13322 : 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13323 : 20 : ? from_se.string_length
13324 : : : size_zero_node;
13325 : 20 : gfc_add_modify_loc (input_location, &block, to_len,
13326 : 20 : fold_convert (TREE_TYPE (to_len), tmp));
13327 : : }
13328 : : }
13329 : :
13330 : 163 : if (from_is_scalar)
13331 : : {
13332 : 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13333 : : {
13334 : 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13335 : 6 : fold_convert (TREE_TYPE (to_se.string_length),
13336 : : from_se.string_length));
13337 : 6 : if (from_expr->ts.deferred)
13338 : 6 : gfc_add_modify_loc (
13339 : : input_location, &block, from_se.string_length,
13340 : 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13341 : : }
13342 : 115 : if (UNLIMITED_POLY (from_expr))
13343 : 2 : gfc_reset_len (&block, from_expr);
13344 : :
13345 : 115 : return gfc_finish_block (&block);
13346 : : }
13347 : :
13348 : 48 : gfc_init_se (&to_se, NULL);
13349 : 48 : gfc_init_se (&from_se, NULL);
13350 : : }
13351 : :
13352 : : /* Deallocate "to". */
13353 : 145 : if (from_expr->rank == 0)
13354 : : {
13355 : 3 : to_se.want_coarray = 1;
13356 : 3 : from_se.want_coarray = 1;
13357 : : }
13358 : 145 : gfc_conv_expr_descriptor (&to_se, to_expr);
13359 : 145 : gfc_conv_expr_descriptor (&from_se, from_expr);
13360 : 145 : gfc_add_block_to_block (&block, &to_se.pre);
13361 : 145 : gfc_add_block_to_block (&block, &from_se.pre);
13362 : :
13363 : : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13364 : : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13365 : 145 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13366 : : {
13367 : 4 : tree cond;
13368 : :
13369 : 4 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13370 : : fin_label, true, to_expr,
13371 : : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13372 : : NULL_TREE, NULL_TREE,
13373 : : gfc_conv_descriptor_token (to_se.expr),
13374 : : true);
13375 : 4 : gfc_add_expr_to_block (&block, tmp);
13376 : :
13377 : 4 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13378 : 4 : cond = fold_build2_loc (input_location, EQ_EXPR,
13379 : : logical_type_node, tmp,
13380 : 4 : fold_convert (TREE_TYPE (tmp),
13381 : : null_pointer_node));
13382 : 4 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13383 : : 3, null_pointer_node, null_pointer_node,
13384 : : integer_zero_node);
13385 : :
13386 : 4 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13387 : : tmp, build_empty_stmt (input_location));
13388 : 4 : gfc_add_expr_to_block (&block, tmp);
13389 : 4 : }
13390 : : else
13391 : : {
13392 : 141 : if (to_expr->ts.type == BT_DERIVED
13393 : 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13394 : : {
13395 : 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13396 : : to_se.expr, to_expr->rank);
13397 : 19 : gfc_add_expr_to_block (&block, tmp);
13398 : : }
13399 : :
13400 : 141 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13401 : : fin_label, true, to_expr,
13402 : : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13403 : : NULL_TREE, NULL_TREE, true);
13404 : 141 : gfc_add_expr_to_block (&block, tmp);
13405 : : }
13406 : :
13407 : : /* Copy the array descriptor data. */
13408 : 145 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13409 : :
13410 : : /* Set "from" to NULL. */
13411 : 145 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13412 : 145 : gfc_add_modify_loc (input_location, &block, tmp,
13413 : 145 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13414 : :
13415 : 145 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13416 : : {
13417 : : /* Copy the array descriptor data has overwritten the to-token and cleared
13418 : : from.data. Now also clear the from.token. */
13419 : 4 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13420 : : null_pointer_node);
13421 : : }
13422 : :
13423 : 145 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13424 : : {
13425 : 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13426 : 7 : fold_convert (TREE_TYPE (to_se.string_length),
13427 : : from_se.string_length));
13428 : 7 : if (from_expr->ts.deferred)
13429 : 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13430 : 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13431 : : }
13432 : 145 : if (fin_label)
13433 : 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13434 : :
13435 : 145 : gfc_add_block_to_block (&block, &to_se.post);
13436 : 145 : gfc_add_block_to_block (&block, &from_se.post);
13437 : :
13438 : 145 : return gfc_finish_block (&block);
13439 : : }
13440 : :
13441 : :
13442 : : tree
13443 : 6123 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13444 : : {
13445 : 6123 : tree res;
13446 : :
13447 : 6123 : gcc_assert (code->resolved_isym);
13448 : :
13449 : 6123 : switch (code->resolved_isym->id)
13450 : : {
13451 : 260 : case GFC_ISYM_MOVE_ALLOC:
13452 : 260 : res = conv_intrinsic_move_alloc (code);
13453 : 260 : break;
13454 : :
13455 : 10 : case GFC_ISYM_ATOMIC_CAS:
13456 : 10 : res = conv_intrinsic_atomic_cas (code);
13457 : 10 : break;
13458 : :
13459 : 68 : case GFC_ISYM_ATOMIC_ADD:
13460 : 68 : case GFC_ISYM_ATOMIC_AND:
13461 : 68 : case GFC_ISYM_ATOMIC_DEF:
13462 : 68 : case GFC_ISYM_ATOMIC_OR:
13463 : 68 : case GFC_ISYM_ATOMIC_XOR:
13464 : 68 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13465 : 68 : case GFC_ISYM_ATOMIC_FETCH_AND:
13466 : 68 : case GFC_ISYM_ATOMIC_FETCH_OR:
13467 : 68 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13468 : 68 : res = conv_intrinsic_atomic_op (code);
13469 : 68 : break;
13470 : :
13471 : 119 : case GFC_ISYM_ATOMIC_REF:
13472 : 119 : res = conv_intrinsic_atomic_ref (code);
13473 : 119 : break;
13474 : :
13475 : 70 : case GFC_ISYM_EVENT_QUERY:
13476 : 70 : res = conv_intrinsic_event_query (code);
13477 : 70 : break;
13478 : :
13479 : 2853 : case GFC_ISYM_C_F_POINTER:
13480 : 2853 : case GFC_ISYM_C_F_PROCPOINTER:
13481 : 2853 : res = conv_isocbinding_subroutine (code);
13482 : 2853 : break;
13483 : :
13484 : 293 : case GFC_ISYM_CAF_SEND:
13485 : 293 : res = conv_caf_send_to_remote (code);
13486 : 293 : break;
13487 : :
13488 : 97 : case GFC_ISYM_CAF_SENDGET:
13489 : 97 : res = conv_caf_sendget (code);
13490 : 97 : break;
13491 : :
13492 : 63 : case GFC_ISYM_CO_BROADCAST:
13493 : 63 : case GFC_ISYM_CO_MIN:
13494 : 63 : case GFC_ISYM_CO_MAX:
13495 : 63 : case GFC_ISYM_CO_REDUCE:
13496 : 63 : case GFC_ISYM_CO_SUM:
13497 : 63 : res = conv_co_collective (code);
13498 : 63 : break;
13499 : :
13500 : 10 : case GFC_ISYM_FREE:
13501 : 10 : res = conv_intrinsic_free (code);
13502 : 10 : break;
13503 : :
13504 : 55 : case GFC_ISYM_FSTAT:
13505 : 55 : case GFC_ISYM_LSTAT:
13506 : 55 : case GFC_ISYM_STAT:
13507 : 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13508 : 55 : break;
13509 : :
13510 : 90 : case GFC_ISYM_RANDOM_INIT:
13511 : 90 : res = conv_intrinsic_random_init (code);
13512 : 90 : break;
13513 : :
13514 : 15 : case GFC_ISYM_KILL:
13515 : 15 : res = conv_intrinsic_kill_sub (code);
13516 : 15 : break;
13517 : :
13518 : : case GFC_ISYM_MVBITS:
13519 : : res = NULL_TREE;
13520 : : break;
13521 : :
13522 : 194 : case GFC_ISYM_SYSTEM_CLOCK:
13523 : 194 : res = conv_intrinsic_system_clock (code);
13524 : 194 : break;
13525 : :
13526 : 102 : case GFC_ISYM_SPLIT:
13527 : 102 : res = conv_intrinsic_split (code);
13528 : 102 : break;
13529 : :
13530 : : default:
13531 : : res = NULL_TREE;
13532 : : break;
13533 : : }
13534 : :
13535 : 6123 : return res;
13536 : : }
13537 : :
13538 : : #include "gt-fortran-trans-intrinsic.h"
|
