1 /* Intrinsic translation
2 Copyright (C) 2002-2018 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.c-- generate GENERIC trees for calls to intrinsics. */
23
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "memmodel.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
29 #include "tree.h"
30 #include "gfortran.h"
31 #include "trans.h"
32 #include "stringpool.h"
33 #include "fold-const.h"
34 #include "tree-nested.h"
35 #include "stor-layout.h"
36 #include "toplev.h" /* For rest_of_decl_compilation. */
37 #include "arith.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "dependency.h" /* For CAF array alias analysis. */
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43
44 /* This maps Fortran intrinsic math functions to external library or GCC
45 builtin functions. */
46 typedef struct GTY(()) gfc_intrinsic_map_t {
47 /* The explicit enum is required to work around inadequacies in the
48 garbage collection/gengtype parsing mechanism. */
49 enum gfc_isym_id id;
50
51 /* Enum value from the "language-independent", aka C-centric, part
52 of gcc, or END_BUILTINS of no such value set. */
53 enum built_in_function float_built_in;
54 enum built_in_function double_built_in;
55 enum built_in_function long_double_built_in;
56 enum built_in_function complex_float_built_in;
57 enum built_in_function complex_double_built_in;
58 enum built_in_function complex_long_double_built_in;
59
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
63 bool libm_name;
64
65 /* True if a complex version of the function exists. */
66 bool complex_available;
67
68 /* True if the function should be marked const. */
69 bool is_constant;
70
71 /* The base library name of this function. */
72 const char *name;
73
74 /* Cache decls created for the various operand types. */
75 tree real4_decl;
76 tree real8_decl;
77 tree real10_decl;
78 tree real16_decl;
79 tree complex4_decl;
80 tree complex8_decl;
81 tree complex10_decl;
82 tree complex16_decl;
83 }
84 gfc_intrinsic_map_t;
85
86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
87 defines complex variants of all of the entries in mathbuiltins.def
88 except for atan2. */
89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
90 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
91 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
92 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
93 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
94
95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
96 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
97 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
98 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
99 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100
101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
102 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
103 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
106
107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
108 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
109 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
112
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
114 {
115 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
116 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
117 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
118 #include "mathbuiltins.def"
119
120 /* Functions in libgfortran. */
121 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
122
123 /* End the list. */
124 LIB_FUNCTION (NONE, NULL, false)
125
126 };
127 #undef OTHER_BUILTIN
128 #undef LIB_FUNCTION
129 #undef DEFINE_MATH_BUILTIN
130 #undef DEFINE_MATH_BUILTIN_C
131
132
133 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
134
135
136 /* Find the correct variant of a given builtin from its argument. */
137 static tree
builtin_decl_for_precision(enum built_in_function base_built_in,int precision)138 builtin_decl_for_precision (enum built_in_function base_built_in,
139 int precision)
140 {
141 enum built_in_function i = END_BUILTINS;
142
143 gfc_intrinsic_map_t *m;
144 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
145 ;
146
147 if (precision == TYPE_PRECISION (float_type_node))
148 i = m->float_built_in;
149 else if (precision == TYPE_PRECISION (double_type_node))
150 i = m->double_built_in;
151 else if (precision == TYPE_PRECISION (long_double_type_node))
152 i = m->long_double_built_in;
153 else if (precision == TYPE_PRECISION (gfc_float128_type_node))
154 {
155 /* Special treatment, because it is not exactly a built-in, but
156 a library function. */
157 return m->real16_decl;
158 }
159
160 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
161 }
162
163
164 tree
gfc_builtin_decl_for_float_kind(enum built_in_function double_built_in,int kind)165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
166 int kind)
167 {
168 int i = gfc_validate_kind (BT_REAL, kind, false);
169
170 if (gfc_real_kinds[i].c_float128)
171 {
172 /* For __float128, the story is a bit different, because we return
173 a decl to a library function rather than a built-in. */
174 gfc_intrinsic_map_t *m;
175 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
176 ;
177
178 return m->real16_decl;
179 }
180
181 return builtin_decl_for_precision (double_built_in,
182 gfc_real_kinds[i].mode_precision);
183 }
184
185
186 /* Evaluate the arguments to an intrinsic function. The value
187 of NARGS may be less than the actual number of arguments in EXPR
188 to allow optional "KIND" arguments that are not included in the
189 generated code to be ignored. */
190
191 static void
gfc_conv_intrinsic_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)192 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
193 tree *argarray, int nargs)
194 {
195 gfc_actual_arglist *actual;
196 gfc_expr *e;
197 gfc_intrinsic_arg *formal;
198 gfc_se argse;
199 int curr_arg;
200
201 formal = expr->value.function.isym->formal;
202 actual = expr->value.function.actual;
203
204 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
205 actual = actual->next,
206 formal = formal ? formal->next : NULL)
207 {
208 gcc_assert (actual);
209 e = actual->expr;
210 /* Skip omitted optional arguments. */
211 if (!e)
212 {
213 --curr_arg;
214 continue;
215 }
216
217 /* Evaluate the parameter. This will substitute scalarized
218 references automatically. */
219 gfc_init_se (&argse, se);
220
221 if (e->ts.type == BT_CHARACTER)
222 {
223 gfc_conv_expr (&argse, e);
224 gfc_conv_string_parameter (&argse);
225 argarray[curr_arg++] = argse.string_length;
226 gcc_assert (curr_arg < nargs);
227 }
228 else
229 gfc_conv_expr_val (&argse, e);
230
231 /* If an optional argument is itself an optional dummy argument,
232 check its presence and substitute a null if absent. */
233 if (e->expr_type == EXPR_VARIABLE
234 && e->symtree->n.sym->attr.optional
235 && formal
236 && formal->optional)
237 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
238
239 gfc_add_block_to_block (&se->pre, &argse.pre);
240 gfc_add_block_to_block (&se->post, &argse.post);
241 argarray[curr_arg] = argse.expr;
242 }
243 }
244
245 /* Count the number of actual arguments to the intrinsic function EXPR
246 including any "hidden" string length arguments. */
247
248 static unsigned int
gfc_intrinsic_argument_list_length(gfc_expr * expr)249 gfc_intrinsic_argument_list_length (gfc_expr *expr)
250 {
251 int n = 0;
252 gfc_actual_arglist *actual;
253
254 for (actual = expr->value.function.actual; actual; actual = actual->next)
255 {
256 if (!actual->expr)
257 continue;
258
259 if (actual->expr->ts.type == BT_CHARACTER)
260 n += 2;
261 else
262 n++;
263 }
264
265 return n;
266 }
267
268
269 /* Conversions between different types are output by the frontend as
270 intrinsic functions. We implement these directly with inline code. */
271
272 static void
gfc_conv_intrinsic_conversion(gfc_se * se,gfc_expr * expr)273 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
274 {
275 tree type;
276 tree *args;
277 int nargs;
278
279 nargs = gfc_intrinsic_argument_list_length (expr);
280 args = XALLOCAVEC (tree, nargs);
281
282 /* Evaluate all the arguments passed. Whilst we're only interested in the
283 first one here, there are other parts of the front-end that assume this
284 and will trigger an ICE if it's not the case. */
285 type = gfc_typenode_for_spec (&expr->ts);
286 gcc_assert (expr->value.function.actual->expr);
287 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
288
289 /* Conversion between character kinds involves a call to a library
290 function. */
291 if (expr->ts.type == BT_CHARACTER)
292 {
293 tree fndecl, var, addr, tmp;
294
295 if (expr->ts.kind == 1
296 && expr->value.function.actual->expr->ts.kind == 4)
297 fndecl = gfor_fndecl_convert_char4_to_char1;
298 else if (expr->ts.kind == 4
299 && expr->value.function.actual->expr->ts.kind == 1)
300 fndecl = gfor_fndecl_convert_char1_to_char4;
301 else
302 gcc_unreachable ();
303
304 /* Create the variable storing the converted value. */
305 type = gfc_get_pchar_type (expr->ts.kind);
306 var = gfc_create_var (type, "str");
307 addr = gfc_build_addr_expr (build_pointer_type (type), var);
308
309 /* Call the library function that will perform the conversion. */
310 gcc_assert (nargs >= 2);
311 tmp = build_call_expr_loc (input_location,
312 fndecl, 3, addr, args[0], args[1]);
313 gfc_add_expr_to_block (&se->pre, tmp);
314
315 /* Free the temporary afterwards. */
316 tmp = gfc_call_free (var);
317 gfc_add_expr_to_block (&se->post, tmp);
318
319 se->expr = var;
320 se->string_length = args[0];
321
322 return;
323 }
324
325 /* Conversion from complex to non-complex involves taking the real
326 component of the value. */
327 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
328 && expr->ts.type != BT_COMPLEX)
329 {
330 tree artype;
331
332 artype = TREE_TYPE (TREE_TYPE (args[0]));
333 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
334 args[0]);
335 }
336
337 se->expr = convert (type, args[0]);
338 }
339
340 /* This is needed because the gcc backend only implements
341 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
342 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
343 Similarly for CEILING. */
344
345 static tree
build_fixbound_expr(stmtblock_t * pblock,tree arg,tree type,int up)346 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
347 {
348 tree tmp;
349 tree cond;
350 tree argtype;
351 tree intval;
352
353 argtype = TREE_TYPE (arg);
354 arg = gfc_evaluate_now (arg, pblock);
355
356 intval = convert (type, arg);
357 intval = gfc_evaluate_now (intval, pblock);
358
359 tmp = convert (argtype, intval);
360 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
361 logical_type_node, tmp, arg);
362
363 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
364 intval, build_int_cst (type, 1));
365 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
366 return tmp;
367 }
368
369
370 /* Round to nearest integer, away from zero. */
371
372 static tree
build_round_expr(tree arg,tree restype)373 build_round_expr (tree arg, tree restype)
374 {
375 tree argtype;
376 tree fn;
377 int argprec, resprec;
378
379 argtype = TREE_TYPE (arg);
380 argprec = TYPE_PRECISION (argtype);
381 resprec = TYPE_PRECISION (restype);
382
383 /* Depending on the type of the result, choose the int intrinsic
384 (iround, available only as a builtin, therefore cannot use it for
385 __float128), long int intrinsic (lround family) or long long
386 intrinsic (llround). We might also need to convert the result
387 afterwards. */
388 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
389 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
390 else if (resprec <= LONG_TYPE_SIZE)
391 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
392 else if (resprec <= LONG_LONG_TYPE_SIZE)
393 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
394 else
395 gcc_unreachable ();
396
397 return fold_convert (restype, build_call_expr_loc (input_location,
398 fn, 1, arg));
399 }
400
401
402 /* Convert a real to an integer using a specific rounding mode.
403 Ideally we would just build the corresponding GENERIC node,
404 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
405
406 static tree
build_fix_expr(stmtblock_t * pblock,tree arg,tree type,enum rounding_mode op)407 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
408 enum rounding_mode op)
409 {
410 switch (op)
411 {
412 case RND_FLOOR:
413 return build_fixbound_expr (pblock, arg, type, 0);
414
415 case RND_CEIL:
416 return build_fixbound_expr (pblock, arg, type, 1);
417
418 case RND_ROUND:
419 return build_round_expr (arg, type);
420
421 case RND_TRUNC:
422 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
423
424 default:
425 gcc_unreachable ();
426 }
427 }
428
429
430 /* Round a real value using the specified rounding mode.
431 We use a temporary integer of that same kind size as the result.
432 Values larger than those that can be represented by this kind are
433 unchanged, as they will not be accurate enough to represent the
434 rounding.
435 huge = HUGE (KIND (a))
436 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
437 */
438
439 static void
gfc_conv_intrinsic_aint(gfc_se * se,gfc_expr * expr,enum rounding_mode op)440 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
441 {
442 tree type;
443 tree itype;
444 tree arg[2];
445 tree tmp;
446 tree cond;
447 tree decl;
448 mpfr_t huge;
449 int n, nargs;
450 int kind;
451
452 kind = expr->ts.kind;
453 nargs = gfc_intrinsic_argument_list_length (expr);
454
455 decl = NULL_TREE;
456 /* We have builtin functions for some cases. */
457 switch (op)
458 {
459 case RND_ROUND:
460 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
461 break;
462
463 case RND_TRUNC:
464 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
465 break;
466
467 default:
468 gcc_unreachable ();
469 }
470
471 /* Evaluate the argument. */
472 gcc_assert (expr->value.function.actual->expr);
473 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
474
475 /* Use a builtin function if one exists. */
476 if (decl != NULL_TREE)
477 {
478 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
479 return;
480 }
481
482 /* This code is probably redundant, but we'll keep it lying around just
483 in case. */
484 type = gfc_typenode_for_spec (&expr->ts);
485 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
486
487 /* Test if the value is too large to handle sensibly. */
488 gfc_set_model_kind (kind);
489 mpfr_init (huge);
490 n = gfc_validate_kind (BT_INTEGER, kind, false);
491 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
492 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
493 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
494 tmp);
495
496 mpfr_neg (huge, huge, GFC_RND_MODE);
497 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
498 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
499 tmp);
500 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
501 cond, tmp);
502 itype = gfc_get_int_type (kind);
503
504 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
505 tmp = convert (type, tmp);
506 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
507 arg[0]);
508 mpfr_clear (huge);
509 }
510
511
512 /* Convert to an integer using the specified rounding mode. */
513
514 static void
gfc_conv_intrinsic_int(gfc_se * se,gfc_expr * expr,enum rounding_mode op)515 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
516 {
517 tree type;
518 tree *args;
519 int nargs;
520
521 nargs = gfc_intrinsic_argument_list_length (expr);
522 args = XALLOCAVEC (tree, nargs);
523
524 /* Evaluate the argument, we process all arguments even though we only
525 use the first one for code generation purposes. */
526 type = gfc_typenode_for_spec (&expr->ts);
527 gcc_assert (expr->value.function.actual->expr);
528 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
529
530 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
531 {
532 /* Conversion to a different integer kind. */
533 se->expr = convert (type, args[0]);
534 }
535 else
536 {
537 /* Conversion from complex to non-complex involves taking the real
538 component of the value. */
539 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
540 && expr->ts.type != BT_COMPLEX)
541 {
542 tree artype;
543
544 artype = TREE_TYPE (TREE_TYPE (args[0]));
545 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
546 args[0]);
547 }
548
549 se->expr = build_fix_expr (&se->pre, args[0], type, op);
550 }
551 }
552
553
554 /* Get the imaginary component of a value. */
555
556 static void
gfc_conv_intrinsic_imagpart(gfc_se * se,gfc_expr * expr)557 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
558 {
559 tree arg;
560
561 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
562 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
563 TREE_TYPE (TREE_TYPE (arg)), arg);
564 }
565
566
567 /* Get the complex conjugate of a value. */
568
569 static void
gfc_conv_intrinsic_conjg(gfc_se * se,gfc_expr * expr)570 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
571 {
572 tree arg;
573
574 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
575 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
576 }
577
578
579
580 static tree
define_quad_builtin(const char * name,tree type,bool is_const)581 define_quad_builtin (const char *name, tree type, bool is_const)
582 {
583 tree fndecl;
584 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
585 type);
586
587 /* Mark the decl as external. */
588 DECL_EXTERNAL (fndecl) = 1;
589 TREE_PUBLIC (fndecl) = 1;
590
591 /* Mark it __attribute__((const)). */
592 TREE_READONLY (fndecl) = is_const;
593
594 rest_of_decl_compilation (fndecl, 1, 0);
595
596 return fndecl;
597 }
598
599
600
601 /* Initialize function decls for library functions. The external functions
602 are created as required. Builtin functions are added here. */
603
604 void
gfc_build_intrinsic_lib_fndecls(void)605 gfc_build_intrinsic_lib_fndecls (void)
606 {
607 gfc_intrinsic_map_t *m;
608 tree quad_decls[END_BUILTINS + 1];
609
610 if (gfc_real16_is_float128)
611 {
612 /* If we have soft-float types, we create the decls for their
613 C99-like library functions. For now, we only handle __float128
614 q-suffixed functions. */
615
616 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
617 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
618
619 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
620
621 type = gfc_float128_type_node;
622 complex_type = gfc_complex_float128_type_node;
623 /* type (*) (type) */
624 func_1 = build_function_type_list (type, type, NULL_TREE);
625 /* int (*) (type) */
626 func_iround = build_function_type_list (integer_type_node,
627 type, NULL_TREE);
628 /* long (*) (type) */
629 func_lround = build_function_type_list (long_integer_type_node,
630 type, NULL_TREE);
631 /* long long (*) (type) */
632 func_llround = build_function_type_list (long_long_integer_type_node,
633 type, NULL_TREE);
634 /* type (*) (type, type) */
635 func_2 = build_function_type_list (type, type, type, NULL_TREE);
636 /* type (*) (type, &int) */
637 func_frexp
638 = build_function_type_list (type,
639 type,
640 build_pointer_type (integer_type_node),
641 NULL_TREE);
642 /* type (*) (type, int) */
643 func_scalbn = build_function_type_list (type,
644 type, integer_type_node, NULL_TREE);
645 /* type (*) (complex type) */
646 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
647 /* complex type (*) (complex type, complex type) */
648 func_cpow
649 = build_function_type_list (complex_type,
650 complex_type, complex_type, NULL_TREE);
651
652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
655
656 /* Only these built-ins are actually needed here. These are used directly
657 from the code, when calling builtin_decl_for_precision() or
658 builtin_decl_for_float_type(). The others are all constructed by
659 gfc_get_intrinsic_lib_fndecl(). */
660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
661 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
662
663 #include "mathbuiltins.def"
664
665 #undef OTHER_BUILTIN
666 #undef LIB_FUNCTION
667 #undef DEFINE_MATH_BUILTIN
668 #undef DEFINE_MATH_BUILTIN_C
669
670 /* There is one built-in we defined manually, because it gets called
671 with builtin_decl_for_precision() or builtin_decl_for_float_type()
672 even though it is not an OTHER_BUILTIN: it is SQRT. */
673 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
674
675 }
676
677 /* Add GCC builtin functions. */
678 for (m = gfc_intrinsic_map;
679 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
680 {
681 if (m->float_built_in != END_BUILTINS)
682 m->real4_decl = builtin_decl_explicit (m->float_built_in);
683 if (m->complex_float_built_in != END_BUILTINS)
684 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
685 if (m->double_built_in != END_BUILTINS)
686 m->real8_decl = builtin_decl_explicit (m->double_built_in);
687 if (m->complex_double_built_in != END_BUILTINS)
688 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
689
690 /* If real(kind=10) exists, it is always long double. */
691 if (m->long_double_built_in != END_BUILTINS)
692 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
693 if (m->complex_long_double_built_in != END_BUILTINS)
694 m->complex10_decl
695 = builtin_decl_explicit (m->complex_long_double_built_in);
696
697 if (!gfc_real16_is_float128)
698 {
699 if (m->long_double_built_in != END_BUILTINS)
700 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
701 if (m->complex_long_double_built_in != END_BUILTINS)
702 m->complex16_decl
703 = builtin_decl_explicit (m->complex_long_double_built_in);
704 }
705 else if (quad_decls[m->double_built_in] != NULL_TREE)
706 {
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m->real16_decl = quad_decls[m->double_built_in];
711 }
712 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
713 {
714 /* Same thing for the complex ones. */
715 m->complex16_decl = quad_decls[m->double_built_in];
716 }
717 }
718 }
719
720
721 /* Create a fndecl for a simple intrinsic library function. */
722
723 static tree
gfc_get_intrinsic_lib_fndecl(gfc_intrinsic_map_t * m,gfc_expr * expr)724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
725 {
726 tree type;
727 vec<tree, va_gc> *argtypes;
728 tree fndecl;
729 gfc_actual_arglist *actual;
730 tree *pdecl;
731 gfc_typespec *ts;
732 char name[GFC_MAX_SYMBOL_LEN + 3];
733
734 ts = &expr->ts;
735 if (ts->type == BT_REAL)
736 {
737 switch (ts->kind)
738 {
739 case 4:
740 pdecl = &m->real4_decl;
741 break;
742 case 8:
743 pdecl = &m->real8_decl;
744 break;
745 case 10:
746 pdecl = &m->real10_decl;
747 break;
748 case 16:
749 pdecl = &m->real16_decl;
750 break;
751 default:
752 gcc_unreachable ();
753 }
754 }
755 else if (ts->type == BT_COMPLEX)
756 {
757 gcc_assert (m->complex_available);
758
759 switch (ts->kind)
760 {
761 case 4:
762 pdecl = &m->complex4_decl;
763 break;
764 case 8:
765 pdecl = &m->complex8_decl;
766 break;
767 case 10:
768 pdecl = &m->complex10_decl;
769 break;
770 case 16:
771 pdecl = &m->complex16_decl;
772 break;
773 default:
774 gcc_unreachable ();
775 }
776 }
777 else
778 gcc_unreachable ();
779
780 if (*pdecl)
781 return *pdecl;
782
783 if (m->libm_name)
784 {
785 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
786 if (gfc_real_kinds[n].c_float)
787 snprintf (name, sizeof (name), "%s%s%s",
788 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
789 else if (gfc_real_kinds[n].c_double)
790 snprintf (name, sizeof (name), "%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name);
792 else if (gfc_real_kinds[n].c_long_double)
793 snprintf (name, sizeof (name), "%s%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
795 else if (gfc_real_kinds[n].c_float128)
796 snprintf (name, sizeof (name), "%s%s%s",
797 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
798 else
799 gcc_unreachable ();
800 }
801 else
802 {
803 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
804 ts->type == BT_COMPLEX ? 'c' : 'r',
805 ts->kind);
806 }
807
808 argtypes = NULL;
809 for (actual = expr->value.function.actual; actual; actual = actual->next)
810 {
811 type = gfc_typenode_for_spec (&actual->expr->ts);
812 vec_safe_push (argtypes, type);
813 }
814 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
815 fndecl = build_decl (input_location,
816 FUNCTION_DECL, get_identifier (name), type);
817
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl) = 1;
820 TREE_PUBLIC (fndecl) = 1;
821
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl) = m->is_constant;
824
825 rest_of_decl_compilation (fndecl, 1, 0);
826
827 (*pdecl) = fndecl;
828 return fndecl;
829 }
830
831
832 /* Convert an intrinsic function into an external or builtin call. */
833
834 static void
gfc_conv_intrinsic_lib_function(gfc_se * se,gfc_expr * expr)835 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
836 {
837 gfc_intrinsic_map_t *m;
838 tree fndecl;
839 tree rettype;
840 tree *args;
841 unsigned int num_args;
842 gfc_isym_id id;
843
844 id = expr->value.function.isym->id;
845 /* Find the entry for this function. */
846 for (m = gfc_intrinsic_map;
847 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
848 {
849 if (id == m->id)
850 break;
851 }
852
853 if (m->id == GFC_ISYM_NONE)
854 {
855 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
856 expr->value.function.name, id);
857 }
858
859 /* Get the decl and generate the call. */
860 num_args = gfc_intrinsic_argument_list_length (expr);
861 args = XALLOCAVEC (tree, num_args);
862
863 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
864 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
865 rettype = TREE_TYPE (TREE_TYPE (fndecl));
866
867 fndecl = build_addr (fndecl);
868 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
869 }
870
871
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
875
876 void
gfc_trans_same_strlen_check(const char * intr_name,locus * where,tree a,tree b,stmtblock_t * target)877 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
878 tree a, tree b, stmtblock_t* target)
879 {
880 tree cond;
881 tree name;
882
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
885 return;
886
887 /* Compare the two string lengths. */
888 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
889
890 /* Output the runtime-check. */
891 name = gfc_build_cstring_const (intr_name);
892 name = gfc_build_addr_expr (pchar_type_node, name);
893 gfc_trans_runtime_check (true, false, cond, target, where,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node, a),
896 fold_convert (long_integer_type_node, b), name);
897 }
898
899
900 /* The EXPONENT(X) intrinsic function is translated into
901 int ret;
902 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
903 so that if X is a NaN or infinity, the result is HUGE(0).
904 */
905
906 static void
gfc_conv_intrinsic_exponent(gfc_se * se,gfc_expr * expr)907 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
908 {
909 tree arg, type, res, tmp, frexp, cond, huge;
910 int i;
911
912 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
913 expr->value.function.actual->expr->ts.kind);
914
915 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
916 arg = gfc_evaluate_now (arg, &se->pre);
917
918 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
919 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
920 cond = build_call_expr_loc (input_location,
921 builtin_decl_explicit (BUILT_IN_ISFINITE),
922 1, arg);
923
924 res = gfc_create_var (integer_type_node, NULL);
925 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
926 gfc_build_addr_expr (NULL_TREE, res));
927 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
928 tmp, res);
929 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
930 cond, tmp, huge);
931
932 type = gfc_typenode_for_spec (&expr->ts);
933 se->expr = fold_convert (type, se->expr);
934 }
935
936
937 /* Fill in the following structure
938 struct caf_vector_t {
939 size_t nvec; // size of the vector
940 union {
941 struct {
942 void *vector;
943 int kind;
944 } v;
945 struct {
946 ptrdiff_t lower_bound;
947 ptrdiff_t upper_bound;
948 ptrdiff_t stride;
949 } triplet;
950 } u;
951 } */
952
953 static void
conv_caf_vector_subscript_elem(stmtblock_t * block,int i,tree desc,tree lower,tree upper,tree stride,tree vector,int kind,tree nvec)954 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
955 tree lower, tree upper, tree stride,
956 tree vector, int kind, tree nvec)
957 {
958 tree field, type, tmp;
959
960 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
961 type = TREE_TYPE (desc);
962
963 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
964 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
965 desc, field, NULL_TREE);
966 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
967
968 /* Access union. */
969 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
970 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
971 desc, field, NULL_TREE);
972 type = TREE_TYPE (desc);
973
974 /* Access the inner struct. */
975 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
976 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
977 desc, field, NULL_TREE);
978 type = TREE_TYPE (desc);
979
980 if (vector != NULL_TREE)
981 {
982 /* Set vector and kind. */
983 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
984 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
985 desc, field, NULL_TREE);
986 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
987 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
988 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
989 desc, field, NULL_TREE);
990 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
991 }
992 else
993 {
994 /* Set dim.lower/upper/stride. */
995 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
996 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
997 desc, field, NULL_TREE);
998 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
999
1000 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1001 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1002 desc, field, NULL_TREE);
1003 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1004
1005 field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1006 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1007 desc, field, NULL_TREE);
1008 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1009 }
1010 }
1011
1012
1013 static tree
conv_caf_vector_subscript(stmtblock_t * block,tree desc,gfc_array_ref * ar)1014 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1015 {
1016 gfc_se argse;
1017 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1018 tree lbound, ubound, tmp;
1019 int i;
1020
1021 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1022
1023 for (i = 0; i < ar->dimen; i++)
1024 switch (ar->dimen_type[i])
1025 {
1026 case DIMEN_RANGE:
1027 if (ar->end[i])
1028 {
1029 gfc_init_se (&argse, NULL);
1030 gfc_conv_expr (&argse, ar->end[i]);
1031 gfc_add_block_to_block (block, &argse.pre);
1032 upper = gfc_evaluate_now (argse.expr, block);
1033 }
1034 else
1035 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1036 if (ar->stride[i])
1037 {
1038 gfc_init_se (&argse, NULL);
1039 gfc_conv_expr (&argse, ar->stride[i]);
1040 gfc_add_block_to_block (block, &argse.pre);
1041 stride = gfc_evaluate_now (argse.expr, block);
1042 }
1043 else
1044 stride = gfc_index_one_node;
1045
1046 /* Fall through. */
1047 case DIMEN_ELEMENT:
1048 if (ar->start[i])
1049 {
1050 gfc_init_se (&argse, NULL);
1051 gfc_conv_expr (&argse, ar->start[i]);
1052 gfc_add_block_to_block (block, &argse.pre);
1053 lower = gfc_evaluate_now (argse.expr, block);
1054 }
1055 else
1056 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1057 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1058 {
1059 upper = lower;
1060 stride = gfc_index_one_node;
1061 }
1062 vector = NULL_TREE;
1063 nvec = size_zero_node;
1064 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1065 vector, 0, nvec);
1066 break;
1067
1068 case DIMEN_VECTOR:
1069 gfc_init_se (&argse, NULL);
1070 argse.descriptor_only = 1;
1071 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1072 gfc_add_block_to_block (block, &argse.pre);
1073 vector = argse.expr;
1074 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1075 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1076 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1077 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1078 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1079 TREE_TYPE (nvec), nvec, tmp);
1080 lower = gfc_index_zero_node;
1081 upper = gfc_index_zero_node;
1082 stride = gfc_index_zero_node;
1083 vector = gfc_conv_descriptor_data_get (vector);
1084 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1085 vector, ar->start[i]->ts.kind, nvec);
1086 break;
1087 default:
1088 gcc_unreachable();
1089 }
1090 return gfc_build_addr_expr (NULL_TREE, var);
1091 }
1092
1093
1094 static tree
compute_component_offset(tree field,tree type)1095 compute_component_offset (tree field, tree type)
1096 {
1097 tree tmp;
1098 if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1099 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1100 {
1101 tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1102 DECL_FIELD_BIT_OFFSET (field),
1103 bitsize_unit_node);
1104 return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1105 }
1106 else
1107 return DECL_FIELD_OFFSET (field);
1108 }
1109
1110
1111 static tree
conv_expr_ref_to_caf_ref(stmtblock_t * block,gfc_expr * expr)1112 conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1113 {
1114 gfc_ref *ref = expr->ref, *last_comp_ref;
1115 tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1116 field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1117 start, end, stride, vector, nvec;
1118 gfc_se se;
1119 bool ref_static_array = false;
1120 tree last_component_ref_tree = NULL_TREE;
1121 int i, last_type_n;
1122
1123 if (expr->symtree)
1124 {
1125 last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1126 ref_static_array = !expr->symtree->n.sym->attr.allocatable
1127 && !expr->symtree->n.sym->attr.pointer;
1128 }
1129
1130 /* Prevent uninit-warning. */
1131 reference_type = NULL_TREE;
1132
1133 /* Skip refs upto the first coarray-ref. */
1134 last_comp_ref = NULL;
1135 while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1136 {
1137 /* Remember the type of components skipped. */
1138 if (ref->type == REF_COMPONENT)
1139 last_comp_ref = ref;
1140 ref = ref->next;
1141 }
1142 /* When a component was skipped, get the type information of the last
1143 component ref, else get the type from the symbol. */
1144 if (last_comp_ref)
1145 {
1146 last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1147 last_type_n = last_comp_ref->u.c.component->ts.type;
1148 }
1149 else
1150 {
1151 last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1152 last_type_n = expr->symtree->n.sym->ts.type;
1153 }
1154
1155 while (ref)
1156 {
1157 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1158 && ref->u.ar.dimen == 0)
1159 {
1160 /* Skip pure coindexes. */
1161 ref = ref->next;
1162 continue;
1163 }
1164 tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1165 reference_type = TREE_TYPE (tmp);
1166
1167 if (caf_ref == NULL_TREE)
1168 caf_ref = tmp;
1169
1170 /* Construct the chain of refs. */
1171 if (prev_caf_ref != NULL_TREE)
1172 {
1173 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1174 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1175 TREE_TYPE (field), prev_caf_ref, field,
1176 NULL_TREE);
1177 gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1178 tmp));
1179 }
1180 prev_caf_ref = tmp;
1181
1182 switch (ref->type)
1183 {
1184 case REF_COMPONENT:
1185 last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1186 last_type_n = ref->u.c.component->ts.type;
1187 /* Set the type of the ref. */
1188 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1189 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1190 TREE_TYPE (field), prev_caf_ref, field,
1191 NULL_TREE);
1192 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1193 GFC_CAF_REF_COMPONENT));
1194
1195 /* Ref the c in union u. */
1196 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1197 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1198 TREE_TYPE (field), prev_caf_ref, field,
1199 NULL_TREE);
1200 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1201 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1202 TREE_TYPE (field), tmp, field,
1203 NULL_TREE);
1204
1205 /* Set the offset. */
1206 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1207 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1208 TREE_TYPE (field), inner_struct, field,
1209 NULL_TREE);
1210 /* Computing the offset is somewhat harder. The bit_offset has to be
1211 taken into account. When the bit_offset in the field_decl is non-
1212 null, divide it by the bitsize_unit and add it to the regular
1213 offset. */
1214 tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1215 TREE_TYPE (tmp));
1216 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1217
1218 /* Set caf_token_offset. */
1219 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1220 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1221 TREE_TYPE (field), inner_struct, field,
1222 NULL_TREE);
1223 if ((ref->u.c.component->attr.allocatable
1224 || ref->u.c.component->attr.pointer)
1225 && ref->u.c.component->attr.dimension)
1226 {
1227 tree arr_desc_token_offset;
1228 /* Get the token field from the descriptor. */
1229 arr_desc_token_offset = TREE_OPERAND (
1230 gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
1231 arr_desc_token_offset
1232 = compute_component_offset (arr_desc_token_offset,
1233 TREE_TYPE (tmp));
1234 tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1235 TREE_TYPE (tmp2), tmp2,
1236 arr_desc_token_offset);
1237 }
1238 else if (ref->u.c.component->caf_token)
1239 tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1240 TREE_TYPE (tmp));
1241 else
1242 tmp2 = integer_zero_node;
1243 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1244
1245 /* Remember whether this ref was to a non-allocatable/non-pointer
1246 component so the next array ref can be tailored correctly. */
1247 ref_static_array = !ref->u.c.component->attr.allocatable
1248 && !ref->u.c.component->attr.pointer;
1249 last_component_ref_tree = ref_static_array
1250 ? ref->u.c.component->backend_decl : NULL_TREE;
1251 break;
1252 case REF_ARRAY:
1253 if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1254 ref_static_array = false;
1255 /* Set the type of the ref. */
1256 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1257 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1258 TREE_TYPE (field), prev_caf_ref, field,
1259 NULL_TREE);
1260 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1261 ref_static_array
1262 ? GFC_CAF_REF_STATIC_ARRAY
1263 : GFC_CAF_REF_ARRAY));
1264
1265 /* Ref the a in union u. */
1266 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1267 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1268 TREE_TYPE (field), prev_caf_ref, field,
1269 NULL_TREE);
1270 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1271 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1272 TREE_TYPE (field), tmp, field,
1273 NULL_TREE);
1274
1275 /* Set the static_array_type in a for static arrays. */
1276 if (ref_static_array)
1277 {
1278 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1279 1);
1280 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1281 TREE_TYPE (field), inner_struct, field,
1282 NULL_TREE);
1283 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1284 last_type_n));
1285 }
1286 /* Ref the mode in the inner_struct. */
1287 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1288 mode = fold_build3_loc (input_location, COMPONENT_REF,
1289 TREE_TYPE (field), inner_struct, field,
1290 NULL_TREE);
1291 /* Ref the dim in the inner_struct. */
1292 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1293 dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1294 TREE_TYPE (field), inner_struct, field,
1295 NULL_TREE);
1296 for (i = 0; i < ref->u.ar.dimen; ++i)
1297 {
1298 /* Ref dim i. */
1299 dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1300 dim_type = TREE_TYPE (dim);
1301 mode_rhs = start = end = stride = NULL_TREE;
1302 switch (ref->u.ar.dimen_type[i])
1303 {
1304 case DIMEN_RANGE:
1305 if (ref->u.ar.end[i])
1306 {
1307 gfc_init_se (&se, NULL);
1308 gfc_conv_expr (&se, ref->u.ar.end[i]);
1309 gfc_add_block_to_block (block, &se.pre);
1310 if (ref_static_array)
1311 {
1312 /* Make the index zero-based, when reffing a static
1313 array. */
1314 end = se.expr;
1315 gfc_init_se (&se, NULL);
1316 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1317 gfc_add_block_to_block (block, &se.pre);
1318 se.expr = fold_build2 (MINUS_EXPR,
1319 gfc_array_index_type,
1320 end, fold_convert (
1321 gfc_array_index_type,
1322 se.expr));
1323 }
1324 end = gfc_evaluate_now (fold_convert (
1325 gfc_array_index_type,
1326 se.expr),
1327 block);
1328 }
1329 else if (ref_static_array)
1330 end = fold_build2 (MINUS_EXPR,
1331 gfc_array_index_type,
1332 gfc_conv_array_ubound (
1333 last_component_ref_tree, i),
1334 gfc_conv_array_lbound (
1335 last_component_ref_tree, i));
1336 else
1337 {
1338 end = NULL_TREE;
1339 mode_rhs = build_int_cst (unsigned_char_type_node,
1340 GFC_CAF_ARR_REF_OPEN_END);
1341 }
1342 if (ref->u.ar.stride[i])
1343 {
1344 gfc_init_se (&se, NULL);
1345 gfc_conv_expr (&se, ref->u.ar.stride[i]);
1346 gfc_add_block_to_block (block, &se.pre);
1347 stride = gfc_evaluate_now (fold_convert (
1348 gfc_array_index_type,
1349 se.expr),
1350 block);
1351 if (ref_static_array)
1352 {
1353 /* Make the index zero-based, when reffing a static
1354 array. */
1355 stride = fold_build2 (MULT_EXPR,
1356 gfc_array_index_type,
1357 gfc_conv_array_stride (
1358 last_component_ref_tree,
1359 i),
1360 stride);
1361 gcc_assert (end != NULL_TREE);
1362 /* Multiply with the product of array's stride and
1363 the step of the ref to a virtual upper bound.
1364 We can not compute the actual upper bound here or
1365 the caflib would compute the extend
1366 incorrectly. */
1367 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1368 end, gfc_conv_array_stride (
1369 last_component_ref_tree,
1370 i));
1371 end = gfc_evaluate_now (end, block);
1372 stride = gfc_evaluate_now (stride, block);
1373 }
1374 }
1375 else if (ref_static_array)
1376 {
1377 stride = gfc_conv_array_stride (last_component_ref_tree,
1378 i);
1379 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1380 end, stride);
1381 end = gfc_evaluate_now (end, block);
1382 }
1383 else
1384 /* Always set a ref stride of one to make caflib's
1385 handling easier. */
1386 stride = gfc_index_one_node;
1387
1388 /* Fall through. */
1389 case DIMEN_ELEMENT:
1390 if (ref->u.ar.start[i])
1391 {
1392 gfc_init_se (&se, NULL);
1393 gfc_conv_expr (&se, ref->u.ar.start[i]);
1394 gfc_add_block_to_block (block, &se.pre);
1395 if (ref_static_array)
1396 {
1397 /* Make the index zero-based, when reffing a static
1398 array. */
1399 start = fold_convert (gfc_array_index_type, se.expr);
1400 gfc_init_se (&se, NULL);
1401 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1402 gfc_add_block_to_block (block, &se.pre);
1403 se.expr = fold_build2 (MINUS_EXPR,
1404 gfc_array_index_type,
1405 start, fold_convert (
1406 gfc_array_index_type,
1407 se.expr));
1408 /* Multiply with the stride. */
1409 se.expr = fold_build2 (MULT_EXPR,
1410 gfc_array_index_type,
1411 se.expr,
1412 gfc_conv_array_stride (
1413 last_component_ref_tree,
1414 i));
1415 }
1416 start = gfc_evaluate_now (fold_convert (
1417 gfc_array_index_type,
1418 se.expr),
1419 block);
1420 if (mode_rhs == NULL_TREE)
1421 mode_rhs = build_int_cst (unsigned_char_type_node,
1422 ref->u.ar.dimen_type[i]
1423 == DIMEN_ELEMENT
1424 ? GFC_CAF_ARR_REF_SINGLE
1425 : GFC_CAF_ARR_REF_RANGE);
1426 }
1427 else if (ref_static_array)
1428 {
1429 start = integer_zero_node;
1430 mode_rhs = build_int_cst (unsigned_char_type_node,
1431 ref->u.ar.start[i] == NULL
1432 ? GFC_CAF_ARR_REF_FULL
1433 : GFC_CAF_ARR_REF_RANGE);
1434 }
1435 else if (end == NULL_TREE)
1436 mode_rhs = build_int_cst (unsigned_char_type_node,
1437 GFC_CAF_ARR_REF_FULL);
1438 else
1439 mode_rhs = build_int_cst (unsigned_char_type_node,
1440 GFC_CAF_ARR_REF_OPEN_START);
1441
1442 /* Ref the s in dim. */
1443 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1444 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1445 TREE_TYPE (field), dim, field,
1446 NULL_TREE);
1447
1448 /* Set start in s. */
1449 if (start != NULL_TREE)
1450 {
1451 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1452 0);
1453 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1454 TREE_TYPE (field), tmp, field,
1455 NULL_TREE);
1456 gfc_add_modify (block, tmp2,
1457 fold_convert (TREE_TYPE (tmp2), start));
1458 }
1459
1460 /* Set end in s. */
1461 if (end != NULL_TREE)
1462 {
1463 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1464 1);
1465 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1466 TREE_TYPE (field), tmp, field,
1467 NULL_TREE);
1468 gfc_add_modify (block, tmp2,
1469 fold_convert (TREE_TYPE (tmp2), end));
1470 }
1471
1472 /* Set end in s. */
1473 if (stride != NULL_TREE)
1474 {
1475 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1476 2);
1477 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1478 TREE_TYPE (field), tmp, field,
1479 NULL_TREE);
1480 gfc_add_modify (block, tmp2,
1481 fold_convert (TREE_TYPE (tmp2), stride));
1482 }
1483 break;
1484 case DIMEN_VECTOR:
1485 /* TODO: In case of static array. */
1486 gcc_assert (!ref_static_array);
1487 mode_rhs = build_int_cst (unsigned_char_type_node,
1488 GFC_CAF_ARR_REF_VECTOR);
1489 gfc_init_se (&se, NULL);
1490 se.descriptor_only = 1;
1491 gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1492 gfc_add_block_to_block (block, &se.pre);
1493 vector = se.expr;
1494 tmp = gfc_conv_descriptor_lbound_get (vector,
1495 gfc_rank_cst[0]);
1496 tmp2 = gfc_conv_descriptor_ubound_get (vector,
1497 gfc_rank_cst[0]);
1498 nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1499 tmp = gfc_conv_descriptor_stride_get (vector,
1500 gfc_rank_cst[0]);
1501 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1502 TREE_TYPE (nvec), nvec, tmp);
1503 vector = gfc_conv_descriptor_data_get (vector);
1504
1505 /* Ref the v in dim. */
1506 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1507 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1508 TREE_TYPE (field), dim, field,
1509 NULL_TREE);
1510
1511 /* Set vector in v. */
1512 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1513 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1514 TREE_TYPE (field), tmp, field,
1515 NULL_TREE);
1516 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1517 vector));
1518
1519 /* Set nvec in v. */
1520 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1521 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1522 TREE_TYPE (field), tmp, field,
1523 NULL_TREE);
1524 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1525 nvec));
1526
1527 /* Set kind in v. */
1528 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1529 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1530 TREE_TYPE (field), tmp, field,
1531 NULL_TREE);
1532 gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1533 ref->u.ar.start[i]->ts.kind));
1534 break;
1535 default:
1536 gcc_unreachable ();
1537 }
1538 /* Set the mode for dim i. */
1539 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1540 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1541 mode_rhs));
1542 }
1543
1544 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1545 if (i < GFC_MAX_DIMENSIONS)
1546 {
1547 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1548 gfc_add_modify (block, tmp,
1549 build_int_cst (unsigned_char_type_node,
1550 GFC_CAF_ARR_REF_NONE));
1551 }
1552 break;
1553 default:
1554 gcc_unreachable ();
1555 }
1556
1557 /* Set the size of the current type. */
1558 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1559 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1560 prev_caf_ref, field, NULL_TREE);
1561 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1562 TYPE_SIZE_UNIT (last_type)));
1563
1564 ref = ref->next;
1565 }
1566
1567 if (prev_caf_ref != NULL_TREE)
1568 {
1569 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1570 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1571 prev_caf_ref, field, NULL_TREE);
1572 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1573 null_pointer_node));
1574 }
1575 return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1576 : NULL_TREE;
1577 }
1578
1579 /* Get data from a remote coarray. */
1580
1581 static void
gfc_conv_intrinsic_caf_get(gfc_se * se,gfc_expr * expr,tree lhs,tree lhs_kind,tree may_require_tmp,bool may_realloc,symbol_attribute * caf_attr)1582 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1583 tree may_require_tmp, bool may_realloc,
1584 symbol_attribute *caf_attr)
1585 {
1586 gfc_expr *array_expr, *tmp_stat;
1587 gfc_se argse;
1588 tree caf_decl, token, offset, image_index, tmp;
1589 tree res_var, dst_var, type, kind, vec, stat;
1590 tree caf_reference;
1591 symbol_attribute caf_attr_store;
1592
1593 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1594
1595 if (se->ss && se->ss->info->useflags)
1596 {
1597 /* Access the previously obtained result. */
1598 gfc_conv_tmp_array_ref (se);
1599 return;
1600 }
1601
1602 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1603 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1604 type = gfc_typenode_for_spec (&array_expr->ts);
1605
1606 if (caf_attr == NULL)
1607 {
1608 caf_attr_store = gfc_caf_attr (array_expr);
1609 caf_attr = &caf_attr_store;
1610 }
1611
1612 res_var = lhs;
1613 dst_var = lhs;
1614
1615 vec = null_pointer_node;
1616 tmp_stat = gfc_find_stat_co (expr);
1617
1618 if (tmp_stat)
1619 {
1620 gfc_se stat_se;
1621 gfc_init_se (&stat_se, NULL);
1622 gfc_conv_expr_reference (&stat_se, tmp_stat);
1623 stat = stat_se.expr;
1624 gfc_add_block_to_block (&se->pre, &stat_se.pre);
1625 gfc_add_block_to_block (&se->post, &stat_se.post);
1626 }
1627 else
1628 stat = null_pointer_node;
1629
1630 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1631 is reallocatable or the right-hand side has allocatable components. */
1632 if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1633 {
1634 /* Get using caf_get_by_ref. */
1635 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1636
1637 if (caf_reference != NULL_TREE)
1638 {
1639 if (lhs == NULL_TREE)
1640 {
1641 if (array_expr->ts.type == BT_CHARACTER)
1642 gfc_init_se (&argse, NULL);
1643 if (array_expr->rank == 0)
1644 {
1645 symbol_attribute attr;
1646 gfc_clear_attr (&attr);
1647 if (array_expr->ts.type == BT_CHARACTER)
1648 {
1649 res_var = gfc_conv_string_tmp (se,
1650 build_pointer_type (type),
1651 array_expr->ts.u.cl->backend_decl);
1652 argse.string_length = array_expr->ts.u.cl->backend_decl;
1653 }
1654 else
1655 res_var = gfc_create_var (type, "caf_res");
1656 dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1657 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1658 }
1659 else
1660 {
1661 /* Create temporary. */
1662 if (array_expr->ts.type == BT_CHARACTER)
1663 gfc_conv_expr_descriptor (&argse, array_expr);
1664 may_realloc = gfc_trans_create_temp_array (&se->pre,
1665 &se->post,
1666 se->ss, type,
1667 NULL_TREE, false,
1668 false, false,
1669 &array_expr->where)
1670 == NULL_TREE;
1671 res_var = se->ss->info->data.array.descriptor;
1672 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1673 if (may_realloc)
1674 {
1675 tmp = gfc_conv_descriptor_data_get (res_var);
1676 tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1677 NULL_TREE, NULL_TREE,
1678 NULL_TREE, true,
1679 NULL,
1680 GFC_CAF_COARRAY_NOCOARRAY);
1681 gfc_add_expr_to_block (&se->post, tmp);
1682 }
1683 }
1684 }
1685
1686 kind = build_int_cst (integer_type_node, expr->ts.kind);
1687 if (lhs_kind == NULL_TREE)
1688 lhs_kind = kind;
1689
1690 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1691 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1692 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1693 image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1694 caf_decl);
1695 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1696 array_expr);
1697
1698 /* No overlap possible as we have generated a temporary. */
1699 if (lhs == NULL_TREE)
1700 may_require_tmp = boolean_false_node;
1701
1702 /* It guarantees memory consistency within the same segment. */
1703 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1704 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1705 gfc_build_string_const (1, ""), NULL_TREE,
1706 NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1707 NULL_TREE);
1708 ASM_VOLATILE_P (tmp) = 1;
1709 gfc_add_expr_to_block (&se->pre, tmp);
1710
1711 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1712 10, token, image_index, dst_var,
1713 caf_reference, lhs_kind, kind,
1714 may_require_tmp,
1715 may_realloc ? boolean_true_node :
1716 boolean_false_node,
1717 stat, build_int_cst (integer_type_node,
1718 array_expr->ts.type));
1719
1720 gfc_add_expr_to_block (&se->pre, tmp);
1721
1722 if (se->ss)
1723 gfc_advance_se_ss_chain (se);
1724
1725 se->expr = res_var;
1726 if (array_expr->ts.type == BT_CHARACTER)
1727 se->string_length = argse.string_length;
1728
1729 return;
1730 }
1731 }
1732
1733 gfc_init_se (&argse, NULL);
1734 if (array_expr->rank == 0)
1735 {
1736 symbol_attribute attr;
1737
1738 gfc_clear_attr (&attr);
1739 gfc_conv_expr (&argse, array_expr);
1740
1741 if (lhs == NULL_TREE)
1742 {
1743 gfc_clear_attr (&attr);
1744 if (array_expr->ts.type == BT_CHARACTER)
1745 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1746 argse.string_length);
1747 else
1748 res_var = gfc_create_var (type, "caf_res");
1749 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1750 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1751 }
1752 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1753 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1754 }
1755 else
1756 {
1757 /* If has_vector, pass descriptor for whole array and the
1758 vector bounds separately. */
1759 gfc_array_ref *ar, ar2;
1760 bool has_vector = false;
1761
1762 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1763 {
1764 has_vector = true;
1765 ar = gfc_find_array_ref (expr);
1766 ar2 = *ar;
1767 memset (ar, '\0', sizeof (*ar));
1768 ar->as = ar2.as;
1769 ar->type = AR_FULL;
1770 }
1771 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1772 gfc_conv_expr_descriptor (&argse, array_expr);
1773 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1774 has the wrong type if component references are done. */
1775 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1776 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1777 : array_expr->rank,
1778 type));
1779 if (has_vector)
1780 {
1781 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1782 *ar = ar2;
1783 }
1784
1785 if (lhs == NULL_TREE)
1786 {
1787 /* Create temporary. */
1788 for (int n = 0; n < se->ss->loop->dimen; n++)
1789 if (se->loop->to[n] == NULL_TREE)
1790 {
1791 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1792 gfc_rank_cst[n]);
1793 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1794 gfc_rank_cst[n]);
1795 }
1796 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1797 NULL_TREE, false, true, false,
1798 &array_expr->where);
1799 res_var = se->ss->info->data.array.descriptor;
1800 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1801 }
1802 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1803 }
1804
1805 kind = build_int_cst (integer_type_node, expr->ts.kind);
1806 if (lhs_kind == NULL_TREE)
1807 lhs_kind = kind;
1808
1809 gfc_add_block_to_block (&se->pre, &argse.pre);
1810 gfc_add_block_to_block (&se->post, &argse.post);
1811
1812 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1813 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1814 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1815 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1816 gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1817 array_expr);
1818
1819 /* No overlap possible as we have generated a temporary. */
1820 if (lhs == NULL_TREE)
1821 may_require_tmp = boolean_false_node;
1822
1823 /* It guarantees memory consistency within the same segment. */
1824 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1825 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1826 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1827 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1828 ASM_VOLATILE_P (tmp) = 1;
1829 gfc_add_expr_to_block (&se->pre, tmp);
1830
1831 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1832 token, offset, image_index, argse.expr, vec,
1833 dst_var, kind, lhs_kind, may_require_tmp, stat);
1834
1835 gfc_add_expr_to_block (&se->pre, tmp);
1836
1837 if (se->ss)
1838 gfc_advance_se_ss_chain (se);
1839
1840 se->expr = res_var;
1841 if (array_expr->ts.type == BT_CHARACTER)
1842 se->string_length = argse.string_length;
1843 }
1844
1845
1846 /* Send data to a remote coarray. */
1847
1848 static tree
conv_caf_send(gfc_code * code)1849 conv_caf_send (gfc_code *code) {
1850 gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1851 gfc_se lhs_se, rhs_se;
1852 stmtblock_t block;
1853 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1854 tree may_require_tmp, src_stat, dst_stat, dst_team;
1855 tree lhs_type = NULL_TREE;
1856 tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1857 symbol_attribute lhs_caf_attr, rhs_caf_attr;
1858
1859 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1860
1861 lhs_expr = code->ext.actual->expr;
1862 rhs_expr = code->ext.actual->next->expr;
1863 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1864 ? boolean_false_node : boolean_true_node;
1865 gfc_init_block (&block);
1866
1867 lhs_caf_attr = gfc_caf_attr (lhs_expr);
1868 rhs_caf_attr = gfc_caf_attr (rhs_expr);
1869 src_stat = dst_stat = null_pointer_node;
1870 dst_team = null_pointer_node;
1871
1872 /* LHS. */
1873 gfc_init_se (&lhs_se, NULL);
1874 if (lhs_expr->rank == 0)
1875 {
1876 if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1877 {
1878 lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1879 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1880 }
1881 else
1882 {
1883 symbol_attribute attr;
1884 gfc_clear_attr (&attr);
1885 gfc_conv_expr (&lhs_se, lhs_expr);
1886 lhs_type = TREE_TYPE (lhs_se.expr);
1887 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1888 attr);
1889 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1890 }
1891 }
1892 else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1893 && lhs_caf_attr.codimension)
1894 {
1895 lhs_se.want_pointer = 1;
1896 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1897 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1898 has the wrong type if component references are done. */
1899 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1900 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1901 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1902 gfc_get_dtype_rank_type (
1903 gfc_has_vector_subscript (lhs_expr)
1904 ? gfc_find_array_ref (lhs_expr)->dimen
1905 : lhs_expr->rank,
1906 lhs_type));
1907 }
1908 else
1909 {
1910 bool has_vector = gfc_has_vector_subscript (lhs_expr);
1911
1912 if (gfc_is_coindexed (lhs_expr) || !has_vector)
1913 {
1914 /* If has_vector, pass descriptor for whole array and the
1915 vector bounds separately. */
1916 gfc_array_ref *ar, ar2;
1917 bool has_tmp_lhs_array = false;
1918 if (has_vector)
1919 {
1920 has_tmp_lhs_array = true;
1921 ar = gfc_find_array_ref (lhs_expr);
1922 ar2 = *ar;
1923 memset (ar, '\0', sizeof (*ar));
1924 ar->as = ar2.as;
1925 ar->type = AR_FULL;
1926 }
1927 lhs_se.want_pointer = 1;
1928 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1929 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
1930 that has the wrong type if component references are done. */
1931 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1932 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1933 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1934 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1935 : lhs_expr->rank,
1936 lhs_type));
1937 if (has_tmp_lhs_array)
1938 {
1939 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
1940 *ar = ar2;
1941 }
1942 }
1943 else
1944 {
1945 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
1946 indexed array expression. This is rewritten to:
1947
1948 tmp_array = arr2[...]
1949 arr1 ([...]) = tmp_array
1950
1951 because using the standard gfc_conv_expr (lhs_expr) did the
1952 assignment with lhs and rhs exchanged. */
1953
1954 gfc_ss *lss_for_tmparray, *lss_real;
1955 gfc_loopinfo loop;
1956 gfc_se se;
1957 stmtblock_t body;
1958 tree tmparr_desc, src;
1959 tree index = gfc_index_zero_node;
1960 tree stride = gfc_index_zero_node;
1961 int n;
1962
1963 /* Walk both sides of the assignment, once to get the shape of the
1964 temporary array to create right. */
1965 lss_for_tmparray = gfc_walk_expr (lhs_expr);
1966 /* And a second time to be able to create an assignment of the
1967 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
1968 the tree in the descriptor with the one for the temporary
1969 array. */
1970 lss_real = gfc_walk_expr (lhs_expr);
1971 gfc_init_loopinfo (&loop);
1972 gfc_add_ss_to_loop (&loop, lss_for_tmparray);
1973 gfc_add_ss_to_loop (&loop, lss_real);
1974 gfc_conv_ss_startstride (&loop);
1975 gfc_conv_loop_setup (&loop, &lhs_expr->where);
1976 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1977 gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
1978 lss_for_tmparray, lhs_type, NULL_TREE,
1979 false, true, false,
1980 &lhs_expr->where);
1981 tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
1982 gfc_start_scalarized_body (&loop, &body);
1983 gfc_init_se (&se, NULL);
1984 gfc_copy_loopinfo_to_se (&se, &loop);
1985 se.ss = lss_real;
1986 gfc_conv_expr (&se, lhs_expr);
1987 gfc_add_block_to_block (&body, &se.pre);
1988
1989 /* Walk over all indexes of the loop. */
1990 for (n = loop.dimen - 1; n > 0; --n)
1991 {
1992 tmp = loop.loopvar[n];
1993 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1994 gfc_array_index_type, tmp, loop.from[n]);
1995 tmp = fold_build2_loc (input_location, PLUS_EXPR,
1996 gfc_array_index_type, tmp, index);
1997
1998 stride = fold_build2_loc (input_location, MINUS_EXPR,
1999 gfc_array_index_type,
2000 loop.to[n - 1], loop.from[n - 1]);
2001 stride = fold_build2_loc (input_location, PLUS_EXPR,
2002 gfc_array_index_type,
2003 stride, gfc_index_one_node);
2004
2005 index = fold_build2_loc (input_location, MULT_EXPR,
2006 gfc_array_index_type, tmp, stride);
2007 }
2008
2009 index = fold_build2_loc (input_location, MINUS_EXPR,
2010 gfc_array_index_type,
2011 index, loop.from[0]);
2012
2013 index = fold_build2_loc (input_location, PLUS_EXPR,
2014 gfc_array_index_type,
2015 loop.loopvar[0], index);
2016
2017 src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
2018 src = gfc_build_array_ref (src, index, NULL);
2019 /* Now create the assignment of lhs_expr = tmp_array. */
2020 gfc_add_modify (&body, se.expr, src);
2021 gfc_add_block_to_block (&body, &se.post);
2022 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
2023 gfc_trans_scalarizing_loops (&loop, &body);
2024 gfc_add_block_to_block (&loop.pre, &loop.post);
2025 gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2026 gfc_free_ss (lss_for_tmparray);
2027 gfc_free_ss (lss_real);
2028 }
2029 }
2030
2031 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
2032
2033 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2034 temporary and a loop. */
2035 if (!gfc_is_coindexed (lhs_expr)
2036 && (!lhs_caf_attr.codimension
2037 || !(lhs_expr->rank > 0
2038 && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2039 {
2040 bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2041 gcc_assert (gfc_is_coindexed (rhs_expr));
2042 gfc_init_se (&rhs_se, NULL);
2043 if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2044 {
2045 gfc_se scal_se;
2046 gfc_init_se (&scal_se, NULL);
2047 scal_se.want_pointer = 1;
2048 gfc_conv_expr (&scal_se, lhs_expr);
2049 /* Ensure scalar on lhs is allocated. */
2050 gfc_add_block_to_block (&block, &scal_se.pre);
2051
2052 gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2053 TYPE_SIZE_UNIT (
2054 gfc_typenode_for_spec (&lhs_expr->ts)),
2055 NULL_TREE);
2056 tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
2057 null_pointer_node);
2058 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2059 tmp, gfc_finish_block (&scal_se.pre),
2060 build_empty_stmt (input_location));
2061 gfc_add_expr_to_block (&block, tmp);
2062 }
2063 else
2064 lhs_may_realloc = lhs_may_realloc
2065 && gfc_full_array_ref_p (lhs_expr->ref, NULL);
2066 gfc_add_block_to_block (&block, &lhs_se.pre);
2067 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
2068 may_require_tmp, lhs_may_realloc,
2069 &rhs_caf_attr);
2070 gfc_add_block_to_block (&block, &rhs_se.pre);
2071 gfc_add_block_to_block (&block, &rhs_se.post);
2072 gfc_add_block_to_block (&block, &lhs_se.post);
2073 return gfc_finish_block (&block);
2074 }
2075
2076 gfc_add_block_to_block (&block, &lhs_se.pre);
2077
2078 /* Obtain token, offset and image index for the LHS. */
2079 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2080 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2081 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2082 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2083 tmp = lhs_se.expr;
2084 if (lhs_caf_attr.alloc_comp)
2085 gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
2086 NULL);
2087 else
2088 gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2089 lhs_expr);
2090 lhs_se.expr = tmp;
2091
2092 /* RHS. */
2093 gfc_init_se (&rhs_se, NULL);
2094 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2095 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2096 rhs_expr = rhs_expr->value.function.actual->expr;
2097 if (rhs_expr->rank == 0)
2098 {
2099 symbol_attribute attr;
2100 gfc_clear_attr (&attr);
2101 gfc_conv_expr (&rhs_se, rhs_expr);
2102 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2103 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2104 }
2105 else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2106 && rhs_caf_attr.codimension)
2107 {
2108 tree tmp2;
2109 rhs_se.want_pointer = 1;
2110 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2111 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2112 has the wrong type if component references are done. */
2113 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2114 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2115 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2116 gfc_get_dtype_rank_type (
2117 gfc_has_vector_subscript (rhs_expr)
2118 ? gfc_find_array_ref (rhs_expr)->dimen
2119 : rhs_expr->rank,
2120 tmp2));
2121 }
2122 else
2123 {
2124 /* If has_vector, pass descriptor for whole array and the
2125 vector bounds separately. */
2126 gfc_array_ref *ar, ar2;
2127 bool has_vector = false;
2128 tree tmp2;
2129
2130 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2131 {
2132 has_vector = true;
2133 ar = gfc_find_array_ref (rhs_expr);
2134 ar2 = *ar;
2135 memset (ar, '\0', sizeof (*ar));
2136 ar->as = ar2.as;
2137 ar->type = AR_FULL;
2138 }
2139 rhs_se.want_pointer = 1;
2140 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2141 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2142 has the wrong type if component references are done. */
2143 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2144 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2145 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2146 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2147 : rhs_expr->rank,
2148 tmp2));
2149 if (has_vector)
2150 {
2151 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2152 *ar = ar2;
2153 }
2154 }
2155
2156 gfc_add_block_to_block (&block, &rhs_se.pre);
2157
2158 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2159
2160 tmp_stat = gfc_find_stat_co (lhs_expr);
2161
2162 if (tmp_stat)
2163 {
2164 gfc_se stat_se;
2165 gfc_init_se (&stat_se, NULL);
2166 gfc_conv_expr_reference (&stat_se, tmp_stat);
2167 dst_stat = stat_se.expr;
2168 gfc_add_block_to_block (&block, &stat_se.pre);
2169 gfc_add_block_to_block (&block, &stat_se.post);
2170 }
2171
2172 tmp_team = gfc_find_team_co (lhs_expr);
2173
2174 if (tmp_team)
2175 {
2176 gfc_se team_se;
2177 gfc_init_se (&team_se, NULL);
2178 gfc_conv_expr_reference (&team_se, tmp_team);
2179 dst_team = team_se.expr;
2180 gfc_add_block_to_block (&block, &team_se.pre);
2181 gfc_add_block_to_block (&block, &team_se.post);
2182 }
2183
2184 if (!gfc_is_coindexed (rhs_expr))
2185 {
2186 if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2187 {
2188 tree reference, dst_realloc;
2189 reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2190 dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2191 : boolean_false_node;
2192 tmp = build_call_expr_loc (input_location,
2193 gfor_fndecl_caf_send_by_ref,
2194 10, token, image_index, rhs_se.expr,
2195 reference, lhs_kind, rhs_kind,
2196 may_require_tmp, dst_realloc, src_stat,
2197 build_int_cst (integer_type_node,
2198 lhs_expr->ts.type));
2199 }
2200 else
2201 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2202 token, offset, image_index, lhs_se.expr, vec,
2203 rhs_se.expr, lhs_kind, rhs_kind,
2204 may_require_tmp, src_stat, dst_team);
2205 }
2206 else
2207 {
2208 tree rhs_token, rhs_offset, rhs_image_index;
2209
2210 /* It guarantees memory consistency within the same segment. */
2211 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2212 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2213 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2214 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2215 ASM_VOLATILE_P (tmp) = 1;
2216 gfc_add_expr_to_block (&block, tmp);
2217
2218 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2219 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2220 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2221 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2222 tmp = rhs_se.expr;
2223 if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2224 {
2225 tmp_stat = gfc_find_stat_co (lhs_expr);
2226
2227 if (tmp_stat)
2228 {
2229 gfc_se stat_se;
2230 gfc_init_se (&stat_se, NULL);
2231 gfc_conv_expr_reference (&stat_se, tmp_stat);
2232 src_stat = stat_se.expr;
2233 gfc_add_block_to_block (&block, &stat_se.pre);
2234 gfc_add_block_to_block (&block, &stat_se.post);
2235 }
2236
2237 gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2238 NULL_TREE, NULL);
2239 tree lhs_reference, rhs_reference;
2240 lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2241 rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2242 tmp = build_call_expr_loc (input_location,
2243 gfor_fndecl_caf_sendget_by_ref, 13,
2244 token, image_index, lhs_reference,
2245 rhs_token, rhs_image_index, rhs_reference,
2246 lhs_kind, rhs_kind, may_require_tmp,
2247 dst_stat, src_stat,
2248 build_int_cst (integer_type_node,
2249 lhs_expr->ts.type),
2250 build_int_cst (integer_type_node,
2251 rhs_expr->ts.type));
2252 }
2253 else
2254 {
2255 gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2256 tmp, rhs_expr);
2257 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2258 14, token, offset, image_index,
2259 lhs_se.expr, vec, rhs_token, rhs_offset,
2260 rhs_image_index, tmp, rhs_vec, lhs_kind,
2261 rhs_kind, may_require_tmp, src_stat);
2262 }
2263 }
2264 gfc_add_expr_to_block (&block, tmp);
2265 gfc_add_block_to_block (&block, &lhs_se.post);
2266 gfc_add_block_to_block (&block, &rhs_se.post);
2267
2268 /* It guarantees memory consistency within the same segment. */
2269 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2270 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2271 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2272 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2273 ASM_VOLATILE_P (tmp) = 1;
2274 gfc_add_expr_to_block (&block, tmp);
2275
2276 return gfc_finish_block (&block);
2277 }
2278
2279
2280 static void
trans_this_image(gfc_se * se,gfc_expr * expr)2281 trans_this_image (gfc_se * se, gfc_expr *expr)
2282 {
2283 stmtblock_t loop;
2284 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2285 lbound, ubound, extent, ml;
2286 gfc_se argse;
2287 int rank, corank;
2288 gfc_expr *distance = expr->value.function.actual->next->next->expr;
2289
2290 if (expr->value.function.actual->expr
2291 && !gfc_is_coarray (expr->value.function.actual->expr))
2292 distance = expr->value.function.actual->expr;
2293
2294 /* The case -fcoarray=single is handled elsewhere. */
2295 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2296
2297 /* Argument-free version: THIS_IMAGE(). */
2298 if (distance || expr->value.function.actual->expr == NULL)
2299 {
2300 if (distance)
2301 {
2302 gfc_init_se (&argse, NULL);
2303 gfc_conv_expr_val (&argse, distance);
2304 gfc_add_block_to_block (&se->pre, &argse.pre);
2305 gfc_add_block_to_block (&se->post, &argse.post);
2306 tmp = fold_convert (integer_type_node, argse.expr);
2307 }
2308 else
2309 tmp = integer_zero_node;
2310 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2311 tmp);
2312 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2313 tmp);
2314 return;
2315 }
2316
2317 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2318
2319 type = gfc_get_int_type (gfc_default_integer_kind);
2320 corank = gfc_get_corank (expr->value.function.actual->expr);
2321 rank = expr->value.function.actual->expr->rank;
2322
2323 /* Obtain the descriptor of the COARRAY. */
2324 gfc_init_se (&argse, NULL);
2325 argse.want_coarray = 1;
2326 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2327 gfc_add_block_to_block (&se->pre, &argse.pre);
2328 gfc_add_block_to_block (&se->post, &argse.post);
2329 desc = argse.expr;
2330
2331 if (se->ss)
2332 {
2333 /* Create an implicit second parameter from the loop variable. */
2334 gcc_assert (!expr->value.function.actual->next->expr);
2335 gcc_assert (corank > 0);
2336 gcc_assert (se->loop->dimen == 1);
2337 gcc_assert (se->ss->info->expr == expr);
2338
2339 dim_arg = se->loop->loopvar[0];
2340 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2341 gfc_array_index_type, dim_arg,
2342 build_int_cst (TREE_TYPE (dim_arg), 1));
2343 gfc_advance_se_ss_chain (se);
2344 }
2345 else
2346 {
2347 /* Use the passed DIM= argument. */
2348 gcc_assert (expr->value.function.actual->next->expr);
2349 gfc_init_se (&argse, NULL);
2350 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2351 gfc_array_index_type);
2352 gfc_add_block_to_block (&se->pre, &argse.pre);
2353 dim_arg = argse.expr;
2354
2355 if (INTEGER_CST_P (dim_arg))
2356 {
2357 if (wi::ltu_p (wi::to_wide (dim_arg), 1)
2358 || wi::gtu_p (wi::to_wide (dim_arg),
2359 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2360 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2361 "dimension index", expr->value.function.isym->name,
2362 &expr->where);
2363 }
2364 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2365 {
2366 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2367 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2368 dim_arg,
2369 build_int_cst (TREE_TYPE (dim_arg), 1));
2370 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2371 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2372 dim_arg, tmp);
2373 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2374 logical_type_node, cond, tmp);
2375 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2376 gfc_msg_fault);
2377 }
2378 }
2379
2380 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2381 one always has a dim_arg argument.
2382
2383 m = this_image() - 1
2384 if (corank == 1)
2385 {
2386 sub(1) = m + lcobound(corank)
2387 return;
2388 }
2389 i = rank
2390 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2391 for (;;)
2392 {
2393 extent = gfc_extent(i)
2394 ml = m
2395 m = m/extent
2396 if (i >= min_var)
2397 goto exit_label
2398 i++
2399 }
2400 exit_label:
2401 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2402 : m + lcobound(corank)
2403 */
2404
2405 /* this_image () - 1. */
2406 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2407 integer_zero_node);
2408 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2409 fold_convert (type, tmp), build_int_cst (type, 1));
2410 if (corank == 1)
2411 {
2412 /* sub(1) = m + lcobound(corank). */
2413 lbound = gfc_conv_descriptor_lbound_get (desc,
2414 build_int_cst (TREE_TYPE (gfc_array_index_type),
2415 corank+rank-1));
2416 lbound = fold_convert (type, lbound);
2417 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2418
2419 se->expr = tmp;
2420 return;
2421 }
2422
2423 m = gfc_create_var (type, NULL);
2424 ml = gfc_create_var (type, NULL);
2425 loop_var = gfc_create_var (integer_type_node, NULL);
2426 min_var = gfc_create_var (integer_type_node, NULL);
2427
2428 /* m = this_image () - 1. */
2429 gfc_add_modify (&se->pre, m, tmp);
2430
2431 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2432 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2433 fold_convert (integer_type_node, dim_arg),
2434 build_int_cst (integer_type_node, rank - 1));
2435 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2436 build_int_cst (integer_type_node, rank + corank - 2),
2437 tmp);
2438 gfc_add_modify (&se->pre, min_var, tmp);
2439
2440 /* i = rank. */
2441 tmp = build_int_cst (integer_type_node, rank);
2442 gfc_add_modify (&se->pre, loop_var, tmp);
2443
2444 exit_label = gfc_build_label_decl (NULL_TREE);
2445 TREE_USED (exit_label) = 1;
2446
2447 /* Loop body. */
2448 gfc_init_block (&loop);
2449
2450 /* ml = m. */
2451 gfc_add_modify (&loop, ml, m);
2452
2453 /* extent = ... */
2454 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2455 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2456 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2457 extent = fold_convert (type, extent);
2458
2459 /* m = m/extent. */
2460 gfc_add_modify (&loop, m,
2461 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2462 m, extent));
2463
2464 /* Exit condition: if (i >= min_var) goto exit_label. */
2465 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2466 min_var);
2467 tmp = build1_v (GOTO_EXPR, exit_label);
2468 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2469 build_empty_stmt (input_location));
2470 gfc_add_expr_to_block (&loop, tmp);
2471
2472 /* Increment loop variable: i++. */
2473 gfc_add_modify (&loop, loop_var,
2474 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2475 loop_var,
2476 build_int_cst (integer_type_node, 1)));
2477
2478 /* Making the loop... actually loop! */
2479 tmp = gfc_finish_block (&loop);
2480 tmp = build1_v (LOOP_EXPR, tmp);
2481 gfc_add_expr_to_block (&se->pre, tmp);
2482
2483 /* The exit label. */
2484 tmp = build1_v (LABEL_EXPR, exit_label);
2485 gfc_add_expr_to_block (&se->pre, tmp);
2486
2487 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2488 : m + lcobound(corank) */
2489
2490 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2491 build_int_cst (TREE_TYPE (dim_arg), corank));
2492
2493 lbound = gfc_conv_descriptor_lbound_get (desc,
2494 fold_build2_loc (input_location, PLUS_EXPR,
2495 gfc_array_index_type, dim_arg,
2496 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2497 lbound = fold_convert (type, lbound);
2498
2499 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2500 fold_build2_loc (input_location, MULT_EXPR, type,
2501 m, extent));
2502 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2503
2504 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2505 fold_build2_loc (input_location, PLUS_EXPR, type,
2506 m, lbound));
2507 }
2508
2509
2510 /* Convert a call to image_status. */
2511
2512 static void
conv_intrinsic_image_status(gfc_se * se,gfc_expr * expr)2513 conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2514 {
2515 unsigned int num_args;
2516 tree *args, tmp;
2517
2518 num_args = gfc_intrinsic_argument_list_length (expr);
2519 args = XALLOCAVEC (tree, num_args);
2520 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2521 /* In args[0] the number of the image the status is desired for has to be
2522 given. */
2523
2524 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2525 {
2526 tree arg;
2527 arg = gfc_evaluate_now (args[0], &se->pre);
2528 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2529 fold_convert (integer_type_node, arg),
2530 integer_one_node);
2531 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2532 tmp, integer_zero_node,
2533 build_int_cst (integer_type_node,
2534 GFC_STAT_STOPPED_IMAGE));
2535 }
2536 else if (flag_coarray == GFC_FCOARRAY_LIB)
2537 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2538 args[0], build_int_cst (integer_type_node, -1));
2539 else
2540 gcc_unreachable ();
2541
2542 se->expr = tmp;
2543 }
2544
2545 static void
conv_intrinsic_team_number(gfc_se * se,gfc_expr * expr)2546 conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2547 {
2548 unsigned int num_args;
2549
2550 tree *args, tmp;
2551
2552 num_args = gfc_intrinsic_argument_list_length (expr);
2553 args = XALLOCAVEC (tree, num_args);
2554 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2555
2556 if (flag_coarray ==
2557 GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2558 {
2559 tree arg;
2560
2561 arg = gfc_evaluate_now (args[0], &se->pre);
2562 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2563 fold_convert (integer_type_node, arg),
2564 integer_one_node);
2565 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2566 tmp, integer_zero_node,
2567 build_int_cst (integer_type_node,
2568 GFC_STAT_STOPPED_IMAGE));
2569 }
2570 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2571 {
2572 // the value -1 represents that no team has been created yet
2573 tmp = build_int_cst (integer_type_node, -1);
2574 }
2575 else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2576 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2577 args[0], build_int_cst (integer_type_node, -1));
2578 else if (flag_coarray == GFC_FCOARRAY_LIB)
2579 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2580 integer_zero_node, build_int_cst (integer_type_node, -1));
2581 else
2582 gcc_unreachable ();
2583
2584 se->expr = tmp;
2585 }
2586
2587
2588 static void
trans_image_index(gfc_se * se,gfc_expr * expr)2589 trans_image_index (gfc_se * se, gfc_expr *expr)
2590 {
2591 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2592 tmp, invalid_bound;
2593 gfc_se argse, subse;
2594 int rank, corank, codim;
2595
2596 type = gfc_get_int_type (gfc_default_integer_kind);
2597 corank = gfc_get_corank (expr->value.function.actual->expr);
2598 rank = expr->value.function.actual->expr->rank;
2599
2600 /* Obtain the descriptor of the COARRAY. */
2601 gfc_init_se (&argse, NULL);
2602 argse.want_coarray = 1;
2603 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2604 gfc_add_block_to_block (&se->pre, &argse.pre);
2605 gfc_add_block_to_block (&se->post, &argse.post);
2606 desc = argse.expr;
2607
2608 /* Obtain a handle to the SUB argument. */
2609 gfc_init_se (&subse, NULL);
2610 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2611 gfc_add_block_to_block (&se->pre, &subse.pre);
2612 gfc_add_block_to_block (&se->post, &subse.post);
2613 subdesc = build_fold_indirect_ref_loc (input_location,
2614 gfc_conv_descriptor_data_get (subse.expr));
2615
2616 /* Fortran 2008 does not require that the values remain in the cobounds,
2617 thus we need explicitly check this - and return 0 if they are exceeded. */
2618
2619 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2620 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2621 invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2622 fold_convert (gfc_array_index_type, tmp),
2623 lbound);
2624
2625 for (codim = corank + rank - 2; codim >= rank; codim--)
2626 {
2627 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2628 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2629 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2630 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2631 fold_convert (gfc_array_index_type, tmp),
2632 lbound);
2633 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2634 logical_type_node, invalid_bound, cond);
2635 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2636 fold_convert (gfc_array_index_type, tmp),
2637 ubound);
2638 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2639 logical_type_node, invalid_bound, cond);
2640 }
2641
2642 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2643
2644 /* See Fortran 2008, C.10 for the following algorithm. */
2645
2646 /* coindex = sub(corank) - lcobound(n). */
2647 coindex = fold_convert (gfc_array_index_type,
2648 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2649 NULL));
2650 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2651 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2652 fold_convert (gfc_array_index_type, coindex),
2653 lbound);
2654
2655 for (codim = corank + rank - 2; codim >= rank; codim--)
2656 {
2657 tree extent, ubound;
2658
2659 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2660 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2661 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2662 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2663
2664 /* coindex *= extent. */
2665 coindex = fold_build2_loc (input_location, MULT_EXPR,
2666 gfc_array_index_type, coindex, extent);
2667
2668 /* coindex += sub(codim). */
2669 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2670 coindex = fold_build2_loc (input_location, PLUS_EXPR,
2671 gfc_array_index_type, coindex,
2672 fold_convert (gfc_array_index_type, tmp));
2673
2674 /* coindex -= lbound(codim). */
2675 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2676 coindex = fold_build2_loc (input_location, MINUS_EXPR,
2677 gfc_array_index_type, coindex, lbound);
2678 }
2679
2680 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2681 fold_convert(type, coindex),
2682 build_int_cst (type, 1));
2683
2684 /* Return 0 if "coindex" exceeds num_images(). */
2685
2686 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2687 num_images = build_int_cst (type, 1);
2688 else
2689 {
2690 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2691 integer_zero_node,
2692 build_int_cst (integer_type_node, -1));
2693 num_images = fold_convert (type, tmp);
2694 }
2695
2696 tmp = gfc_create_var (type, NULL);
2697 gfc_add_modify (&se->pre, tmp, coindex);
2698
2699 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2700 num_images);
2701 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2702 cond,
2703 fold_convert (logical_type_node, invalid_bound));
2704 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2705 build_int_cst (type, 0), tmp);
2706 }
2707
2708 static void
trans_num_images(gfc_se * se,gfc_expr * expr)2709 trans_num_images (gfc_se * se, gfc_expr *expr)
2710 {
2711 tree tmp, distance, failed;
2712 gfc_se argse;
2713
2714 if (expr->value.function.actual->expr)
2715 {
2716 gfc_init_se (&argse, NULL);
2717 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2718 gfc_add_block_to_block (&se->pre, &argse.pre);
2719 gfc_add_block_to_block (&se->post, &argse.post);
2720 distance = fold_convert (integer_type_node, argse.expr);
2721 }
2722 else
2723 distance = integer_zero_node;
2724
2725 if (expr->value.function.actual->next->expr)
2726 {
2727 gfc_init_se (&argse, NULL);
2728 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2729 gfc_add_block_to_block (&se->pre, &argse.pre);
2730 gfc_add_block_to_block (&se->post, &argse.post);
2731 failed = fold_convert (integer_type_node, argse.expr);
2732 }
2733 else
2734 failed = build_int_cst (integer_type_node, -1);
2735 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2736 distance, failed);
2737 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2738 }
2739
2740
2741 static void
gfc_conv_intrinsic_rank(gfc_se * se,gfc_expr * expr)2742 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2743 {
2744 gfc_se argse;
2745
2746 gfc_init_se (&argse, NULL);
2747 argse.data_not_needed = 1;
2748 argse.descriptor_only = 1;
2749
2750 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2751 gfc_add_block_to_block (&se->pre, &argse.pre);
2752 gfc_add_block_to_block (&se->post, &argse.post);
2753
2754 se->expr = gfc_conv_descriptor_rank (argse.expr);
2755 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2756 se->expr);
2757 }
2758
2759
2760 /* Evaluate a single upper or lower bound. */
2761 /* TODO: bound intrinsic generates way too much unnecessary code. */
2762
2763 static void
gfc_conv_intrinsic_bound(gfc_se * se,gfc_expr * expr,int upper)2764 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2765 {
2766 gfc_actual_arglist *arg;
2767 gfc_actual_arglist *arg2;
2768 tree desc;
2769 tree type;
2770 tree bound;
2771 tree tmp;
2772 tree cond, cond1, cond3, cond4, size;
2773 tree ubound;
2774 tree lbound;
2775 gfc_se argse;
2776 gfc_array_spec * as;
2777 bool assumed_rank_lb_one;
2778
2779 arg = expr->value.function.actual;
2780 arg2 = arg->next;
2781
2782 if (se->ss)
2783 {
2784 /* Create an implicit second parameter from the loop variable. */
2785 gcc_assert (!arg2->expr);
2786 gcc_assert (se->loop->dimen == 1);
2787 gcc_assert (se->ss->info->expr == expr);
2788 gfc_advance_se_ss_chain (se);
2789 bound = se->loop->loopvar[0];
2790 bound = fold_build2_loc (input_location, MINUS_EXPR,
2791 gfc_array_index_type, bound,
2792 se->loop->from[0]);
2793 }
2794 else
2795 {
2796 /* use the passed argument. */
2797 gcc_assert (arg2->expr);
2798 gfc_init_se (&argse, NULL);
2799 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2800 gfc_add_block_to_block (&se->pre, &argse.pre);
2801 bound = argse.expr;
2802 /* Convert from one based to zero based. */
2803 bound = fold_build2_loc (input_location, MINUS_EXPR,
2804 gfc_array_index_type, bound,
2805 gfc_index_one_node);
2806 }
2807
2808 /* TODO: don't re-evaluate the descriptor on each iteration. */
2809 /* Get a descriptor for the first parameter. */
2810 gfc_init_se (&argse, NULL);
2811 gfc_conv_expr_descriptor (&argse, arg->expr);
2812 gfc_add_block_to_block (&se->pre, &argse.pre);
2813 gfc_add_block_to_block (&se->post, &argse.post);
2814
2815 desc = argse.expr;
2816
2817 as = gfc_get_full_arrayspec_from_expr (arg->expr);
2818
2819 if (INTEGER_CST_P (bound))
2820 {
2821 if (((!as || as->type != AS_ASSUMED_RANK)
2822 && wi::geu_p (wi::to_wide (bound),
2823 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2824 || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2825 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2826 "dimension index", upper ? "UBOUND" : "LBOUND",
2827 &expr->where);
2828 }
2829
2830 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2831 {
2832 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2833 {
2834 bound = gfc_evaluate_now (bound, &se->pre);
2835 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2836 bound, build_int_cst (TREE_TYPE (bound), 0));
2837 if (as && as->type == AS_ASSUMED_RANK)
2838 tmp = gfc_conv_descriptor_rank (desc);
2839 else
2840 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2841 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2842 bound, fold_convert(TREE_TYPE (bound), tmp));
2843 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2844 logical_type_node, cond, tmp);
2845 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2846 gfc_msg_fault);
2847 }
2848 }
2849
2850 /* Take care of the lbound shift for assumed-rank arrays, which are
2851 nonallocatable and nonpointers. Those has a lbound of 1. */
2852 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2853 && ((arg->expr->ts.type != BT_CLASS
2854 && !arg->expr->symtree->n.sym->attr.allocatable
2855 && !arg->expr->symtree->n.sym->attr.pointer)
2856 || (arg->expr->ts.type == BT_CLASS
2857 && !CLASS_DATA (arg->expr)->attr.allocatable
2858 && !CLASS_DATA (arg->expr)->attr.class_pointer));
2859
2860 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2861 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2862
2863 /* 13.14.53: Result value for LBOUND
2864
2865 Case (i): For an array section or for an array expression other than a
2866 whole array or array structure component, LBOUND(ARRAY, DIM)
2867 has the value 1. For a whole array or array structure
2868 component, LBOUND(ARRAY, DIM) has the value:
2869 (a) equal to the lower bound for subscript DIM of ARRAY if
2870 dimension DIM of ARRAY does not have extent zero
2871 or if ARRAY is an assumed-size array of rank DIM,
2872 or (b) 1 otherwise.
2873
2874 13.14.113: Result value for UBOUND
2875
2876 Case (i): For an array section or for an array expression other than a
2877 whole array or array structure component, UBOUND(ARRAY, DIM)
2878 has the value equal to the number of elements in the given
2879 dimension; otherwise, it has a value equal to the upper bound
2880 for subscript DIM of ARRAY if dimension DIM of ARRAY does
2881 not have size zero and has value zero if dimension DIM has
2882 size zero. */
2883
2884 if (!upper && assumed_rank_lb_one)
2885 se->expr = gfc_index_one_node;
2886 else if (as)
2887 {
2888 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
2889
2890 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2891 ubound, lbound);
2892 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2893 stride, gfc_index_zero_node);
2894 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2895 logical_type_node, cond3, cond1);
2896 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2897 stride, gfc_index_zero_node);
2898
2899 if (upper)
2900 {
2901 tree cond5;
2902 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2903 logical_type_node, cond3, cond4);
2904 cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2905 gfc_index_one_node, lbound);
2906 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2907 logical_type_node, cond4, cond5);
2908
2909 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2910 logical_type_node, cond, cond5);
2911
2912 if (assumed_rank_lb_one)
2913 {
2914 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2915 gfc_array_index_type, ubound, lbound);
2916 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2917 gfc_array_index_type, tmp, gfc_index_one_node);
2918 }
2919 else
2920 tmp = ubound;
2921
2922 se->expr = fold_build3_loc (input_location, COND_EXPR,
2923 gfc_array_index_type, cond,
2924 tmp, gfc_index_zero_node);
2925 }
2926 else
2927 {
2928 if (as->type == AS_ASSUMED_SIZE)
2929 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2930 bound, build_int_cst (TREE_TYPE (bound),
2931 arg->expr->rank - 1));
2932 else
2933 cond = logical_false_node;
2934
2935 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2936 logical_type_node, cond3, cond4);
2937 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2938 logical_type_node, cond, cond1);
2939
2940 se->expr = fold_build3_loc (input_location, COND_EXPR,
2941 gfc_array_index_type, cond,
2942 lbound, gfc_index_one_node);
2943 }
2944 }
2945 else
2946 {
2947 if (upper)
2948 {
2949 size = fold_build2_loc (input_location, MINUS_EXPR,
2950 gfc_array_index_type, ubound, lbound);
2951 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2952 gfc_array_index_type, size,
2953 gfc_index_one_node);
2954 se->expr = fold_build2_loc (input_location, MAX_EXPR,
2955 gfc_array_index_type, se->expr,
2956 gfc_index_zero_node);
2957 }
2958 else
2959 se->expr = gfc_index_one_node;
2960 }
2961
2962 type = gfc_typenode_for_spec (&expr->ts);
2963 se->expr = convert (type, se->expr);
2964 }
2965
2966
2967 static void
conv_intrinsic_cobound(gfc_se * se,gfc_expr * expr)2968 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2969 {
2970 gfc_actual_arglist *arg;
2971 gfc_actual_arglist *arg2;
2972 gfc_se argse;
2973 tree bound, resbound, resbound2, desc, cond, tmp;
2974 tree type;
2975 int corank;
2976
2977 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2978 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2979 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2980
2981 arg = expr->value.function.actual;
2982 arg2 = arg->next;
2983
2984 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2985 corank = gfc_get_corank (arg->expr);
2986
2987 gfc_init_se (&argse, NULL);
2988 argse.want_coarray = 1;
2989
2990 gfc_conv_expr_descriptor (&argse, arg->expr);
2991 gfc_add_block_to_block (&se->pre, &argse.pre);
2992 gfc_add_block_to_block (&se->post, &argse.post);
2993 desc = argse.expr;
2994
2995 if (se->ss)
2996 {
2997 /* Create an implicit second parameter from the loop variable. */
2998 gcc_assert (!arg2->expr);
2999 gcc_assert (corank > 0);
3000 gcc_assert (se->loop->dimen == 1);
3001 gcc_assert (se->ss->info->expr == expr);
3002
3003 bound = se->loop->loopvar[0];
3004 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3005 bound, gfc_rank_cst[arg->expr->rank]);
3006 gfc_advance_se_ss_chain (se);
3007 }
3008 else
3009 {
3010 /* use the passed argument. */
3011 gcc_assert (arg2->expr);
3012 gfc_init_se (&argse, NULL);
3013 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
3014 gfc_add_block_to_block (&se->pre, &argse.pre);
3015 bound = argse.expr;
3016
3017 if (INTEGER_CST_P (bound))
3018 {
3019 if (wi::ltu_p (wi::to_wide (bound), 1)
3020 || wi::gtu_p (wi::to_wide (bound),
3021 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
3022 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3023 "dimension index", expr->value.function.isym->name,
3024 &expr->where);
3025 }
3026 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3027 {
3028 bound = gfc_evaluate_now (bound, &se->pre);
3029 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3030 bound, build_int_cst (TREE_TYPE (bound), 1));
3031 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
3032 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3033 bound, tmp);
3034 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3035 logical_type_node, cond, tmp);
3036 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3037 gfc_msg_fault);
3038 }
3039
3040
3041 /* Subtract 1 to get to zero based and add dimensions. */
3042 switch (arg->expr->rank)
3043 {
3044 case 0:
3045 bound = fold_build2_loc (input_location, MINUS_EXPR,
3046 gfc_array_index_type, bound,
3047 gfc_index_one_node);
3048 case 1:
3049 break;
3050 default:
3051 bound = fold_build2_loc (input_location, PLUS_EXPR,
3052 gfc_array_index_type, bound,
3053 gfc_rank_cst[arg->expr->rank - 1]);
3054 }
3055 }
3056
3057 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3058
3059 /* Handle UCOBOUND with special handling of the last codimension. */
3060 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3061 {
3062 /* Last codimension: For -fcoarray=single just return
3063 the lcobound - otherwise add
3064 ceiling (real (num_images ()) / real (size)) - 1
3065 = (num_images () + size - 1) / size - 1
3066 = (num_images - 1) / size(),
3067 where size is the product of the extent of all but the last
3068 codimension. */
3069
3070 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3071 {
3072 tree cosize;
3073
3074 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3075 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3076 2, integer_zero_node,
3077 build_int_cst (integer_type_node, -1));
3078 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3079 gfc_array_index_type,
3080 fold_convert (gfc_array_index_type, tmp),
3081 build_int_cst (gfc_array_index_type, 1));
3082 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3083 gfc_array_index_type, tmp,
3084 fold_convert (gfc_array_index_type, cosize));
3085 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3086 gfc_array_index_type, resbound, tmp);
3087 }
3088 else if (flag_coarray != GFC_FCOARRAY_SINGLE)
3089 {
3090 /* ubound = lbound + num_images() - 1. */
3091 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3092 2, integer_zero_node,
3093 build_int_cst (integer_type_node, -1));
3094 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3095 gfc_array_index_type,
3096 fold_convert (gfc_array_index_type, tmp),
3097 build_int_cst (gfc_array_index_type, 1));
3098 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3099 gfc_array_index_type, resbound, tmp);
3100 }
3101
3102 if (corank > 1)
3103 {
3104 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3105 bound,
3106 build_int_cst (TREE_TYPE (bound),
3107 arg->expr->rank + corank - 1));
3108
3109 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3110 se->expr = fold_build3_loc (input_location, COND_EXPR,
3111 gfc_array_index_type, cond,
3112 resbound, resbound2);
3113 }
3114 else
3115 se->expr = resbound;
3116 }
3117 else
3118 se->expr = resbound;
3119
3120 type = gfc_typenode_for_spec (&expr->ts);
3121 se->expr = convert (type, se->expr);
3122 }
3123
3124
3125 static void
conv_intrinsic_stride(gfc_se * se,gfc_expr * expr)3126 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3127 {
3128 gfc_actual_arglist *array_arg;
3129 gfc_actual_arglist *dim_arg;
3130 gfc_se argse;
3131 tree desc, tmp;
3132
3133 array_arg = expr->value.function.actual;
3134 dim_arg = array_arg->next;
3135
3136 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
3137
3138 gfc_init_se (&argse, NULL);
3139 gfc_conv_expr_descriptor (&argse, array_arg->expr);
3140 gfc_add_block_to_block (&se->pre, &argse.pre);
3141 gfc_add_block_to_block (&se->post, &argse.post);
3142 desc = argse.expr;
3143
3144 gcc_assert (dim_arg->expr);
3145 gfc_init_se (&argse, NULL);
3146 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
3147 gfc_add_block_to_block (&se->pre, &argse.pre);
3148 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3149 argse.expr, gfc_index_one_node);
3150 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3151 }
3152
3153 static void
gfc_conv_intrinsic_abs(gfc_se * se,gfc_expr * expr)3154 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3155 {
3156 tree arg, cabs;
3157
3158 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3159
3160 switch (expr->value.function.actual->expr->ts.type)
3161 {
3162 case BT_INTEGER:
3163 case BT_REAL:
3164 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3165 arg);
3166 break;
3167
3168 case BT_COMPLEX:
3169 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3170 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3171 break;
3172
3173 default:
3174 gcc_unreachable ();
3175 }
3176 }
3177
3178
3179 /* Create a complex value from one or two real components. */
3180
3181 static void
gfc_conv_intrinsic_cmplx(gfc_se * se,gfc_expr * expr,int both)3182 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3183 {
3184 tree real;
3185 tree imag;
3186 tree type;
3187 tree *args;
3188 unsigned int num_args;
3189
3190 num_args = gfc_intrinsic_argument_list_length (expr);
3191 args = XALLOCAVEC (tree, num_args);
3192
3193 type = gfc_typenode_for_spec (&expr->ts);
3194 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3195 real = convert (TREE_TYPE (type), args[0]);
3196 if (both)
3197 imag = convert (TREE_TYPE (type), args[1]);
3198 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3199 {
3200 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3201 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3202 imag = convert (TREE_TYPE (type), imag);
3203 }
3204 else
3205 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3206
3207 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3208 }
3209
3210
3211 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3212 MODULO(A, P) = A - FLOOR (A / P) * P
3213
3214 The obvious algorithms above are numerically instable for large
3215 arguments, hence these intrinsics are instead implemented via calls
3216 to the fmod family of functions. It is the responsibility of the
3217 user to ensure that the second argument is non-zero. */
3218
3219 static void
gfc_conv_intrinsic_mod(gfc_se * se,gfc_expr * expr,int modulo)3220 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3221 {
3222 tree type;
3223 tree tmp;
3224 tree test;
3225 tree test2;
3226 tree fmod;
3227 tree zero;
3228 tree args[2];
3229
3230 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3231
3232 switch (expr->ts.type)
3233 {
3234 case BT_INTEGER:
3235 /* Integer case is easy, we've got a builtin op. */
3236 type = TREE_TYPE (args[0]);
3237
3238 if (modulo)
3239 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3240 args[0], args[1]);
3241 else
3242 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3243 args[0], args[1]);
3244 break;
3245
3246 case BT_REAL:
3247 fmod = NULL_TREE;
3248 /* Check if we have a builtin fmod. */
3249 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3250
3251 /* The builtin should always be available. */
3252 gcc_assert (fmod != NULL_TREE);
3253
3254 tmp = build_addr (fmod);
3255 se->expr = build_call_array_loc (input_location,
3256 TREE_TYPE (TREE_TYPE (fmod)),
3257 tmp, 2, args);
3258 if (modulo == 0)
3259 return;
3260
3261 type = TREE_TYPE (args[0]);
3262
3263 args[0] = gfc_evaluate_now (args[0], &se->pre);
3264 args[1] = gfc_evaluate_now (args[1], &se->pre);
3265
3266 /* Definition:
3267 modulo = arg - floor (arg/arg2) * arg2
3268
3269 In order to calculate the result accurately, we use the fmod
3270 function as follows.
3271
3272 res = fmod (arg, arg2);
3273 if (res)
3274 {
3275 if ((arg < 0) xor (arg2 < 0))
3276 res += arg2;
3277 }
3278 else
3279 res = copysign (0., arg2);
3280
3281 => As two nested ternary exprs:
3282
3283 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3284 : copysign (0., arg2);
3285
3286 */
3287
3288 zero = gfc_build_const (type, integer_zero_node);
3289 tmp = gfc_evaluate_now (se->expr, &se->pre);
3290 if (!flag_signed_zeros)
3291 {
3292 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3293 args[0], zero);
3294 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3295 args[1], zero);
3296 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3297 logical_type_node, test, test2);
3298 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3299 tmp, zero);
3300 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3301 logical_type_node, test, test2);
3302 test = gfc_evaluate_now (test, &se->pre);
3303 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3304 fold_build2_loc (input_location,
3305 PLUS_EXPR,
3306 type, tmp, args[1]),
3307 tmp);
3308 }
3309 else
3310 {
3311 tree expr1, copysign, cscall;
3312 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3313 expr->ts.kind);
3314 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3315 args[0], zero);
3316 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3317 args[1], zero);
3318 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3319 logical_type_node, test, test2);
3320 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3321 fold_build2_loc (input_location,
3322 PLUS_EXPR,
3323 type, tmp, args[1]),
3324 tmp);
3325 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3326 tmp, zero);
3327 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3328 args[1]);
3329 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3330 expr1, cscall);
3331 }
3332 return;
3333
3334 default:
3335 gcc_unreachable ();
3336 }
3337 }
3338
3339 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3340 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3341 where the right shifts are logical (i.e. 0's are shifted in).
3342 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3343 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3344 DSHIFTL(I,J,0) = I
3345 DSHIFTL(I,J,BITSIZE) = J
3346 DSHIFTR(I,J,0) = J
3347 DSHIFTR(I,J,BITSIZE) = I. */
3348
3349 static void
gfc_conv_intrinsic_dshift(gfc_se * se,gfc_expr * expr,bool dshiftl)3350 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3351 {
3352 tree type, utype, stype, arg1, arg2, shift, res, left, right;
3353 tree args[3], cond, tmp;
3354 int bitsize;
3355
3356 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3357
3358 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3359 type = TREE_TYPE (args[0]);
3360 bitsize = TYPE_PRECISION (type);
3361 utype = unsigned_type_for (type);
3362 stype = TREE_TYPE (args[2]);
3363
3364 arg1 = gfc_evaluate_now (args[0], &se->pre);
3365 arg2 = gfc_evaluate_now (args[1], &se->pre);
3366 shift = gfc_evaluate_now (args[2], &se->pre);
3367
3368 /* The generic case. */
3369 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3370 build_int_cst (stype, bitsize), shift);
3371 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3372 arg1, dshiftl ? shift : tmp);
3373
3374 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3375 fold_convert (utype, arg2), dshiftl ? tmp : shift);
3376 right = fold_convert (type, right);
3377
3378 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3379
3380 /* Special cases. */
3381 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3382 build_int_cst (stype, 0));
3383 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3384 dshiftl ? arg1 : arg2, res);
3385
3386 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3387 build_int_cst (stype, bitsize));
3388 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3389 dshiftl ? arg2 : arg1, res);
3390
3391 se->expr = res;
3392 }
3393
3394
3395 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3396
3397 static void
gfc_conv_intrinsic_dim(gfc_se * se,gfc_expr * expr)3398 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3399 {
3400 tree val;
3401 tree tmp;
3402 tree type;
3403 tree zero;
3404 tree args[2];
3405
3406 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3407 type = TREE_TYPE (args[0]);
3408
3409 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3410 val = gfc_evaluate_now (val, &se->pre);
3411
3412 zero = gfc_build_const (type, integer_zero_node);
3413 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3414 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3415 }
3416
3417
3418 /* SIGN(A, B) is absolute value of A times sign of B.
3419 The real value versions use library functions to ensure the correct
3420 handling of negative zero. Integer case implemented as:
3421 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3422 */
3423
3424 static void
gfc_conv_intrinsic_sign(gfc_se * se,gfc_expr * expr)3425 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3426 {
3427 tree tmp;
3428 tree type;
3429 tree args[2];
3430
3431 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3432 if (expr->ts.type == BT_REAL)
3433 {
3434 tree abs;
3435
3436 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3437 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3438
3439 /* We explicitly have to ignore the minus sign. We do so by using
3440 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3441 if (!flag_sign_zero
3442 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3443 {
3444 tree cond, zero;
3445 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3446 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3447 args[1], zero);
3448 se->expr = fold_build3_loc (input_location, COND_EXPR,
3449 TREE_TYPE (args[0]), cond,
3450 build_call_expr_loc (input_location, abs, 1,
3451 args[0]),
3452 build_call_expr_loc (input_location, tmp, 2,
3453 args[0], args[1]));
3454 }
3455 else
3456 se->expr = build_call_expr_loc (input_location, tmp, 2,
3457 args[0], args[1]);
3458 return;
3459 }
3460
3461 /* Having excluded floating point types, we know we are now dealing
3462 with signed integer types. */
3463 type = TREE_TYPE (args[0]);
3464
3465 /* Args[0] is used multiple times below. */
3466 args[0] = gfc_evaluate_now (args[0], &se->pre);
3467
3468 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3469 the signs of A and B are the same, and of all ones if they differ. */
3470 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3471 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3472 build_int_cst (type, TYPE_PRECISION (type) - 1));
3473 tmp = gfc_evaluate_now (tmp, &se->pre);
3474
3475 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3476 is all ones (i.e. -1). */
3477 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3478 fold_build2_loc (input_location, PLUS_EXPR,
3479 type, args[0], tmp), tmp);
3480 }
3481
3482
3483 /* Test for the presence of an optional argument. */
3484
3485 static void
gfc_conv_intrinsic_present(gfc_se * se,gfc_expr * expr)3486 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3487 {
3488 gfc_expr *arg;
3489
3490 arg = expr->value.function.actual->expr;
3491 gcc_assert (arg->expr_type == EXPR_VARIABLE);
3492 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3493 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3494 }
3495
3496
3497 /* Calculate the double precision product of two single precision values. */
3498
3499 static void
gfc_conv_intrinsic_dprod(gfc_se * se,gfc_expr * expr)3500 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3501 {
3502 tree type;
3503 tree args[2];
3504
3505 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3506
3507 /* Convert the args to double precision before multiplying. */
3508 type = gfc_typenode_for_spec (&expr->ts);
3509 args[0] = convert (type, args[0]);
3510 args[1] = convert (type, args[1]);
3511 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3512 args[1]);
3513 }
3514
3515
3516 /* Return a length one character string containing an ascii character. */
3517
3518 static void
gfc_conv_intrinsic_char(gfc_se * se,gfc_expr * expr)3519 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3520 {
3521 tree arg[2];
3522 tree var;
3523 tree type;
3524 unsigned int num_args;
3525
3526 num_args = gfc_intrinsic_argument_list_length (expr);
3527 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3528
3529 type = gfc_get_char_type (expr->ts.kind);
3530 var = gfc_create_var (type, "char");
3531
3532 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3533 gfc_add_modify (&se->pre, var, arg[0]);
3534 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3535 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3536 }
3537
3538
3539 static void
gfc_conv_intrinsic_ctime(gfc_se * se,gfc_expr * expr)3540 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3541 {
3542 tree var;
3543 tree len;
3544 tree tmp;
3545 tree cond;
3546 tree fndecl;
3547 tree *args;
3548 unsigned int num_args;
3549
3550 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3551 args = XALLOCAVEC (tree, num_args);
3552
3553 var = gfc_create_var (pchar_type_node, "pstr");
3554 len = gfc_create_var (gfc_charlen_type_node, "len");
3555
3556 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3557 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3558 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3559
3560 fndecl = build_addr (gfor_fndecl_ctime);
3561 tmp = build_call_array_loc (input_location,
3562 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3563 fndecl, num_args, args);
3564 gfc_add_expr_to_block (&se->pre, tmp);
3565
3566 /* Free the temporary afterwards, if necessary. */
3567 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3568 len, build_int_cst (TREE_TYPE (len), 0));
3569 tmp = gfc_call_free (var);
3570 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3571 gfc_add_expr_to_block (&se->post, tmp);
3572
3573 se->expr = var;
3574 se->string_length = len;
3575 }
3576
3577
3578 static void
gfc_conv_intrinsic_fdate(gfc_se * se,gfc_expr * expr)3579 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3580 {
3581 tree var;
3582 tree len;
3583 tree tmp;
3584 tree cond;
3585 tree fndecl;
3586 tree *args;
3587 unsigned int num_args;
3588
3589 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3590 args = XALLOCAVEC (tree, num_args);
3591
3592 var = gfc_create_var (pchar_type_node, "pstr");
3593 len = gfc_create_var (gfc_charlen_type_node, "len");
3594
3595 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3596 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3597 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3598
3599 fndecl = build_addr (gfor_fndecl_fdate);
3600 tmp = build_call_array_loc (input_location,
3601 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3602 fndecl, num_args, args);
3603 gfc_add_expr_to_block (&se->pre, tmp);
3604
3605 /* Free the temporary afterwards, if necessary. */
3606 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3607 len, build_int_cst (TREE_TYPE (len), 0));
3608 tmp = gfc_call_free (var);
3609 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3610 gfc_add_expr_to_block (&se->post, tmp);
3611
3612 se->expr = var;
3613 se->string_length = len;
3614 }
3615
3616
3617 /* Generate a direct call to free() for the FREE subroutine. */
3618
3619 static tree
conv_intrinsic_free(gfc_code * code)3620 conv_intrinsic_free (gfc_code *code)
3621 {
3622 stmtblock_t block;
3623 gfc_se argse;
3624 tree arg, call;
3625
3626 gfc_init_se (&argse, NULL);
3627 gfc_conv_expr (&argse, code->ext.actual->expr);
3628 arg = fold_convert (ptr_type_node, argse.expr);
3629
3630 gfc_init_block (&block);
3631 call = build_call_expr_loc (input_location,
3632 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3633 gfc_add_expr_to_block (&block, call);
3634 return gfc_finish_block (&block);
3635 }
3636
3637
3638 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3639 conversions. */
3640
3641 static tree
conv_intrinsic_system_clock(gfc_code * code)3642 conv_intrinsic_system_clock (gfc_code *code)
3643 {
3644 stmtblock_t block;
3645 gfc_se count_se, count_rate_se, count_max_se;
3646 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3647 tree tmp;
3648 int least;
3649
3650 gfc_expr *count = code->ext.actual->expr;
3651 gfc_expr *count_rate = code->ext.actual->next->expr;
3652 gfc_expr *count_max = code->ext.actual->next->next->expr;
3653
3654 /* Evaluate our arguments. */
3655 if (count)
3656 {
3657 gfc_init_se (&count_se, NULL);
3658 gfc_conv_expr (&count_se, count);
3659 }
3660
3661 if (count_rate)
3662 {
3663 gfc_init_se (&count_rate_se, NULL);
3664 gfc_conv_expr (&count_rate_se, count_rate);
3665 }
3666
3667 if (count_max)
3668 {
3669 gfc_init_se (&count_max_se, NULL);
3670 gfc_conv_expr (&count_max_se, count_max);
3671 }
3672
3673 /* Find the smallest kind found of the arguments. */
3674 least = 16;
3675 least = (count && count->ts.kind < least) ? count->ts.kind : least;
3676 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3677 : least;
3678 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3679 : least;
3680
3681 /* Prepare temporary variables. */
3682
3683 if (count)
3684 {
3685 if (least >= 8)
3686 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3687 else if (least == 4)
3688 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3689 else if (count->ts.kind == 1)
3690 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3691 count->ts.kind);
3692 else
3693 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3694 count->ts.kind);
3695 }
3696
3697 if (count_rate)
3698 {
3699 if (least >= 8)
3700 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3701 else if (least == 4)
3702 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3703 else
3704 arg2 = integer_zero_node;
3705 }
3706
3707 if (count_max)
3708 {
3709 if (least >= 8)
3710 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3711 else if (least == 4)
3712 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3713 else
3714 arg3 = integer_zero_node;
3715 }
3716
3717 /* Make the function call. */
3718 gfc_init_block (&block);
3719
3720 if (least <= 2)
3721 {
3722 if (least == 1)
3723 {
3724 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3725 : null_pointer_node;
3726 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3727 : null_pointer_node;
3728 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3729 : null_pointer_node;
3730 }
3731
3732 if (least == 2)
3733 {
3734 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3735 : null_pointer_node;
3736 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3737 : null_pointer_node;
3738 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3739 : null_pointer_node;
3740 }
3741 }
3742 else
3743 {
3744 if (least == 4)
3745 {
3746 tmp = build_call_expr_loc (input_location,
3747 gfor_fndecl_system_clock4, 3,
3748 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3749 : null_pointer_node,
3750 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3751 : null_pointer_node,
3752 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3753 : null_pointer_node);
3754 gfc_add_expr_to_block (&block, tmp);
3755 }
3756 /* Handle kind>=8, 10, or 16 arguments */
3757 if (least >= 8)
3758 {
3759 tmp = build_call_expr_loc (input_location,
3760 gfor_fndecl_system_clock8, 3,
3761 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3762 : null_pointer_node,
3763 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3764 : null_pointer_node,
3765 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3766 : null_pointer_node);
3767 gfc_add_expr_to_block (&block, tmp);
3768 }
3769 }
3770
3771 /* And store values back if needed. */
3772 if (arg1 && arg1 != count_se.expr)
3773 gfc_add_modify (&block, count_se.expr,
3774 fold_convert (TREE_TYPE (count_se.expr), arg1));
3775 if (arg2 && arg2 != count_rate_se.expr)
3776 gfc_add_modify (&block, count_rate_se.expr,
3777 fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3778 if (arg3 && arg3 != count_max_se.expr)
3779 gfc_add_modify (&block, count_max_se.expr,
3780 fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3781
3782 return gfc_finish_block (&block);
3783 }
3784
3785
3786 /* Return a character string containing the tty name. */
3787
3788 static void
gfc_conv_intrinsic_ttynam(gfc_se * se,gfc_expr * expr)3789 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3790 {
3791 tree var;
3792 tree len;
3793 tree tmp;
3794 tree cond;
3795 tree fndecl;
3796 tree *args;
3797 unsigned int num_args;
3798
3799 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3800 args = XALLOCAVEC (tree, num_args);
3801
3802 var = gfc_create_var (pchar_type_node, "pstr");
3803 len = gfc_create_var (gfc_charlen_type_node, "len");
3804
3805 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3806 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3807 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3808
3809 fndecl = build_addr (gfor_fndecl_ttynam);
3810 tmp = build_call_array_loc (input_location,
3811 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3812 fndecl, num_args, args);
3813 gfc_add_expr_to_block (&se->pre, tmp);
3814
3815 /* Free the temporary afterwards, if necessary. */
3816 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3817 len, build_int_cst (TREE_TYPE (len), 0));
3818 tmp = gfc_call_free (var);
3819 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3820 gfc_add_expr_to_block (&se->post, tmp);
3821
3822 se->expr = var;
3823 se->string_length = len;
3824 }
3825
3826
3827 /* Get the minimum/maximum value of all the parameters.
3828 minmax (a1, a2, a3, ...)
3829 {
3830 mvar = a1;
3831 if (a2 .op. mvar || isnan (mvar))
3832 mvar = a2;
3833 if (a3 .op. mvar || isnan (mvar))
3834 mvar = a3;
3835 ...
3836 return mvar
3837 }
3838 */
3839
3840 /* TODO: Mismatching types can occur when specific names are used.
3841 These should be handled during resolution. */
3842 static void
gfc_conv_intrinsic_minmax(gfc_se * se,gfc_expr * expr,enum tree_code op)3843 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3844 {
3845 tree tmp;
3846 tree mvar;
3847 tree val;
3848 tree thencase;
3849 tree *args;
3850 tree type;
3851 gfc_actual_arglist *argexpr;
3852 unsigned int i, nargs;
3853
3854 nargs = gfc_intrinsic_argument_list_length (expr);
3855 args = XALLOCAVEC (tree, nargs);
3856
3857 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3858 type = gfc_typenode_for_spec (&expr->ts);
3859
3860 argexpr = expr->value.function.actual;
3861 if (TREE_TYPE (args[0]) != type)
3862 args[0] = convert (type, args[0]);
3863 /* Only evaluate the argument once. */
3864 if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3865 args[0] = gfc_evaluate_now (args[0], &se->pre);
3866
3867 mvar = gfc_create_var (type, "M");
3868 gfc_add_modify (&se->pre, mvar, args[0]);
3869 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
3870 {
3871 tree cond, isnan;
3872
3873 val = args[i];
3874
3875 /* Handle absent optional arguments by ignoring the comparison. */
3876 if (argexpr->expr->expr_type == EXPR_VARIABLE
3877 && argexpr->expr->symtree->n.sym->attr.optional
3878 && TREE_CODE (val) == INDIRECT_REF)
3879 cond = fold_build2_loc (input_location,
3880 NE_EXPR, logical_type_node,
3881 TREE_OPERAND (val, 0),
3882 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3883 else
3884 {
3885 cond = NULL_TREE;
3886
3887 /* Only evaluate the argument once. */
3888 if (!VAR_P (val) && !TREE_CONSTANT (val))
3889 val = gfc_evaluate_now (val, &se->pre);
3890 }
3891
3892 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
3893
3894 tmp = fold_build2_loc (input_location, op, logical_type_node,
3895 convert (type, val), mvar);
3896
3897 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3898 __builtin_isnan might be made dependent on that module being loaded,
3899 to help performance of programs that don't rely on IEEE semantics. */
3900 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
3901 {
3902 isnan = build_call_expr_loc (input_location,
3903 builtin_decl_explicit (BUILT_IN_ISNAN),
3904 1, mvar);
3905 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3906 logical_type_node, tmp,
3907 fold_convert (logical_type_node, isnan));
3908 }
3909 tmp = build3_v (COND_EXPR, tmp, thencase,
3910 build_empty_stmt (input_location));
3911
3912 if (cond != NULL_TREE)
3913 tmp = build3_v (COND_EXPR, cond, tmp,
3914 build_empty_stmt (input_location));
3915
3916 gfc_add_expr_to_block (&se->pre, tmp);
3917 argexpr = argexpr->next;
3918 }
3919 se->expr = mvar;
3920 }
3921
3922
3923 /* Generate library calls for MIN and MAX intrinsics for character
3924 variables. */
3925 static void
gfc_conv_intrinsic_minmax_char(gfc_se * se,gfc_expr * expr,int op)3926 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3927 {
3928 tree *args;
3929 tree var, len, fndecl, tmp, cond, function;
3930 unsigned int nargs;
3931
3932 nargs = gfc_intrinsic_argument_list_length (expr);
3933 args = XALLOCAVEC (tree, nargs + 4);
3934 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3935
3936 /* Create the result variables. */
3937 len = gfc_create_var (gfc_charlen_type_node, "len");
3938 args[0] = gfc_build_addr_expr (NULL_TREE, len);
3939 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3940 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3941 args[2] = build_int_cst (integer_type_node, op);
3942 args[3] = build_int_cst (integer_type_node, nargs / 2);
3943
3944 if (expr->ts.kind == 1)
3945 function = gfor_fndecl_string_minmax;
3946 else if (expr->ts.kind == 4)
3947 function = gfor_fndecl_string_minmax_char4;
3948 else
3949 gcc_unreachable ();
3950
3951 /* Make the function call. */
3952 fndecl = build_addr (function);
3953 tmp = build_call_array_loc (input_location,
3954 TREE_TYPE (TREE_TYPE (function)), fndecl,
3955 nargs + 4, args);
3956 gfc_add_expr_to_block (&se->pre, tmp);
3957
3958 /* Free the temporary afterwards, if necessary. */
3959 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3960 len, build_int_cst (TREE_TYPE (len), 0));
3961 tmp = gfc_call_free (var);
3962 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3963 gfc_add_expr_to_block (&se->post, tmp);
3964
3965 se->expr = var;
3966 se->string_length = len;
3967 }
3968
3969
3970 /* Create a symbol node for this intrinsic. The symbol from the frontend
3971 has the generic name. */
3972
3973 static gfc_symbol *
gfc_get_symbol_for_expr(gfc_expr * expr,bool ignore_optional)3974 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3975 {
3976 gfc_symbol *sym;
3977
3978 /* TODO: Add symbols for intrinsic function to the global namespace. */
3979 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3980 sym = gfc_new_symbol (expr->value.function.name, NULL);
3981
3982 sym->ts = expr->ts;
3983 sym->attr.external = 1;
3984 sym->attr.function = 1;
3985 sym->attr.always_explicit = 1;
3986 sym->attr.proc = PROC_INTRINSIC;
3987 sym->attr.flavor = FL_PROCEDURE;
3988 sym->result = sym;
3989 if (expr->rank > 0)
3990 {
3991 sym->attr.dimension = 1;
3992 sym->as = gfc_get_array_spec ();
3993 sym->as->type = AS_ASSUMED_SHAPE;
3994 sym->as->rank = expr->rank;
3995 }
3996
3997 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3998 ignore_optional ? expr->value.function.actual
3999 : NULL);
4000
4001 return sym;
4002 }
4003
4004 /* Generate a call to an external intrinsic function. */
4005 static void
gfc_conv_intrinsic_funcall(gfc_se * se,gfc_expr * expr)4006 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4007 {
4008 gfc_symbol *sym;
4009 vec<tree, va_gc> *append_args;
4010
4011 gcc_assert (!se->ss || se->ss->info->expr == expr);
4012
4013 if (se->ss)
4014 gcc_assert (expr->rank > 0);
4015 else
4016 gcc_assert (expr->rank == 0);
4017
4018 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4019
4020 /* Calls to libgfortran_matmul need to be appended special arguments,
4021 to be able to call the BLAS ?gemm functions if required and possible. */
4022 append_args = NULL;
4023 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4024 && sym->ts.type != BT_LOGICAL)
4025 {
4026 tree cint = gfc_get_int_type (gfc_c_int_kind);
4027
4028 if (flag_external_blas
4029 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4030 && (sym->ts.kind == 4 || sym->ts.kind == 8))
4031 {
4032 tree gemm_fndecl;
4033
4034 if (sym->ts.type == BT_REAL)
4035 {
4036 if (sym->ts.kind == 4)
4037 gemm_fndecl = gfor_fndecl_sgemm;
4038 else
4039 gemm_fndecl = gfor_fndecl_dgemm;
4040 }
4041 else
4042 {
4043 if (sym->ts.kind == 4)
4044 gemm_fndecl = gfor_fndecl_cgemm;
4045 else
4046 gemm_fndecl = gfor_fndecl_zgemm;
4047 }
4048
4049 vec_alloc (append_args, 3);
4050 append_args->quick_push (build_int_cst (cint, 1));
4051 append_args->quick_push (build_int_cst (cint,
4052 flag_blas_matmul_limit));
4053 append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4054 gemm_fndecl));
4055 }
4056 else
4057 {
4058 vec_alloc (append_args, 3);
4059 append_args->quick_push (build_int_cst (cint, 0));
4060 append_args->quick_push (build_int_cst (cint, 0));
4061 append_args->quick_push (null_pointer_node);
4062 }
4063 }
4064
4065 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4066 append_args);
4067 gfc_free_symbol (sym);
4068 }
4069
4070 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4071 Implemented as
4072 any(a)
4073 {
4074 forall (i=...)
4075 if (a[i] != 0)
4076 return 1
4077 end forall
4078 return 0
4079 }
4080 all(a)
4081 {
4082 forall (i=...)
4083 if (a[i] == 0)
4084 return 0
4085 end forall
4086 return 1
4087 }
4088 */
4089 static void
gfc_conv_intrinsic_anyall(gfc_se * se,gfc_expr * expr,enum tree_code op)4090 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4091 {
4092 tree resvar;
4093 stmtblock_t block;
4094 stmtblock_t body;
4095 tree type;
4096 tree tmp;
4097 tree found;
4098 gfc_loopinfo loop;
4099 gfc_actual_arglist *actual;
4100 gfc_ss *arrayss;
4101 gfc_se arrayse;
4102 tree exit_label;
4103
4104 if (se->ss)
4105 {
4106 gfc_conv_intrinsic_funcall (se, expr);
4107 return;
4108 }
4109
4110 actual = expr->value.function.actual;
4111 type = gfc_typenode_for_spec (&expr->ts);
4112 /* Initialize the result. */
4113 resvar = gfc_create_var (type, "test");
4114 if (op == EQ_EXPR)
4115 tmp = convert (type, boolean_true_node);
4116 else
4117 tmp = convert (type, boolean_false_node);
4118 gfc_add_modify (&se->pre, resvar, tmp);
4119
4120 /* Walk the arguments. */
4121 arrayss = gfc_walk_expr (actual->expr);
4122 gcc_assert (arrayss != gfc_ss_terminator);
4123
4124 /* Initialize the scalarizer. */
4125 gfc_init_loopinfo (&loop);
4126 exit_label = gfc_build_label_decl (NULL_TREE);
4127 TREE_USED (exit_label) = 1;
4128 gfc_add_ss_to_loop (&loop, arrayss);
4129
4130 /* Initialize the loop. */
4131 gfc_conv_ss_startstride (&loop);
4132 gfc_conv_loop_setup (&loop, &expr->where);
4133
4134 gfc_mark_ss_chain_used (arrayss, 1);
4135 /* Generate the loop body. */
4136 gfc_start_scalarized_body (&loop, &body);
4137
4138 /* If the condition matches then set the return value. */
4139 gfc_start_block (&block);
4140 if (op == EQ_EXPR)
4141 tmp = convert (type, boolean_false_node);
4142 else
4143 tmp = convert (type, boolean_true_node);
4144 gfc_add_modify (&block, resvar, tmp);
4145
4146 /* And break out of the loop. */
4147 tmp = build1_v (GOTO_EXPR, exit_label);
4148 gfc_add_expr_to_block (&block, tmp);
4149
4150 found = gfc_finish_block (&block);
4151
4152 /* Check this element. */
4153 gfc_init_se (&arrayse, NULL);
4154 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4155 arrayse.ss = arrayss;
4156 gfc_conv_expr_val (&arrayse, actual->expr);
4157
4158 gfc_add_block_to_block (&body, &arrayse.pre);
4159 tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4160 build_int_cst (TREE_TYPE (arrayse.expr), 0));
4161 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4162 gfc_add_expr_to_block (&body, tmp);
4163 gfc_add_block_to_block (&body, &arrayse.post);
4164
4165 gfc_trans_scalarizing_loops (&loop, &body);
4166
4167 /* Add the exit label. */
4168 tmp = build1_v (LABEL_EXPR, exit_label);
4169 gfc_add_expr_to_block (&loop.pre, tmp);
4170
4171 gfc_add_block_to_block (&se->pre, &loop.pre);
4172 gfc_add_block_to_block (&se->pre, &loop.post);
4173 gfc_cleanup_loop (&loop);
4174
4175 se->expr = resvar;
4176 }
4177
4178 /* COUNT(A) = Number of true elements in A. */
4179 static void
gfc_conv_intrinsic_count(gfc_se * se,gfc_expr * expr)4180 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4181 {
4182 tree resvar;
4183 tree type;
4184 stmtblock_t body;
4185 tree tmp;
4186 gfc_loopinfo loop;
4187 gfc_actual_arglist *actual;
4188 gfc_ss *arrayss;
4189 gfc_se arrayse;
4190
4191 if (se->ss)
4192 {
4193 gfc_conv_intrinsic_funcall (se, expr);
4194 return;
4195 }
4196
4197 actual = expr->value.function.actual;
4198
4199 type = gfc_typenode_for_spec (&expr->ts);
4200 /* Initialize the result. */
4201 resvar = gfc_create_var (type, "count");
4202 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4203
4204 /* Walk the arguments. */
4205 arrayss = gfc_walk_expr (actual->expr);
4206 gcc_assert (arrayss != gfc_ss_terminator);
4207
4208 /* Initialize the scalarizer. */
4209 gfc_init_loopinfo (&loop);
4210 gfc_add_ss_to_loop (&loop, arrayss);
4211
4212 /* Initialize the loop. */
4213 gfc_conv_ss_startstride (&loop);
4214 gfc_conv_loop_setup (&loop, &expr->where);
4215
4216 gfc_mark_ss_chain_used (arrayss, 1);
4217 /* Generate the loop body. */
4218 gfc_start_scalarized_body (&loop, &body);
4219
4220 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4221 resvar, build_int_cst (TREE_TYPE (resvar), 1));
4222 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4223
4224 gfc_init_se (&arrayse, NULL);
4225 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4226 arrayse.ss = arrayss;
4227 gfc_conv_expr_val (&arrayse, actual->expr);
4228 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4229 build_empty_stmt (input_location));
4230
4231 gfc_add_block_to_block (&body, &arrayse.pre);
4232 gfc_add_expr_to_block (&body, tmp);
4233 gfc_add_block_to_block (&body, &arrayse.post);
4234
4235 gfc_trans_scalarizing_loops (&loop, &body);
4236
4237 gfc_add_block_to_block (&se->pre, &loop.pre);
4238 gfc_add_block_to_block (&se->pre, &loop.post);
4239 gfc_cleanup_loop (&loop);
4240
4241 se->expr = resvar;
4242 }
4243
4244
4245 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4246 struct and return the corresponding loopinfo. */
4247
4248 static gfc_loopinfo *
enter_nested_loop(gfc_se * se)4249 enter_nested_loop (gfc_se *se)
4250 {
4251 se->ss = se->ss->nested_ss;
4252 gcc_assert (se->ss == se->ss->loop->ss);
4253
4254 return se->ss->loop;
4255 }
4256
4257
4258 /* Inline implementation of the sum and product intrinsics. */
4259 static void
gfc_conv_intrinsic_arith(gfc_se * se,gfc_expr * expr,enum tree_code op,bool norm2)4260 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4261 bool norm2)
4262 {
4263 tree resvar;
4264 tree scale = NULL_TREE;
4265 tree type;
4266 stmtblock_t body;
4267 stmtblock_t block;
4268 tree tmp;
4269 gfc_loopinfo loop, *ploop;
4270 gfc_actual_arglist *arg_array, *arg_mask;
4271 gfc_ss *arrayss = NULL;
4272 gfc_ss *maskss = NULL;
4273 gfc_se arrayse;
4274 gfc_se maskse;
4275 gfc_se *parent_se;
4276 gfc_expr *arrayexpr;
4277 gfc_expr *maskexpr;
4278
4279 if (expr->rank > 0)
4280 {
4281 gcc_assert (gfc_inline_intrinsic_function_p (expr));
4282 parent_se = se;
4283 }
4284 else
4285 parent_se = NULL;
4286
4287 type = gfc_typenode_for_spec (&expr->ts);
4288 /* Initialize the result. */
4289 resvar = gfc_create_var (type, "val");
4290 if (norm2)
4291 {
4292 /* result = 0.0;
4293 scale = 1.0. */
4294 scale = gfc_create_var (type, "scale");
4295 gfc_add_modify (&se->pre, scale,
4296 gfc_build_const (type, integer_one_node));
4297 tmp = gfc_build_const (type, integer_zero_node);
4298 }
4299 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4300 tmp = gfc_build_const (type, integer_zero_node);
4301 else if (op == NE_EXPR)
4302 /* PARITY. */
4303 tmp = convert (type, boolean_false_node);
4304 else if (op == BIT_AND_EXPR)
4305 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4306 type, integer_one_node));
4307 else
4308 tmp = gfc_build_const (type, integer_one_node);
4309
4310 gfc_add_modify (&se->pre, resvar, tmp);
4311
4312 arg_array = expr->value.function.actual;
4313
4314 arrayexpr = arg_array->expr;
4315
4316 if (op == NE_EXPR || norm2)
4317 /* PARITY and NORM2. */
4318 maskexpr = NULL;
4319 else
4320 {
4321 arg_mask = arg_array->next->next;
4322 gcc_assert (arg_mask != NULL);
4323 maskexpr = arg_mask->expr;
4324 }
4325
4326 if (expr->rank == 0)
4327 {
4328 /* Walk the arguments. */
4329 arrayss = gfc_walk_expr (arrayexpr);
4330 gcc_assert (arrayss != gfc_ss_terminator);
4331
4332 if (maskexpr && maskexpr->rank > 0)
4333 {
4334 maskss = gfc_walk_expr (maskexpr);
4335 gcc_assert (maskss != gfc_ss_terminator);
4336 }
4337 else
4338 maskss = NULL;
4339
4340 /* Initialize the scalarizer. */
4341 gfc_init_loopinfo (&loop);
4342 gfc_add_ss_to_loop (&loop, arrayss);
4343 if (maskexpr && maskexpr->rank > 0)
4344 gfc_add_ss_to_loop (&loop, maskss);
4345
4346 /* Initialize the loop. */
4347 gfc_conv_ss_startstride (&loop);
4348 gfc_conv_loop_setup (&loop, &expr->where);
4349
4350 gfc_mark_ss_chain_used (arrayss, 1);
4351 if (maskexpr && maskexpr->rank > 0)
4352 gfc_mark_ss_chain_used (maskss, 1);
4353
4354 ploop = &loop;
4355 }
4356 else
4357 /* All the work has been done in the parent loops. */
4358 ploop = enter_nested_loop (se);
4359
4360 gcc_assert (ploop);
4361
4362 /* Generate the loop body. */
4363 gfc_start_scalarized_body (ploop, &body);
4364
4365 /* If we have a mask, only add this element if the mask is set. */
4366 if (maskexpr && maskexpr->rank > 0)
4367 {
4368 gfc_init_se (&maskse, parent_se);
4369 gfc_copy_loopinfo_to_se (&maskse, ploop);
4370 if (expr->rank == 0)
4371 maskse.ss = maskss;
4372 gfc_conv_expr_val (&maskse, maskexpr);
4373 gfc_add_block_to_block (&body, &maskse.pre);
4374
4375 gfc_start_block (&block);
4376 }
4377 else
4378 gfc_init_block (&block);
4379
4380 /* Do the actual summation/product. */
4381 gfc_init_se (&arrayse, parent_se);
4382 gfc_copy_loopinfo_to_se (&arrayse, ploop);
4383 if (expr->rank == 0)
4384 arrayse.ss = arrayss;
4385 gfc_conv_expr_val (&arrayse, arrayexpr);
4386 gfc_add_block_to_block (&block, &arrayse.pre);
4387
4388 if (norm2)
4389 {
4390 /* if (x (i) != 0.0)
4391 {
4392 absX = abs(x(i))
4393 if (absX > scale)
4394 {
4395 val = scale/absX;
4396 result = 1.0 + result * val * val;
4397 scale = absX;
4398 }
4399 else
4400 {
4401 val = absX/scale;
4402 result += val * val;
4403 }
4404 } */
4405 tree res1, res2, cond, absX, val;
4406 stmtblock_t ifblock1, ifblock2, ifblock3;
4407
4408 gfc_init_block (&ifblock1);
4409
4410 absX = gfc_create_var (type, "absX");
4411 gfc_add_modify (&ifblock1, absX,
4412 fold_build1_loc (input_location, ABS_EXPR, type,
4413 arrayse.expr));
4414 val = gfc_create_var (type, "val");
4415 gfc_add_expr_to_block (&ifblock1, val);
4416
4417 gfc_init_block (&ifblock2);
4418 gfc_add_modify (&ifblock2, val,
4419 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4420 absX));
4421 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4422 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4423 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4424 gfc_build_const (type, integer_one_node));
4425 gfc_add_modify (&ifblock2, resvar, res1);
4426 gfc_add_modify (&ifblock2, scale, absX);
4427 res1 = gfc_finish_block (&ifblock2);
4428
4429 gfc_init_block (&ifblock3);
4430 gfc_add_modify (&ifblock3, val,
4431 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4432 scale));
4433 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4434 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4435 gfc_add_modify (&ifblock3, resvar, res2);
4436 res2 = gfc_finish_block (&ifblock3);
4437
4438 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4439 absX, scale);
4440 tmp = build3_v (COND_EXPR, cond, res1, res2);
4441 gfc_add_expr_to_block (&ifblock1, tmp);
4442 tmp = gfc_finish_block (&ifblock1);
4443
4444 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4445 arrayse.expr,
4446 gfc_build_const (type, integer_zero_node));
4447
4448 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4449 gfc_add_expr_to_block (&block, tmp);
4450 }
4451 else
4452 {
4453 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4454 gfc_add_modify (&block, resvar, tmp);
4455 }
4456
4457 gfc_add_block_to_block (&block, &arrayse.post);
4458
4459 if (maskexpr && maskexpr->rank > 0)
4460 {
4461 /* We enclose the above in if (mask) {...} . */
4462
4463 tmp = gfc_finish_block (&block);
4464 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4465 build_empty_stmt (input_location));
4466 }
4467 else
4468 tmp = gfc_finish_block (&block);
4469 gfc_add_expr_to_block (&body, tmp);
4470
4471 gfc_trans_scalarizing_loops (ploop, &body);
4472
4473 /* For a scalar mask, enclose the loop in an if statement. */
4474 if (maskexpr && maskexpr->rank == 0)
4475 {
4476 gfc_init_block (&block);
4477 gfc_add_block_to_block (&block, &ploop->pre);
4478 gfc_add_block_to_block (&block, &ploop->post);
4479 tmp = gfc_finish_block (&block);
4480
4481 if (expr->rank > 0)
4482 {
4483 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4484 build_empty_stmt (input_location));
4485 gfc_advance_se_ss_chain (se);
4486 }
4487 else
4488 {
4489 gcc_assert (expr->rank == 0);
4490 gfc_init_se (&maskse, NULL);
4491 gfc_conv_expr_val (&maskse, maskexpr);
4492 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4493 build_empty_stmt (input_location));
4494 }
4495
4496 gfc_add_expr_to_block (&block, tmp);
4497 gfc_add_block_to_block (&se->pre, &block);
4498 gcc_assert (se->post.head == NULL);
4499 }
4500 else
4501 {
4502 gfc_add_block_to_block (&se->pre, &ploop->pre);
4503 gfc_add_block_to_block (&se->pre, &ploop->post);
4504 }
4505
4506 if (expr->rank == 0)
4507 gfc_cleanup_loop (ploop);
4508
4509 if (norm2)
4510 {
4511 /* result = scale * sqrt(result). */
4512 tree sqrt;
4513 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4514 resvar = build_call_expr_loc (input_location,
4515 sqrt, 1, resvar);
4516 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4517 }
4518
4519 se->expr = resvar;
4520 }
4521
4522
4523 /* Inline implementation of the dot_product intrinsic. This function
4524 is based on gfc_conv_intrinsic_arith (the previous function). */
4525 static void
gfc_conv_intrinsic_dot_product(gfc_se * se,gfc_expr * expr)4526 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4527 {
4528 tree resvar;
4529 tree type;
4530 stmtblock_t body;
4531 stmtblock_t block;
4532 tree tmp;
4533 gfc_loopinfo loop;
4534 gfc_actual_arglist *actual;
4535 gfc_ss *arrayss1, *arrayss2;
4536 gfc_se arrayse1, arrayse2;
4537 gfc_expr *arrayexpr1, *arrayexpr2;
4538
4539 type = gfc_typenode_for_spec (&expr->ts);
4540
4541 /* Initialize the result. */
4542 resvar = gfc_create_var (type, "val");
4543 if (expr->ts.type == BT_LOGICAL)
4544 tmp = build_int_cst (type, 0);
4545 else
4546 tmp = gfc_build_const (type, integer_zero_node);
4547
4548 gfc_add_modify (&se->pre, resvar, tmp);
4549
4550 /* Walk argument #1. */
4551 actual = expr->value.function.actual;
4552 arrayexpr1 = actual->expr;
4553 arrayss1 = gfc_walk_expr (arrayexpr1);
4554 gcc_assert (arrayss1 != gfc_ss_terminator);
4555
4556 /* Walk argument #2. */
4557 actual = actual->next;
4558 arrayexpr2 = actual->expr;
4559 arrayss2 = gfc_walk_expr (arrayexpr2);
4560 gcc_assert (arrayss2 != gfc_ss_terminator);
4561
4562 /* Initialize the scalarizer. */
4563 gfc_init_loopinfo (&loop);
4564 gfc_add_ss_to_loop (&loop, arrayss1);
4565 gfc_add_ss_to_loop (&loop, arrayss2);
4566
4567 /* Initialize the loop. */
4568 gfc_conv_ss_startstride (&loop);
4569 gfc_conv_loop_setup (&loop, &expr->where);
4570
4571 gfc_mark_ss_chain_used (arrayss1, 1);
4572 gfc_mark_ss_chain_used (arrayss2, 1);
4573
4574 /* Generate the loop body. */
4575 gfc_start_scalarized_body (&loop, &body);
4576 gfc_init_block (&block);
4577
4578 /* Make the tree expression for [conjg(]array1[)]. */
4579 gfc_init_se (&arrayse1, NULL);
4580 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4581 arrayse1.ss = arrayss1;
4582 gfc_conv_expr_val (&arrayse1, arrayexpr1);
4583 if (expr->ts.type == BT_COMPLEX)
4584 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4585 arrayse1.expr);
4586 gfc_add_block_to_block (&block, &arrayse1.pre);
4587
4588 /* Make the tree expression for array2. */
4589 gfc_init_se (&arrayse2, NULL);
4590 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4591 arrayse2.ss = arrayss2;
4592 gfc_conv_expr_val (&arrayse2, arrayexpr2);
4593 gfc_add_block_to_block (&block, &arrayse2.pre);
4594
4595 /* Do the actual product and sum. */
4596 if (expr->ts.type == BT_LOGICAL)
4597 {
4598 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4599 arrayse1.expr, arrayse2.expr);
4600 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4601 }
4602 else
4603 {
4604 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4605 arrayse2.expr);
4606 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4607 }
4608 gfc_add_modify (&block, resvar, tmp);
4609
4610 /* Finish up the loop block and the loop. */
4611 tmp = gfc_finish_block (&block);
4612 gfc_add_expr_to_block (&body, tmp);
4613
4614 gfc_trans_scalarizing_loops (&loop, &body);
4615 gfc_add_block_to_block (&se->pre, &loop.pre);
4616 gfc_add_block_to_block (&se->pre, &loop.post);
4617 gfc_cleanup_loop (&loop);
4618
4619 se->expr = resvar;
4620 }
4621
4622
4623 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4624 we need to handle. For performance reasons we sometimes create two
4625 loops instead of one, where the second one is much simpler.
4626 Examples for minloc intrinsic:
4627 1) Result is an array, a call is generated
4628 2) Array mask is used and NaNs need to be supported:
4629 limit = Infinity;
4630 pos = 0;
4631 S = from;
4632 while (S <= to) {
4633 if (mask[S]) {
4634 if (pos == 0) pos = S + (1 - from);
4635 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4636 }
4637 S++;
4638 }
4639 goto lab2;
4640 lab1:;
4641 while (S <= to) {
4642 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4643 S++;
4644 }
4645 lab2:;
4646 3) NaNs need to be supported, but it is known at compile time or cheaply
4647 at runtime whether array is nonempty or not:
4648 limit = Infinity;
4649 pos = 0;
4650 S = from;
4651 while (S <= to) {
4652 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4653 S++;
4654 }
4655 if (from <= to) pos = 1;
4656 goto lab2;
4657 lab1:;
4658 while (S <= to) {
4659 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4660 S++;
4661 }
4662 lab2:;
4663 4) NaNs aren't supported, array mask is used:
4664 limit = infinities_supported ? Infinity : huge (limit);
4665 pos = 0;
4666 S = from;
4667 while (S <= to) {
4668 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4669 S++;
4670 }
4671 goto lab2;
4672 lab1:;
4673 while (S <= to) {
4674 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4675 S++;
4676 }
4677 lab2:;
4678 5) Same without array mask:
4679 limit = infinities_supported ? Infinity : huge (limit);
4680 pos = (from <= to) ? 1 : 0;
4681 S = from;
4682 while (S <= to) {
4683 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4684 S++;
4685 }
4686 For 3) and 5), if mask is scalar, this all goes into a conditional,
4687 setting pos = 0; in the else branch. */
4688
4689 static void
gfc_conv_intrinsic_minmaxloc(gfc_se * se,gfc_expr * expr,enum tree_code op)4690 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4691 {
4692 stmtblock_t body;
4693 stmtblock_t block;
4694 stmtblock_t ifblock;
4695 stmtblock_t elseblock;
4696 tree limit;
4697 tree type;
4698 tree tmp;
4699 tree cond;
4700 tree elsetmp;
4701 tree ifbody;
4702 tree offset;
4703 tree nonempty;
4704 tree lab1, lab2;
4705 gfc_loopinfo loop;
4706 gfc_actual_arglist *actual;
4707 gfc_ss *arrayss;
4708 gfc_ss *maskss;
4709 gfc_se arrayse;
4710 gfc_se maskse;
4711 gfc_expr *arrayexpr;
4712 gfc_expr *maskexpr;
4713 tree pos;
4714 int n;
4715
4716 actual = expr->value.function.actual;
4717
4718 /* The last argument, BACK, is passed by value. Ensure that
4719 by setting its name to %VAL. */
4720 for (gfc_actual_arglist *a = actual; a; a = a->next)
4721 {
4722 if (a->next == NULL)
4723 a->name = "%VAL";
4724 }
4725
4726 if (se->ss)
4727 {
4728 gfc_conv_intrinsic_funcall (se, expr);
4729 return;
4730 }
4731
4732 arrayexpr = actual->expr;
4733
4734 /* Special case for character maxloc. Remove unneeded actual
4735 arguments, then call a library function. */
4736
4737 if (arrayexpr->ts.type == BT_CHARACTER)
4738 {
4739 gfc_actual_arglist *a, *b;
4740 a = actual;
4741 while (a->next)
4742 {
4743 b = a->next;
4744 if (b->expr == NULL || strcmp (b->name, "dim") == 0)
4745 {
4746 a->next = b->next;
4747 b->next = NULL;
4748 gfc_free_actual_arglist (b);
4749 }
4750 else
4751 a = b;
4752 }
4753 gfc_conv_intrinsic_funcall (se, expr);
4754 return;
4755 }
4756
4757 /* Initialize the result. */
4758 pos = gfc_create_var (gfc_array_index_type, "pos");
4759 offset = gfc_create_var (gfc_array_index_type, "offset");
4760 type = gfc_typenode_for_spec (&expr->ts);
4761
4762 /* Walk the arguments. */
4763 arrayss = gfc_walk_expr (arrayexpr);
4764 gcc_assert (arrayss != gfc_ss_terminator);
4765
4766 actual = actual->next->next;
4767 gcc_assert (actual);
4768 maskexpr = actual->expr;
4769 nonempty = NULL;
4770 if (maskexpr && maskexpr->rank != 0)
4771 {
4772 maskss = gfc_walk_expr (maskexpr);
4773 gcc_assert (maskss != gfc_ss_terminator);
4774 }
4775 else
4776 {
4777 mpz_t asize;
4778 if (gfc_array_size (arrayexpr, &asize))
4779 {
4780 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
4781 mpz_clear (asize);
4782 nonempty = fold_build2_loc (input_location, GT_EXPR,
4783 logical_type_node, nonempty,
4784 gfc_index_zero_node);
4785 }
4786 maskss = NULL;
4787 }
4788
4789 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
4790 switch (arrayexpr->ts.type)
4791 {
4792 case BT_REAL:
4793 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
4794 break;
4795
4796 case BT_INTEGER:
4797 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
4798 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
4799 arrayexpr->ts.kind);
4800 break;
4801
4802 default:
4803 gcc_unreachable ();
4804 }
4805
4806 /* We start with the most negative possible value for MAXLOC, and the most
4807 positive possible value for MINLOC. The most negative possible value is
4808 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4809 possible value is HUGE in both cases. */
4810 if (op == GT_EXPR)
4811 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
4812 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
4813 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
4814 build_int_cst (TREE_TYPE (tmp), 1));
4815
4816 gfc_add_modify (&se->pre, limit, tmp);
4817
4818 /* Initialize the scalarizer. */
4819 gfc_init_loopinfo (&loop);
4820 gfc_add_ss_to_loop (&loop, arrayss);
4821 if (maskss)
4822 gfc_add_ss_to_loop (&loop, maskss);
4823
4824 /* Initialize the loop. */
4825 gfc_conv_ss_startstride (&loop);
4826
4827 /* The code generated can have more than one loop in sequence (see the
4828 comment at the function header). This doesn't work well with the
4829 scalarizer, which changes arrays' offset when the scalarization loops
4830 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
4831 are currently inlined in the scalar case only (for which loop is of rank
4832 one). As there is no dependency to care about in that case, there is no
4833 temporary, so that we can use the scalarizer temporary code to handle
4834 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4835 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4836 to restore offset.
4837 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4838 should eventually go away. We could either create two loops properly,
4839 or find another way to save/restore the array offsets between the two
4840 loops (without conflicting with temporary management), or use a single
4841 loop minmaxloc implementation. See PR 31067. */
4842 loop.temp_dim = loop.dimen;
4843 gfc_conv_loop_setup (&loop, &expr->where);
4844
4845 gcc_assert (loop.dimen == 1);
4846 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
4847 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4848 loop.from[0], loop.to[0]);
4849
4850 lab1 = NULL;
4851 lab2 = NULL;
4852 /* Initialize the position to zero, following Fortran 2003. We are free
4853 to do this because Fortran 95 allows the result of an entirely false
4854 mask to be processor dependent. If we know at compile time the array
4855 is non-empty and no MASK is used, we can initialize to 1 to simplify
4856 the inner loop. */
4857 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
4858 gfc_add_modify (&loop.pre, pos,
4859 fold_build3_loc (input_location, COND_EXPR,
4860 gfc_array_index_type,
4861 nonempty, gfc_index_one_node,
4862 gfc_index_zero_node));
4863 else
4864 {
4865 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
4866 lab1 = gfc_build_label_decl (NULL_TREE);
4867 TREE_USED (lab1) = 1;
4868 lab2 = gfc_build_label_decl (NULL_TREE);
4869 TREE_USED (lab2) = 1;
4870 }
4871
4872 /* An offset must be added to the loop
4873 counter to obtain the required position. */
4874 gcc_assert (loop.from[0]);
4875
4876 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4877 gfc_index_one_node, loop.from[0]);
4878 gfc_add_modify (&loop.pre, offset, tmp);
4879
4880 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
4881 if (maskss)
4882 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
4883 /* Generate the loop body. */
4884 gfc_start_scalarized_body (&loop, &body);
4885
4886 /* If we have a mask, only check this element if the mask is set. */
4887 if (maskss)
4888 {
4889 gfc_init_se (&maskse, NULL);
4890 gfc_copy_loopinfo_to_se (&maskse, &loop);
4891 maskse.ss = maskss;
4892 gfc_conv_expr_val (&maskse, maskexpr);
4893 gfc_add_block_to_block (&body, &maskse.pre);
4894
4895 gfc_start_block (&block);
4896 }
4897 else
4898 gfc_init_block (&block);
4899
4900 /* Compare with the current limit. */
4901 gfc_init_se (&arrayse, NULL);
4902 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4903 arrayse.ss = arrayss;
4904 gfc_conv_expr_val (&arrayse, arrayexpr);
4905 gfc_add_block_to_block (&block, &arrayse.pre);
4906
4907 /* We do the following if this is a more extreme value. */
4908 gfc_start_block (&ifblock);
4909
4910 /* Assign the value to the limit... */
4911 gfc_add_modify (&ifblock, limit, arrayse.expr);
4912
4913 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
4914 {
4915 stmtblock_t ifblock2;
4916 tree ifbody2;
4917
4918 gfc_start_block (&ifblock2);
4919 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4920 loop.loopvar[0], offset);
4921 gfc_add_modify (&ifblock2, pos, tmp);
4922 ifbody2 = gfc_finish_block (&ifblock2);
4923 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
4924 gfc_index_zero_node);
4925 tmp = build3_v (COND_EXPR, cond, ifbody2,
4926 build_empty_stmt (input_location));
4927 gfc_add_expr_to_block (&block, tmp);
4928 }
4929
4930 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4931 loop.loopvar[0], offset);
4932 gfc_add_modify (&ifblock, pos, tmp);
4933
4934 if (lab1)
4935 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
4936
4937 ifbody = gfc_finish_block (&ifblock);
4938
4939 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
4940 {
4941 if (lab1)
4942 cond = fold_build2_loc (input_location,
4943 op == GT_EXPR ? GE_EXPR : LE_EXPR,
4944 logical_type_node, arrayse.expr, limit);
4945 else
4946 cond = fold_build2_loc (input_location, op, logical_type_node,
4947 arrayse.expr, limit);
4948
4949 ifbody = build3_v (COND_EXPR, cond, ifbody,
4950 build_empty_stmt (input_location));
4951 }
4952 gfc_add_expr_to_block (&block, ifbody);
4953
4954 if (maskss)
4955 {
4956 /* We enclose the above in if (mask) {...}. */
4957 tmp = gfc_finish_block (&block);
4958
4959 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4960 build_empty_stmt (input_location));
4961 }
4962 else
4963 tmp = gfc_finish_block (&block);
4964 gfc_add_expr_to_block (&body, tmp);
4965
4966 if (lab1)
4967 {
4968 gfc_trans_scalarized_loop_boundary (&loop, &body);
4969
4970 if (HONOR_NANS (DECL_MODE (limit)))
4971 {
4972 if (nonempty != NULL)
4973 {
4974 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
4975 tmp = build3_v (COND_EXPR, nonempty, ifbody,
4976 build_empty_stmt (input_location));
4977 gfc_add_expr_to_block (&loop.code[0], tmp);
4978 }
4979 }
4980
4981 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
4982 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
4983
4984 /* If we have a mask, only check this element if the mask is set. */
4985 if (maskss)
4986 {
4987 gfc_init_se (&maskse, NULL);
4988 gfc_copy_loopinfo_to_se (&maskse, &loop);
4989 maskse.ss = maskss;
4990 gfc_conv_expr_val (&maskse, maskexpr);
4991 gfc_add_block_to_block (&body, &maskse.pre);
4992
4993 gfc_start_block (&block);
4994 }
4995 else
4996 gfc_init_block (&block);
4997
4998 /* Compare with the current limit. */
4999 gfc_init_se (&arrayse, NULL);
5000 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5001 arrayse.ss = arrayss;
5002 gfc_conv_expr_val (&arrayse, arrayexpr);
5003 gfc_add_block_to_block (&block, &arrayse.pre);
5004
5005 /* We do the following if this is a more extreme value. */
5006 gfc_start_block (&ifblock);
5007
5008 /* Assign the value to the limit... */
5009 gfc_add_modify (&ifblock, limit, arrayse.expr);
5010
5011 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5012 loop.loopvar[0], offset);
5013 gfc_add_modify (&ifblock, pos, tmp);
5014
5015 ifbody = gfc_finish_block (&ifblock);
5016
5017 cond = fold_build2_loc (input_location, op, logical_type_node,
5018 arrayse.expr, limit);
5019
5020 tmp = build3_v (COND_EXPR, cond, ifbody,
5021 build_empty_stmt (input_location));
5022 gfc_add_expr_to_block (&block, tmp);
5023
5024 if (maskss)
5025 {
5026 /* We enclose the above in if (mask) {...}. */
5027 tmp = gfc_finish_block (&block);
5028
5029 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5030 build_empty_stmt (input_location));
5031 }
5032 else
5033 tmp = gfc_finish_block (&block);
5034 gfc_add_expr_to_block (&body, tmp);
5035 /* Avoid initializing loopvar[0] again, it should be left where
5036 it finished by the first loop. */
5037 loop.from[0] = loop.loopvar[0];
5038 }
5039
5040 gfc_trans_scalarizing_loops (&loop, &body);
5041
5042 if (lab2)
5043 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
5044
5045 /* For a scalar mask, enclose the loop in an if statement. */
5046 if (maskexpr && maskss == NULL)
5047 {
5048 gfc_init_se (&maskse, NULL);
5049 gfc_conv_expr_val (&maskse, maskexpr);
5050 gfc_init_block (&block);
5051 gfc_add_block_to_block (&block, &loop.pre);
5052 gfc_add_block_to_block (&block, &loop.post);
5053 tmp = gfc_finish_block (&block);
5054
5055 /* For the else part of the scalar mask, just initialize
5056 the pos variable the same way as above. */
5057
5058 gfc_init_block (&elseblock);
5059 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
5060 elsetmp = gfc_finish_block (&elseblock);
5061
5062 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
5063 gfc_add_expr_to_block (&block, tmp);
5064 gfc_add_block_to_block (&se->pre, &block);
5065 }
5066 else
5067 {
5068 gfc_add_block_to_block (&se->pre, &loop.pre);
5069 gfc_add_block_to_block (&se->pre, &loop.post);
5070 }
5071 gfc_cleanup_loop (&loop);
5072
5073 se->expr = convert (type, pos);
5074 }
5075
5076 /* Emit code for minval or maxval intrinsic. There are many different cases
5077 we need to handle. For performance reasons we sometimes create two
5078 loops instead of one, where the second one is much simpler.
5079 Examples for minval intrinsic:
5080 1) Result is an array, a call is generated
5081 2) Array mask is used and NaNs need to be supported, rank 1:
5082 limit = Infinity;
5083 nonempty = false;
5084 S = from;
5085 while (S <= to) {
5086 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5087 S++;
5088 }
5089 limit = nonempty ? NaN : huge (limit);
5090 lab:
5091 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5092 3) NaNs need to be supported, but it is known at compile time or cheaply
5093 at runtime whether array is nonempty or not, rank 1:
5094 limit = Infinity;
5095 S = from;
5096 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5097 limit = (from <= to) ? NaN : huge (limit);
5098 lab:
5099 while (S <= to) { limit = min (a[S], limit); S++; }
5100 4) Array mask is used and NaNs need to be supported, rank > 1:
5101 limit = Infinity;
5102 nonempty = false;
5103 fast = false;
5104 S1 = from1;
5105 while (S1 <= to1) {
5106 S2 = from2;
5107 while (S2 <= to2) {
5108 if (mask[S1][S2]) {
5109 if (fast) limit = min (a[S1][S2], limit);
5110 else {
5111 nonempty = true;
5112 if (a[S1][S2] <= limit) {
5113 limit = a[S1][S2];
5114 fast = true;
5115 }
5116 }
5117 }
5118 S2++;
5119 }
5120 S1++;
5121 }
5122 if (!fast)
5123 limit = nonempty ? NaN : huge (limit);
5124 5) NaNs need to be supported, but it is known at compile time or cheaply
5125 at runtime whether array is nonempty or not, rank > 1:
5126 limit = Infinity;
5127 fast = false;
5128 S1 = from1;
5129 while (S1 <= to1) {
5130 S2 = from2;
5131 while (S2 <= to2) {
5132 if (fast) limit = min (a[S1][S2], limit);
5133 else {
5134 if (a[S1][S2] <= limit) {
5135 limit = a[S1][S2];
5136 fast = true;
5137 }
5138 }
5139 S2++;
5140 }
5141 S1++;
5142 }
5143 if (!fast)
5144 limit = (nonempty_array) ? NaN : huge (limit);
5145 6) NaNs aren't supported, but infinities are. Array mask is used:
5146 limit = Infinity;
5147 nonempty = false;
5148 S = from;
5149 while (S <= to) {
5150 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5151 S++;
5152 }
5153 limit = nonempty ? limit : huge (limit);
5154 7) Same without array mask:
5155 limit = Infinity;
5156 S = from;
5157 while (S <= to) { limit = min (a[S], limit); S++; }
5158 limit = (from <= to) ? limit : huge (limit);
5159 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5160 limit = huge (limit);
5161 S = from;
5162 while (S <= to) { limit = min (a[S], limit); S++); }
5163 (or
5164 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5165 with array mask instead).
5166 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5167 setting limit = huge (limit); in the else branch. */
5168
5169 static void
gfc_conv_intrinsic_minmaxval(gfc_se * se,gfc_expr * expr,enum tree_code op)5170 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
5171 {
5172 tree limit;
5173 tree type;
5174 tree tmp;
5175 tree ifbody;
5176 tree nonempty;
5177 tree nonempty_var;
5178 tree lab;
5179 tree fast;
5180 tree huge_cst = NULL, nan_cst = NULL;
5181 stmtblock_t body;
5182 stmtblock_t block, block2;
5183 gfc_loopinfo loop;
5184 gfc_actual_arglist *actual;
5185 gfc_ss *arrayss;
5186 gfc_ss *maskss;
5187 gfc_se arrayse;
5188 gfc_se maskse;
5189 gfc_expr *arrayexpr;
5190 gfc_expr *maskexpr;
5191 int n;
5192
5193 if (se->ss)
5194 {
5195 gfc_conv_intrinsic_funcall (se, expr);
5196 return;
5197 }
5198
5199 actual = expr->value.function.actual;
5200 arrayexpr = actual->expr;
5201
5202 if (arrayexpr->ts.type == BT_CHARACTER)
5203 {
5204 gfc_actual_arglist *a2, *a3;
5205 a2 = actual->next; /* dim */
5206 a3 = a2->next; /* mask */
5207 if (a2->expr == NULL || expr->rank == 0)
5208 {
5209 if (a3->expr == NULL)
5210 actual->next = NULL;
5211 else
5212 {
5213 actual->next = a3;
5214 a2->next = NULL;
5215 }
5216 gfc_free_actual_arglist (a2);
5217 }
5218 else
5219 if (a3->expr == NULL)
5220 {
5221 a2->next = NULL;
5222 gfc_free_actual_arglist (a3);
5223 }
5224 gfc_conv_intrinsic_funcall (se, expr);
5225 return;
5226 }
5227 type = gfc_typenode_for_spec (&expr->ts);
5228 /* Initialize the result. */
5229 limit = gfc_create_var (type, "limit");
5230 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
5231 switch (expr->ts.type)
5232 {
5233 case BT_REAL:
5234 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
5235 expr->ts.kind, 0);
5236 if (HONOR_INFINITIES (DECL_MODE (limit)))
5237 {
5238 REAL_VALUE_TYPE real;
5239 real_inf (&real);
5240 tmp = build_real (type, real);
5241 }
5242 else
5243 tmp = huge_cst;
5244 if (HONOR_NANS (DECL_MODE (limit)))
5245 nan_cst = gfc_build_nan (type, "");
5246 break;
5247
5248 case BT_INTEGER:
5249 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
5250 break;
5251
5252 default:
5253 gcc_unreachable ();
5254 }
5255
5256 /* We start with the most negative possible value for MAXVAL, and the most
5257 positive possible value for MINVAL. The most negative possible value is
5258 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5259 possible value is HUGE in both cases. */
5260 if (op == GT_EXPR)
5261 {
5262 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5263 if (huge_cst)
5264 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
5265 TREE_TYPE (huge_cst), huge_cst);
5266 }
5267
5268 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
5269 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5270 tmp, build_int_cst (type, 1));
5271
5272 gfc_add_modify (&se->pre, limit, tmp);
5273
5274 /* Walk the arguments. */
5275 arrayss = gfc_walk_expr (arrayexpr);
5276 gcc_assert (arrayss != gfc_ss_terminator);
5277
5278 actual = actual->next->next;
5279 gcc_assert (actual);
5280 maskexpr = actual->expr;
5281 nonempty = NULL;
5282 if (maskexpr && maskexpr->rank != 0)
5283 {
5284 maskss = gfc_walk_expr (maskexpr);
5285 gcc_assert (maskss != gfc_ss_terminator);
5286 }
5287 else
5288 {
5289 mpz_t asize;
5290 if (gfc_array_size (arrayexpr, &asize))
5291 {
5292 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5293 mpz_clear (asize);
5294 nonempty = fold_build2_loc (input_location, GT_EXPR,
5295 logical_type_node, nonempty,
5296 gfc_index_zero_node);
5297 }
5298 maskss = NULL;
5299 }
5300
5301 /* Initialize the scalarizer. */
5302 gfc_init_loopinfo (&loop);
5303 gfc_add_ss_to_loop (&loop, arrayss);
5304 if (maskss)
5305 gfc_add_ss_to_loop (&loop, maskss);
5306
5307 /* Initialize the loop. */
5308 gfc_conv_ss_startstride (&loop);
5309
5310 /* The code generated can have more than one loop in sequence (see the
5311 comment at the function header). This doesn't work well with the
5312 scalarizer, which changes arrays' offset when the scalarization loops
5313 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5314 are currently inlined in the scalar case only. As there is no dependency
5315 to care about in that case, there is no temporary, so that we can use the
5316 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5317 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5318 gfc_trans_scalarized_loop_boundary even later to restore offset.
5319 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5320 should eventually go away. We could either create two loops properly,
5321 or find another way to save/restore the array offsets between the two
5322 loops (without conflicting with temporary management), or use a single
5323 loop minmaxval implementation. See PR 31067. */
5324 loop.temp_dim = loop.dimen;
5325 gfc_conv_loop_setup (&loop, &expr->where);
5326
5327 if (nonempty == NULL && maskss == NULL
5328 && loop.dimen == 1 && loop.from[0] && loop.to[0])
5329 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5330 loop.from[0], loop.to[0]);
5331 nonempty_var = NULL;
5332 if (nonempty == NULL
5333 && (HONOR_INFINITIES (DECL_MODE (limit))
5334 || HONOR_NANS (DECL_MODE (limit))))
5335 {
5336 nonempty_var = gfc_create_var (logical_type_node, "nonempty");
5337 gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
5338 nonempty = nonempty_var;
5339 }
5340 lab = NULL;
5341 fast = NULL;
5342 if (HONOR_NANS (DECL_MODE (limit)))
5343 {
5344 if (loop.dimen == 1)
5345 {
5346 lab = gfc_build_label_decl (NULL_TREE);
5347 TREE_USED (lab) = 1;
5348 }
5349 else
5350 {
5351 fast = gfc_create_var (logical_type_node, "fast");
5352 gfc_add_modify (&se->pre, fast, logical_false_node);
5353 }
5354 }
5355
5356 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
5357 if (maskss)
5358 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
5359 /* Generate the loop body. */
5360 gfc_start_scalarized_body (&loop, &body);
5361
5362 /* If we have a mask, only add this element if the mask is set. */
5363 if (maskss)
5364 {
5365 gfc_init_se (&maskse, NULL);
5366 gfc_copy_loopinfo_to_se (&maskse, &loop);
5367 maskse.ss = maskss;
5368 gfc_conv_expr_val (&maskse, maskexpr);
5369 gfc_add_block_to_block (&body, &maskse.pre);
5370
5371 gfc_start_block (&block);
5372 }
5373 else
5374 gfc_init_block (&block);
5375
5376 /* Compare with the current limit. */
5377 gfc_init_se (&arrayse, NULL);
5378 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5379 arrayse.ss = arrayss;
5380 gfc_conv_expr_val (&arrayse, arrayexpr);
5381 gfc_add_block_to_block (&block, &arrayse.pre);
5382
5383 gfc_init_block (&block2);
5384
5385 if (nonempty_var)
5386 gfc_add_modify (&block2, nonempty_var, logical_true_node);
5387
5388 if (HONOR_NANS (DECL_MODE (limit)))
5389 {
5390 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5391 logical_type_node, arrayse.expr, limit);
5392 if (lab)
5393 ifbody = build1_v (GOTO_EXPR, lab);
5394 else
5395 {
5396 stmtblock_t ifblock;
5397
5398 gfc_init_block (&ifblock);
5399 gfc_add_modify (&ifblock, limit, arrayse.expr);
5400 gfc_add_modify (&ifblock, fast, logical_true_node);
5401 ifbody = gfc_finish_block (&ifblock);
5402 }
5403 tmp = build3_v (COND_EXPR, tmp, ifbody,
5404 build_empty_stmt (input_location));
5405 gfc_add_expr_to_block (&block2, tmp);
5406 }
5407 else
5408 {
5409 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5410 signed zeros. */
5411 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5412 {
5413 tmp = fold_build2_loc (input_location, op, logical_type_node,
5414 arrayse.expr, limit);
5415 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5416 tmp = build3_v (COND_EXPR, tmp, ifbody,
5417 build_empty_stmt (input_location));
5418 gfc_add_expr_to_block (&block2, tmp);
5419 }
5420 else
5421 {
5422 tmp = fold_build2_loc (input_location,
5423 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5424 type, arrayse.expr, limit);
5425 gfc_add_modify (&block2, limit, tmp);
5426 }
5427 }
5428
5429 if (fast)
5430 {
5431 tree elsebody = gfc_finish_block (&block2);
5432
5433 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5434 signed zeros. */
5435 if (HONOR_NANS (DECL_MODE (limit))
5436 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5437 {
5438 tmp = fold_build2_loc (input_location, op, logical_type_node,
5439 arrayse.expr, limit);
5440 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5441 ifbody = build3_v (COND_EXPR, tmp, ifbody,
5442 build_empty_stmt (input_location));
5443 }
5444 else
5445 {
5446 tmp = fold_build2_loc (input_location,
5447 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5448 type, arrayse.expr, limit);
5449 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5450 }
5451 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
5452 gfc_add_expr_to_block (&block, tmp);
5453 }
5454 else
5455 gfc_add_block_to_block (&block, &block2);
5456
5457 gfc_add_block_to_block (&block, &arrayse.post);
5458
5459 tmp = gfc_finish_block (&block);
5460 if (maskss)
5461 /* We enclose the above in if (mask) {...}. */
5462 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5463 build_empty_stmt (input_location));
5464 gfc_add_expr_to_block (&body, tmp);
5465
5466 if (lab)
5467 {
5468 gfc_trans_scalarized_loop_boundary (&loop, &body);
5469
5470 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5471 nan_cst, huge_cst);
5472 gfc_add_modify (&loop.code[0], limit, tmp);
5473 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
5474
5475 /* If we have a mask, only add this element if the mask is set. */
5476 if (maskss)
5477 {
5478 gfc_init_se (&maskse, NULL);
5479 gfc_copy_loopinfo_to_se (&maskse, &loop);
5480 maskse.ss = maskss;
5481 gfc_conv_expr_val (&maskse, maskexpr);
5482 gfc_add_block_to_block (&body, &maskse.pre);
5483
5484 gfc_start_block (&block);
5485 }
5486 else
5487 gfc_init_block (&block);
5488
5489 /* Compare with the current limit. */
5490 gfc_init_se (&arrayse, NULL);
5491 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5492 arrayse.ss = arrayss;
5493 gfc_conv_expr_val (&arrayse, arrayexpr);
5494 gfc_add_block_to_block (&block, &arrayse.pre);
5495
5496 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5497 signed zeros. */
5498 if (HONOR_NANS (DECL_MODE (limit))
5499 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5500 {
5501 tmp = fold_build2_loc (input_location, op, logical_type_node,
5502 arrayse.expr, limit);
5503 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5504 tmp = build3_v (COND_EXPR, tmp, ifbody,
5505 build_empty_stmt (input_location));
5506 gfc_add_expr_to_block (&block, tmp);
5507 }
5508 else
5509 {
5510 tmp = fold_build2_loc (input_location,
5511 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5512 type, arrayse.expr, limit);
5513 gfc_add_modify (&block, limit, tmp);
5514 }
5515
5516 gfc_add_block_to_block (&block, &arrayse.post);
5517
5518 tmp = gfc_finish_block (&block);
5519 if (maskss)
5520 /* We enclose the above in if (mask) {...}. */
5521 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5522 build_empty_stmt (input_location));
5523 gfc_add_expr_to_block (&body, tmp);
5524 /* Avoid initializing loopvar[0] again, it should be left where
5525 it finished by the first loop. */
5526 loop.from[0] = loop.loopvar[0];
5527 }
5528 gfc_trans_scalarizing_loops (&loop, &body);
5529
5530 if (fast)
5531 {
5532 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5533 nan_cst, huge_cst);
5534 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5535 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
5536 ifbody);
5537 gfc_add_expr_to_block (&loop.pre, tmp);
5538 }
5539 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
5540 {
5541 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
5542 huge_cst);
5543 gfc_add_modify (&loop.pre, limit, tmp);
5544 }
5545
5546 /* For a scalar mask, enclose the loop in an if statement. */
5547 if (maskexpr && maskss == NULL)
5548 {
5549 tree else_stmt;
5550
5551 gfc_init_se (&maskse, NULL);
5552 gfc_conv_expr_val (&maskse, maskexpr);
5553 gfc_init_block (&block);
5554 gfc_add_block_to_block (&block, &loop.pre);
5555 gfc_add_block_to_block (&block, &loop.post);
5556 tmp = gfc_finish_block (&block);
5557
5558 if (HONOR_INFINITIES (DECL_MODE (limit)))
5559 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
5560 else
5561 else_stmt = build_empty_stmt (input_location);
5562 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
5563 gfc_add_expr_to_block (&block, tmp);
5564 gfc_add_block_to_block (&se->pre, &block);
5565 }
5566 else
5567 {
5568 gfc_add_block_to_block (&se->pre, &loop.pre);
5569 gfc_add_block_to_block (&se->pre, &loop.post);
5570 }
5571
5572 gfc_cleanup_loop (&loop);
5573
5574 se->expr = limit;
5575 }
5576
5577 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
5578 static void
gfc_conv_intrinsic_btest(gfc_se * se,gfc_expr * expr)5579 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
5580 {
5581 tree args[2];
5582 tree type;
5583 tree tmp;
5584
5585 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5586 type = TREE_TYPE (args[0]);
5587
5588 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5589 build_int_cst (type, 1), args[1]);
5590 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
5591 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
5592 build_int_cst (type, 0));
5593 type = gfc_typenode_for_spec (&expr->ts);
5594 se->expr = convert (type, tmp);
5595 }
5596
5597
5598 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
5599 static void
gfc_conv_intrinsic_bitcomp(gfc_se * se,gfc_expr * expr,enum tree_code op)5600 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5601 {
5602 tree args[2];
5603
5604 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5605
5606 /* Convert both arguments to the unsigned type of the same size. */
5607 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
5608 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
5609
5610 /* If they have unequal type size, convert to the larger one. */
5611 if (TYPE_PRECISION (TREE_TYPE (args[0]))
5612 > TYPE_PRECISION (TREE_TYPE (args[1])))
5613 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
5614 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
5615 > TYPE_PRECISION (TREE_TYPE (args[0])))
5616 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
5617
5618 /* Now, we compare them. */
5619 se->expr = fold_build2_loc (input_location, op, logical_type_node,
5620 args[0], args[1]);
5621 }
5622
5623
5624 /* Generate code to perform the specified operation. */
5625 static void
gfc_conv_intrinsic_bitop(gfc_se * se,gfc_expr * expr,enum tree_code op)5626 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
5627 {
5628 tree args[2];
5629
5630 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5631 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
5632 args[0], args[1]);
5633 }
5634
5635 /* Bitwise not. */
5636 static void
gfc_conv_intrinsic_not(gfc_se * se,gfc_expr * expr)5637 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
5638 {
5639 tree arg;
5640
5641 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5642 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
5643 TREE_TYPE (arg), arg);
5644 }
5645
5646 /* Set or clear a single bit. */
5647 static void
gfc_conv_intrinsic_singlebitop(gfc_se * se,gfc_expr * expr,int set)5648 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
5649 {
5650 tree args[2];
5651 tree type;
5652 tree tmp;
5653 enum tree_code op;
5654
5655 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5656 type = TREE_TYPE (args[0]);
5657
5658 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5659 build_int_cst (type, 1), args[1]);
5660 if (set)
5661 op = BIT_IOR_EXPR;
5662 else
5663 {
5664 op = BIT_AND_EXPR;
5665 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
5666 }
5667 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
5668 }
5669
5670 /* Extract a sequence of bits.
5671 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
5672 static void
gfc_conv_intrinsic_ibits(gfc_se * se,gfc_expr * expr)5673 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
5674 {
5675 tree args[3];
5676 tree type;
5677 tree tmp;
5678 tree mask;
5679
5680 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5681 type = TREE_TYPE (args[0]);
5682
5683 mask = build_int_cst (type, -1);
5684 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
5685 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
5686
5687 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
5688
5689 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
5690 }
5691
5692 static void
gfc_conv_intrinsic_shape(gfc_se * se,gfc_expr * expr)5693 gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
5694 {
5695 gfc_actual_arglist *s, *k;
5696 gfc_expr *e;
5697
5698 /* Remove the KIND argument, if present. */
5699 s = expr->value.function.actual;
5700 k = s->next;
5701 e = k->expr;
5702 gfc_free_expr (e);
5703 k->expr = NULL;
5704
5705 gfc_conv_intrinsic_funcall (se, expr);
5706 }
5707
5708 static void
gfc_conv_intrinsic_shift(gfc_se * se,gfc_expr * expr,bool right_shift,bool arithmetic)5709 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
5710 bool arithmetic)
5711 {
5712 tree args[2], type, num_bits, cond;
5713
5714 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5715
5716 args[0] = gfc_evaluate_now (args[0], &se->pre);
5717 args[1] = gfc_evaluate_now (args[1], &se->pre);
5718 type = TREE_TYPE (args[0]);
5719
5720 if (!arithmetic)
5721 args[0] = fold_convert (unsigned_type_for (type), args[0]);
5722 else
5723 gcc_assert (right_shift);
5724
5725 se->expr = fold_build2_loc (input_location,
5726 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
5727 TREE_TYPE (args[0]), args[0], args[1]);
5728
5729 if (!arithmetic)
5730 se->expr = fold_convert (type, se->expr);
5731
5732 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5733 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5734 special case. */
5735 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5736 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
5737 args[1], num_bits);
5738
5739 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5740 build_int_cst (type, 0), se->expr);
5741 }
5742
5743 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5744 ? 0
5745 : ((shift >= 0) ? i << shift : i >> -shift)
5746 where all shifts are logical shifts. */
5747 static void
gfc_conv_intrinsic_ishft(gfc_se * se,gfc_expr * expr)5748 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
5749 {
5750 tree args[2];
5751 tree type;
5752 tree utype;
5753 tree tmp;
5754 tree width;
5755 tree num_bits;
5756 tree cond;
5757 tree lshift;
5758 tree rshift;
5759
5760 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5761
5762 args[0] = gfc_evaluate_now (args[0], &se->pre);
5763 args[1] = gfc_evaluate_now (args[1], &se->pre);
5764
5765 type = TREE_TYPE (args[0]);
5766 utype = unsigned_type_for (type);
5767
5768 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
5769 args[1]);
5770
5771 /* Left shift if positive. */
5772 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
5773
5774 /* Right shift if negative.
5775 We convert to an unsigned type because we want a logical shift.
5776 The standard doesn't define the case of shifting negative
5777 numbers, and we try to be compatible with other compilers, most
5778 notably g77, here. */
5779 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
5780 utype, convert (utype, args[0]), width));
5781
5782 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
5783 build_int_cst (TREE_TYPE (args[1]), 0));
5784 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
5785
5786 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5787 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5788 special case. */
5789 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5790 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
5791 num_bits);
5792 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5793 build_int_cst (type, 0), tmp);
5794 }
5795
5796
5797 /* Circular shift. AKA rotate or barrel shift. */
5798
5799 static void
gfc_conv_intrinsic_ishftc(gfc_se * se,gfc_expr * expr)5800 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
5801 {
5802 tree *args;
5803 tree type;
5804 tree tmp;
5805 tree lrot;
5806 tree rrot;
5807 tree zero;
5808 unsigned int num_args;
5809
5810 num_args = gfc_intrinsic_argument_list_length (expr);
5811 args = XALLOCAVEC (tree, num_args);
5812
5813 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
5814
5815 if (num_args == 3)
5816 {
5817 /* Use a library function for the 3 parameter version. */
5818 tree int4type = gfc_get_int_type (4);
5819
5820 type = TREE_TYPE (args[0]);
5821 /* We convert the first argument to at least 4 bytes, and
5822 convert back afterwards. This removes the need for library
5823 functions for all argument sizes, and function will be
5824 aligned to at least 32 bits, so there's no loss. */
5825 if (expr->ts.kind < 4)
5826 args[0] = convert (int4type, args[0]);
5827
5828 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5829 need loads of library functions. They cannot have values >
5830 BIT_SIZE (I) so the conversion is safe. */
5831 args[1] = convert (int4type, args[1]);
5832 args[2] = convert (int4type, args[2]);
5833
5834 switch (expr->ts.kind)
5835 {
5836 case 1:
5837 case 2:
5838 case 4:
5839 tmp = gfor_fndecl_math_ishftc4;
5840 break;
5841 case 8:
5842 tmp = gfor_fndecl_math_ishftc8;
5843 break;
5844 case 16:
5845 tmp = gfor_fndecl_math_ishftc16;
5846 break;
5847 default:
5848 gcc_unreachable ();
5849 }
5850 se->expr = build_call_expr_loc (input_location,
5851 tmp, 3, args[0], args[1], args[2]);
5852 /* Convert the result back to the original type, if we extended
5853 the first argument's width above. */
5854 if (expr->ts.kind < 4)
5855 se->expr = convert (type, se->expr);
5856
5857 return;
5858 }
5859 type = TREE_TYPE (args[0]);
5860
5861 /* Evaluate arguments only once. */
5862 args[0] = gfc_evaluate_now (args[0], &se->pre);
5863 args[1] = gfc_evaluate_now (args[1], &se->pre);
5864
5865 /* Rotate left if positive. */
5866 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
5867
5868 /* Rotate right if negative. */
5869 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
5870 args[1]);
5871 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
5872
5873 zero = build_int_cst (TREE_TYPE (args[1]), 0);
5874 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
5875 zero);
5876 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
5877
5878 /* Do nothing if shift == 0. */
5879 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
5880 zero);
5881 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
5882 rrot);
5883 }
5884
5885
5886 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5887 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5888
5889 The conditional expression is necessary because the result of LEADZ(0)
5890 is defined, but the result of __builtin_clz(0) is undefined for most
5891 targets.
5892
5893 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5894 difference in bit size between the argument of LEADZ and the C int. */
5895
5896 static void
gfc_conv_intrinsic_leadz(gfc_se * se,gfc_expr * expr)5897 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
5898 {
5899 tree arg;
5900 tree arg_type;
5901 tree cond;
5902 tree result_type;
5903 tree leadz;
5904 tree bit_size;
5905 tree tmp;
5906 tree func;
5907 int s, argsize;
5908
5909 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5910 argsize = TYPE_PRECISION (TREE_TYPE (arg));
5911
5912 /* Which variant of __builtin_clz* should we call? */
5913 if (argsize <= INT_TYPE_SIZE)
5914 {
5915 arg_type = unsigned_type_node;
5916 func = builtin_decl_explicit (BUILT_IN_CLZ);
5917 }
5918 else if (argsize <= LONG_TYPE_SIZE)
5919 {
5920 arg_type = long_unsigned_type_node;
5921 func = builtin_decl_explicit (BUILT_IN_CLZL);
5922 }
5923 else if (argsize <= LONG_LONG_TYPE_SIZE)
5924 {
5925 arg_type = long_long_unsigned_type_node;
5926 func = builtin_decl_explicit (BUILT_IN_CLZLL);
5927 }
5928 else
5929 {
5930 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5931 arg_type = gfc_build_uint_type (argsize);
5932 func = NULL_TREE;
5933 }
5934
5935 /* Convert the actual argument twice: first, to the unsigned type of the
5936 same size; then, to the proper argument type for the built-in
5937 function. But the return type is of the default INTEGER kind. */
5938 arg = fold_convert (gfc_build_uint_type (argsize), arg);
5939 arg = fold_convert (arg_type, arg);
5940 arg = gfc_evaluate_now (arg, &se->pre);
5941 result_type = gfc_get_int_type (gfc_default_integer_kind);
5942
5943 /* Compute LEADZ for the case i .ne. 0. */
5944 if (func)
5945 {
5946 s = TYPE_PRECISION (arg_type) - argsize;
5947 tmp = fold_convert (result_type,
5948 build_call_expr_loc (input_location, func,
5949 1, arg));
5950 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
5951 tmp, build_int_cst (result_type, s));
5952 }
5953 else
5954 {
5955 /* We end up here if the argument type is larger than 'long long'.
5956 We generate this code:
5957
5958 if (x & (ULL_MAX << ULL_SIZE) != 0)
5959 return clzll ((unsigned long long) (x >> ULLSIZE));
5960 else
5961 return ULL_SIZE + clzll ((unsigned long long) x);
5962 where ULL_MAX is the largest value that a ULL_MAX can hold
5963 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5964 is the bit-size of the long long type (64 in this example). */
5965 tree ullsize, ullmax, tmp1, tmp2, btmp;
5966
5967 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5968 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5969 long_long_unsigned_type_node,
5970 build_int_cst (long_long_unsigned_type_node,
5971 0));
5972
5973 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
5974 fold_convert (arg_type, ullmax), ullsize);
5975 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
5976 arg, cond);
5977 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
5978 cond, build_int_cst (arg_type, 0));
5979
5980 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5981 arg, ullsize);
5982 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5983 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5984 tmp1 = fold_convert (result_type,
5985 build_call_expr_loc (input_location, btmp, 1, tmp1));
5986
5987 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5988 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5989 tmp2 = fold_convert (result_type,
5990 build_call_expr_loc (input_location, btmp, 1, tmp2));
5991 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5992 tmp2, ullsize);
5993
5994 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
5995 cond, tmp1, tmp2);
5996 }
5997
5998 /* Build BIT_SIZE. */
5999 bit_size = build_int_cst (result_type, argsize);
6000
6001 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6002 arg, build_int_cst (arg_type, 0));
6003 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
6004 bit_size, leadz);
6005 }
6006
6007
6008 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6009
6010 The conditional expression is necessary because the result of TRAILZ(0)
6011 is defined, but the result of __builtin_ctz(0) is undefined for most
6012 targets. */
6013
6014 static void
gfc_conv_intrinsic_trailz(gfc_se * se,gfc_expr * expr)6015 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
6016 {
6017 tree arg;
6018 tree arg_type;
6019 tree cond;
6020 tree result_type;
6021 tree trailz;
6022 tree bit_size;
6023 tree func;
6024 int argsize;
6025
6026 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6027 argsize = TYPE_PRECISION (TREE_TYPE (arg));
6028
6029 /* Which variant of __builtin_ctz* should we call? */
6030 if (argsize <= INT_TYPE_SIZE)
6031 {
6032 arg_type = unsigned_type_node;
6033 func = builtin_decl_explicit (BUILT_IN_CTZ);
6034 }
6035 else if (argsize <= LONG_TYPE_SIZE)
6036 {
6037 arg_type = long_unsigned_type_node;
6038 func = builtin_decl_explicit (BUILT_IN_CTZL);
6039 }
6040 else if (argsize <= LONG_LONG_TYPE_SIZE)
6041 {
6042 arg_type = long_long_unsigned_type_node;
6043 func = builtin_decl_explicit (BUILT_IN_CTZLL);
6044 }
6045 else
6046 {
6047 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
6048 arg_type = gfc_build_uint_type (argsize);
6049 func = NULL_TREE;
6050 }
6051
6052 /* Convert the actual argument twice: first, to the unsigned type of the
6053 same size; then, to the proper argument type for the built-in
6054 function. But the return type is of the default INTEGER kind. */
6055 arg = fold_convert (gfc_build_uint_type (argsize), arg);
6056 arg = fold_convert (arg_type, arg);
6057 arg = gfc_evaluate_now (arg, &se->pre);
6058 result_type = gfc_get_int_type (gfc_default_integer_kind);
6059
6060 /* Compute TRAILZ for the case i .ne. 0. */
6061 if (func)
6062 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
6063 func, 1, arg));
6064 else
6065 {
6066 /* We end up here if the argument type is larger than 'long long'.
6067 We generate this code:
6068
6069 if ((x & ULL_MAX) == 0)
6070 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6071 else
6072 return ctzll ((unsigned long long) x);
6073
6074 where ULL_MAX is the largest value that a ULL_MAX can hold
6075 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6076 is the bit-size of the long long type (64 in this example). */
6077 tree ullsize, ullmax, tmp1, tmp2, btmp;
6078
6079 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
6080 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
6081 long_long_unsigned_type_node,
6082 build_int_cst (long_long_unsigned_type_node, 0));
6083
6084 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
6085 fold_convert (arg_type, ullmax));
6086 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
6087 build_int_cst (arg_type, 0));
6088
6089 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
6090 arg, ullsize);
6091 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
6092 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
6093 tmp1 = fold_convert (result_type,
6094 build_call_expr_loc (input_location, btmp, 1, tmp1));
6095 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
6096 tmp1, ullsize);
6097
6098 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
6099 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
6100 tmp2 = fold_convert (result_type,
6101 build_call_expr_loc (input_location, btmp, 1, tmp2));
6102
6103 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
6104 cond, tmp1, tmp2);
6105 }
6106
6107 /* Build BIT_SIZE. */
6108 bit_size = build_int_cst (result_type, argsize);
6109
6110 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6111 arg, build_int_cst (arg_type, 0));
6112 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
6113 bit_size, trailz);
6114 }
6115
6116 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6117 for types larger than "long long", we call the long long built-in for
6118 the lower and higher bits and combine the result. */
6119
6120 static void
gfc_conv_intrinsic_popcnt_poppar(gfc_se * se,gfc_expr * expr,int parity)6121 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
6122 {
6123 tree arg;
6124 tree arg_type;
6125 tree result_type;
6126 tree func;
6127 int argsize;
6128
6129 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6130 argsize = TYPE_PRECISION (TREE_TYPE (arg));
6131 result_type = gfc_get_int_type (gfc_default_integer_kind);
6132
6133 /* Which variant of the builtin should we call? */
6134 if (argsize <= INT_TYPE_SIZE)
6135 {
6136 arg_type = unsigned_type_node;
6137 func = builtin_decl_explicit (parity
6138 ? BUILT_IN_PARITY
6139 : BUILT_IN_POPCOUNT);
6140 }
6141 else if (argsize <= LONG_TYPE_SIZE)
6142 {
6143 arg_type = long_unsigned_type_node;
6144 func = builtin_decl_explicit (parity
6145 ? BUILT_IN_PARITYL
6146 : BUILT_IN_POPCOUNTL);
6147 }
6148 else if (argsize <= LONG_LONG_TYPE_SIZE)
6149 {
6150 arg_type = long_long_unsigned_type_node;
6151 func = builtin_decl_explicit (parity
6152 ? BUILT_IN_PARITYLL
6153 : BUILT_IN_POPCOUNTLL);
6154 }
6155 else
6156 {
6157 /* Our argument type is larger than 'long long', which mean none
6158 of the POPCOUNT builtins covers it. We thus call the 'long long'
6159 variant multiple times, and add the results. */
6160 tree utype, arg2, call1, call2;
6161
6162 /* For now, we only cover the case where argsize is twice as large
6163 as 'long long'. */
6164 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
6165
6166 func = builtin_decl_explicit (parity
6167 ? BUILT_IN_PARITYLL
6168 : BUILT_IN_POPCOUNTLL);
6169
6170 /* Convert it to an integer, and store into a variable. */
6171 utype = gfc_build_uint_type (argsize);
6172 arg = fold_convert (utype, arg);
6173 arg = gfc_evaluate_now (arg, &se->pre);
6174
6175 /* Call the builtin twice. */
6176 call1 = build_call_expr_loc (input_location, func, 1,
6177 fold_convert (long_long_unsigned_type_node,
6178 arg));
6179
6180 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
6181 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
6182 call2 = build_call_expr_loc (input_location, func, 1,
6183 fold_convert (long_long_unsigned_type_node,
6184 arg2));
6185
6186 /* Combine the results. */
6187 if (parity)
6188 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
6189 call1, call2);
6190 else
6191 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
6192 call1, call2);
6193
6194 return;
6195 }
6196
6197 /* Convert the actual argument twice: first, to the unsigned type of the
6198 same size; then, to the proper argument type for the built-in
6199 function. */
6200 arg = fold_convert (gfc_build_uint_type (argsize), arg);
6201 arg = fold_convert (arg_type, arg);
6202
6203 se->expr = fold_convert (result_type,
6204 build_call_expr_loc (input_location, func, 1, arg));
6205 }
6206
6207
6208 /* Process an intrinsic with unspecified argument-types that has an optional
6209 argument (which could be of type character), e.g. EOSHIFT. For those, we
6210 need to append the string length of the optional argument if it is not
6211 present and the type is really character.
6212 primary specifies the position (starting at 1) of the non-optional argument
6213 specifying the type and optional gives the position of the optional
6214 argument in the arglist. */
6215
6216 static void
conv_generic_with_optional_char_arg(gfc_se * se,gfc_expr * expr,unsigned primary,unsigned optional)6217 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
6218 unsigned primary, unsigned optional)
6219 {
6220 gfc_actual_arglist* prim_arg;
6221 gfc_actual_arglist* opt_arg;
6222 unsigned cur_pos;
6223 gfc_actual_arglist* arg;
6224 gfc_symbol* sym;
6225 vec<tree, va_gc> *append_args;
6226
6227 /* Find the two arguments given as position. */
6228 cur_pos = 0;
6229 prim_arg = NULL;
6230 opt_arg = NULL;
6231 for (arg = expr->value.function.actual; arg; arg = arg->next)
6232 {
6233 ++cur_pos;
6234
6235 if (cur_pos == primary)
6236 prim_arg = arg;
6237 if (cur_pos == optional)
6238 opt_arg = arg;
6239
6240 if (cur_pos >= primary && cur_pos >= optional)
6241 break;
6242 }
6243 gcc_assert (prim_arg);
6244 gcc_assert (prim_arg->expr);
6245 gcc_assert (opt_arg);
6246
6247 /* If we do have type CHARACTER and the optional argument is really absent,
6248 append a dummy 0 as string length. */
6249 append_args = NULL;
6250 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
6251 {
6252 tree dummy;
6253
6254 dummy = build_int_cst (gfc_charlen_type_node, 0);
6255 vec_alloc (append_args, 1);
6256 append_args->quick_push (dummy);
6257 }
6258
6259 /* Build the call itself. */
6260 gcc_assert (!se->ignore_optional);
6261 sym = gfc_get_symbol_for_expr (expr, false);
6262 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6263 append_args);
6264 gfc_free_symbol (sym);
6265 }
6266
6267 /* The length of a character string. */
6268 static void
gfc_conv_intrinsic_len(gfc_se * se,gfc_expr * expr)6269 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
6270 {
6271 tree len;
6272 tree type;
6273 tree decl;
6274 gfc_symbol *sym;
6275 gfc_se argse;
6276 gfc_expr *arg;
6277
6278 gcc_assert (!se->ss);
6279
6280 arg = expr->value.function.actual->expr;
6281
6282 type = gfc_typenode_for_spec (&expr->ts);
6283 switch (arg->expr_type)
6284 {
6285 case EXPR_CONSTANT:
6286 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
6287 break;
6288
6289 case EXPR_ARRAY:
6290 /* Obtain the string length from the function used by
6291 trans-array.c(gfc_trans_array_constructor). */
6292 len = NULL_TREE;
6293 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
6294 break;
6295
6296 case EXPR_VARIABLE:
6297 if (arg->ref == NULL
6298 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
6299 {
6300 /* This doesn't catch all cases.
6301 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6302 and the surrounding thread. */
6303 sym = arg->symtree->n.sym;
6304 decl = gfc_get_symbol_decl (sym);
6305 if (decl == current_function_decl && sym->attr.function
6306 && (sym->result == sym))
6307 decl = gfc_get_fake_result_decl (sym, 0);
6308
6309 len = sym->ts.u.cl->backend_decl;
6310 gcc_assert (len);
6311 break;
6312 }
6313
6314 /* Fall through. */
6315
6316 default:
6317 /* Anybody stupid enough to do this deserves inefficient code. */
6318 gfc_init_se (&argse, se);
6319 if (arg->rank == 0)
6320 gfc_conv_expr (&argse, arg);
6321 else
6322 gfc_conv_expr_descriptor (&argse, arg);
6323 gfc_add_block_to_block (&se->pre, &argse.pre);
6324 gfc_add_block_to_block (&se->post, &argse.post);
6325 len = argse.string_length;
6326 break;
6327 }
6328 se->expr = convert (type, len);
6329 }
6330
6331 /* The length of a character string not including trailing blanks. */
6332 static void
gfc_conv_intrinsic_len_trim(gfc_se * se,gfc_expr * expr)6333 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
6334 {
6335 int kind = expr->value.function.actual->expr->ts.kind;
6336 tree args[2], type, fndecl;
6337
6338 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6339 type = gfc_typenode_for_spec (&expr->ts);
6340
6341 if (kind == 1)
6342 fndecl = gfor_fndecl_string_len_trim;
6343 else if (kind == 4)
6344 fndecl = gfor_fndecl_string_len_trim_char4;
6345 else
6346 gcc_unreachable ();
6347
6348 se->expr = build_call_expr_loc (input_location,
6349 fndecl, 2, args[0], args[1]);
6350 se->expr = convert (type, se->expr);
6351 }
6352
6353
6354 /* Returns the starting position of a substring within a string. */
6355
6356 static void
gfc_conv_intrinsic_index_scan_verify(gfc_se * se,gfc_expr * expr,tree function)6357 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
6358 tree function)
6359 {
6360 tree logical4_type_node = gfc_get_logical_type (4);
6361 tree type;
6362 tree fndecl;
6363 tree *args;
6364 unsigned int num_args;
6365
6366 args = XALLOCAVEC (tree, 5);
6367
6368 /* Get number of arguments; characters count double due to the
6369 string length argument. Kind= is not passed to the library
6370 and thus ignored. */
6371 if (expr->value.function.actual->next->next->expr == NULL)
6372 num_args = 4;
6373 else
6374 num_args = 5;
6375
6376 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6377 type = gfc_typenode_for_spec (&expr->ts);
6378
6379 if (num_args == 4)
6380 args[4] = build_int_cst (logical4_type_node, 0);
6381 else
6382 args[4] = convert (logical4_type_node, args[4]);
6383
6384 fndecl = build_addr (function);
6385 se->expr = build_call_array_loc (input_location,
6386 TREE_TYPE (TREE_TYPE (function)), fndecl,
6387 5, args);
6388 se->expr = convert (type, se->expr);
6389
6390 }
6391
6392 /* The ascii value for a single character. */
6393 static void
gfc_conv_intrinsic_ichar(gfc_se * se,gfc_expr * expr)6394 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
6395 {
6396 tree args[3], type, pchartype;
6397 int nargs;
6398
6399 nargs = gfc_intrinsic_argument_list_length (expr);
6400 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
6401 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
6402 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
6403 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
6404 type = gfc_typenode_for_spec (&expr->ts);
6405
6406 se->expr = build_fold_indirect_ref_loc (input_location,
6407 args[1]);
6408 se->expr = convert (type, se->expr);
6409 }
6410
6411
6412 /* Intrinsic ISNAN calls __builtin_isnan. */
6413
6414 static void
gfc_conv_intrinsic_isnan(gfc_se * se,gfc_expr * expr)6415 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
6416 {
6417 tree arg;
6418
6419 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6420 se->expr = build_call_expr_loc (input_location,
6421 builtin_decl_explicit (BUILT_IN_ISNAN),
6422 1, arg);
6423 STRIP_TYPE_NOPS (se->expr);
6424 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
6425 }
6426
6427
6428 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6429 their argument against a constant integer value. */
6430
6431 static void
gfc_conv_has_intvalue(gfc_se * se,gfc_expr * expr,const int value)6432 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
6433 {
6434 tree arg;
6435
6436 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6437 se->expr = fold_build2_loc (input_location, EQ_EXPR,
6438 gfc_typenode_for_spec (&expr->ts),
6439 arg, build_int_cst (TREE_TYPE (arg), value));
6440 }
6441
6442
6443
6444 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
6445
6446 static void
gfc_conv_intrinsic_merge(gfc_se * se,gfc_expr * expr)6447 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
6448 {
6449 tree tsource;
6450 tree fsource;
6451 tree mask;
6452 tree type;
6453 tree len, len2;
6454 tree *args;
6455 unsigned int num_args;
6456
6457 num_args = gfc_intrinsic_argument_list_length (expr);
6458 args = XALLOCAVEC (tree, num_args);
6459
6460 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6461 if (expr->ts.type != BT_CHARACTER)
6462 {
6463 tsource = args[0];
6464 fsource = args[1];
6465 mask = args[2];
6466 }
6467 else
6468 {
6469 /* We do the same as in the non-character case, but the argument
6470 list is different because of the string length arguments. We
6471 also have to set the string length for the result. */
6472 len = args[0];
6473 tsource = args[1];
6474 len2 = args[2];
6475 fsource = args[3];
6476 mask = args[4];
6477
6478 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
6479 &se->pre);
6480 se->string_length = len;
6481 }
6482 type = TREE_TYPE (tsource);
6483 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
6484 fold_convert (type, fsource));
6485 }
6486
6487
6488 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
6489
6490 static void
gfc_conv_intrinsic_merge_bits(gfc_se * se,gfc_expr * expr)6491 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
6492 {
6493 tree args[3], mask, type;
6494
6495 gfc_conv_intrinsic_function_args (se, expr, args, 3);
6496 mask = gfc_evaluate_now (args[2], &se->pre);
6497
6498 type = TREE_TYPE (args[0]);
6499 gcc_assert (TREE_TYPE (args[1]) == type);
6500 gcc_assert (TREE_TYPE (mask) == type);
6501
6502 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
6503 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
6504 fold_build1_loc (input_location, BIT_NOT_EXPR,
6505 type, mask));
6506 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
6507 args[0], args[1]);
6508 }
6509
6510
6511 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6512 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
6513
6514 static void
gfc_conv_intrinsic_mask(gfc_se * se,gfc_expr * expr,int left)6515 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
6516 {
6517 tree arg, allones, type, utype, res, cond, bitsize;
6518 int i;
6519
6520 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6521 arg = gfc_evaluate_now (arg, &se->pre);
6522
6523 type = gfc_get_int_type (expr->ts.kind);
6524 utype = unsigned_type_for (type);
6525
6526 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
6527 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
6528
6529 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
6530 build_int_cst (utype, 0));
6531
6532 if (left)
6533 {
6534 /* Left-justified mask. */
6535 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
6536 bitsize, arg);
6537 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6538 fold_convert (utype, res));
6539
6540 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6541 smaller than type width. */
6542 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
6543 build_int_cst (TREE_TYPE (arg), 0));
6544 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
6545 build_int_cst (utype, 0), res);
6546 }
6547 else
6548 {
6549 /* Right-justified mask. */
6550 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6551 fold_convert (utype, arg));
6552 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
6553
6554 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6555 strictly smaller than type width. */
6556 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6557 arg, bitsize);
6558 res = fold_build3_loc (input_location, COND_EXPR, utype,
6559 cond, allones, res);
6560 }
6561
6562 se->expr = fold_convert (type, res);
6563 }
6564
6565
6566 /* FRACTION (s) is translated into:
6567 isfinite (s) ? frexp (s, &dummy_int) : NaN */
6568 static void
gfc_conv_intrinsic_fraction(gfc_se * se,gfc_expr * expr)6569 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
6570 {
6571 tree arg, type, tmp, res, frexp, cond;
6572
6573 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6574
6575 type = gfc_typenode_for_spec (&expr->ts);
6576 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6577 arg = gfc_evaluate_now (arg, &se->pre);
6578
6579 cond = build_call_expr_loc (input_location,
6580 builtin_decl_explicit (BUILT_IN_ISFINITE),
6581 1, arg);
6582
6583 tmp = gfc_create_var (integer_type_node, NULL);
6584 res = build_call_expr_loc (input_location, frexp, 2,
6585 fold_convert (type, arg),
6586 gfc_build_addr_expr (NULL_TREE, tmp));
6587 res = fold_convert (type, res);
6588
6589 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
6590 cond, res, gfc_build_nan (type, ""));
6591 }
6592
6593
6594 /* NEAREST (s, dir) is translated into
6595 tmp = copysign (HUGE_VAL, dir);
6596 return nextafter (s, tmp);
6597 */
6598 static void
gfc_conv_intrinsic_nearest(gfc_se * se,gfc_expr * expr)6599 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
6600 {
6601 tree args[2], type, tmp, nextafter, copysign, huge_val;
6602
6603 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
6604 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
6605
6606 type = gfc_typenode_for_spec (&expr->ts);
6607 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6608
6609 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
6610 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
6611 fold_convert (type, args[1]));
6612 se->expr = build_call_expr_loc (input_location, nextafter, 2,
6613 fold_convert (type, args[0]), tmp);
6614 se->expr = fold_convert (type, se->expr);
6615 }
6616
6617
6618 /* SPACING (s) is translated into
6619 int e;
6620 if (!isfinite (s))
6621 res = NaN;
6622 else if (s == 0)
6623 res = tiny;
6624 else
6625 {
6626 frexp (s, &e);
6627 e = e - prec;
6628 e = MAX_EXPR (e, emin);
6629 res = scalbn (1., e);
6630 }
6631 return res;
6632
6633 where prec is the precision of s, gfc_real_kinds[k].digits,
6634 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6635 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
6636
6637 static void
gfc_conv_intrinsic_spacing(gfc_se * se,gfc_expr * expr)6638 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
6639 {
6640 tree arg, type, prec, emin, tiny, res, e;
6641 tree cond, nan, tmp, frexp, scalbn;
6642 int k;
6643 stmtblock_t block;
6644
6645 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6646 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
6647 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
6648 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
6649
6650 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6651 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6652
6653 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6654 arg = gfc_evaluate_now (arg, &se->pre);
6655
6656 type = gfc_typenode_for_spec (&expr->ts);
6657 e = gfc_create_var (integer_type_node, NULL);
6658 res = gfc_create_var (type, NULL);
6659
6660
6661 /* Build the block for s /= 0. */
6662 gfc_start_block (&block);
6663 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6664 gfc_build_addr_expr (NULL_TREE, e));
6665 gfc_add_expr_to_block (&block, tmp);
6666
6667 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
6668 prec);
6669 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
6670 integer_type_node, tmp, emin));
6671
6672 tmp = build_call_expr_loc (input_location, scalbn, 2,
6673 build_real_from_int_cst (type, integer_one_node), e);
6674 gfc_add_modify (&block, res, tmp);
6675
6676 /* Finish by building the IF statement for value zero. */
6677 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
6678 build_real_from_int_cst (type, integer_zero_node));
6679 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
6680 gfc_finish_block (&block));
6681
6682 /* And deal with infinities and NaNs. */
6683 cond = build_call_expr_loc (input_location,
6684 builtin_decl_explicit (BUILT_IN_ISFINITE),
6685 1, arg);
6686 nan = gfc_build_nan (type, "");
6687 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
6688
6689 gfc_add_expr_to_block (&se->pre, tmp);
6690 se->expr = res;
6691 }
6692
6693
6694 /* RRSPACING (s) is translated into
6695 int e;
6696 real x;
6697 x = fabs (s);
6698 if (isfinite (x))
6699 {
6700 if (x != 0)
6701 {
6702 frexp (s, &e);
6703 x = scalbn (x, precision - e);
6704 }
6705 }
6706 else
6707 x = NaN;
6708 return x;
6709
6710 where precision is gfc_real_kinds[k].digits. */
6711
6712 static void
gfc_conv_intrinsic_rrspacing(gfc_se * se,gfc_expr * expr)6713 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
6714 {
6715 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
6716 int prec, k;
6717 stmtblock_t block;
6718
6719 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6720 prec = gfc_real_kinds[k].digits;
6721
6722 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6723 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6724 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
6725
6726 type = gfc_typenode_for_spec (&expr->ts);
6727 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6728 arg = gfc_evaluate_now (arg, &se->pre);
6729
6730 e = gfc_create_var (integer_type_node, NULL);
6731 x = gfc_create_var (type, NULL);
6732 gfc_add_modify (&se->pre, x,
6733 build_call_expr_loc (input_location, fabs, 1, arg));
6734
6735
6736 gfc_start_block (&block);
6737 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6738 gfc_build_addr_expr (NULL_TREE, e));
6739 gfc_add_expr_to_block (&block, tmp);
6740
6741 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
6742 build_int_cst (integer_type_node, prec), e);
6743 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
6744 gfc_add_modify (&block, x, tmp);
6745 stmt = gfc_finish_block (&block);
6746
6747 /* if (x != 0) */
6748 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
6749 build_real_from_int_cst (type, integer_zero_node));
6750 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
6751
6752 /* And deal with infinities and NaNs. */
6753 cond = build_call_expr_loc (input_location,
6754 builtin_decl_explicit (BUILT_IN_ISFINITE),
6755 1, x);
6756 nan = gfc_build_nan (type, "");
6757 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
6758
6759 gfc_add_expr_to_block (&se->pre, tmp);
6760 se->expr = fold_convert (type, x);
6761 }
6762
6763
6764 /* SCALE (s, i) is translated into scalbn (s, i). */
6765 static void
gfc_conv_intrinsic_scale(gfc_se * se,gfc_expr * expr)6766 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
6767 {
6768 tree args[2], type, scalbn;
6769
6770 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6771
6772 type = gfc_typenode_for_spec (&expr->ts);
6773 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6774 se->expr = build_call_expr_loc (input_location, scalbn, 2,
6775 fold_convert (type, args[0]),
6776 fold_convert (integer_type_node, args[1]));
6777 se->expr = fold_convert (type, se->expr);
6778 }
6779
6780
6781 /* SET_EXPONENT (s, i) is translated into
6782 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
6783 static void
gfc_conv_intrinsic_set_exponent(gfc_se * se,gfc_expr * expr)6784 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
6785 {
6786 tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
6787
6788 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6789 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6790
6791 type = gfc_typenode_for_spec (&expr->ts);
6792 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6793 args[0] = gfc_evaluate_now (args[0], &se->pre);
6794
6795 tmp = gfc_create_var (integer_type_node, NULL);
6796 tmp = build_call_expr_loc (input_location, frexp, 2,
6797 fold_convert (type, args[0]),
6798 gfc_build_addr_expr (NULL_TREE, tmp));
6799 res = build_call_expr_loc (input_location, scalbn, 2, tmp,
6800 fold_convert (integer_type_node, args[1]));
6801 res = fold_convert (type, res);
6802
6803 /* Call to isfinite */
6804 cond = build_call_expr_loc (input_location,
6805 builtin_decl_explicit (BUILT_IN_ISFINITE),
6806 1, args[0]);
6807 nan = gfc_build_nan (type, "");
6808
6809 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6810 res, nan);
6811 }
6812
6813
6814 static void
gfc_conv_intrinsic_size(gfc_se * se,gfc_expr * expr)6815 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
6816 {
6817 gfc_actual_arglist *actual;
6818 tree arg1;
6819 tree type;
6820 tree fncall0;
6821 tree fncall1;
6822 gfc_se argse;
6823 gfc_expr *e;
6824 gfc_symbol *sym = NULL;
6825
6826 gfc_init_se (&argse, NULL);
6827 actual = expr->value.function.actual;
6828
6829 if (actual->expr->ts.type == BT_CLASS)
6830 gfc_add_class_array_ref (actual->expr);
6831
6832 e = actual->expr;
6833
6834 /* These are emerging from the interface mapping, when a class valued
6835 function appears as the rhs in a realloc on assign statement, where
6836 the size of the result is that of one of the actual arguments. */
6837 if (e->expr_type == EXPR_VARIABLE
6838 && e->symtree->n.sym->ns == NULL /* This is distinctive! */
6839 && e->symtree->n.sym->ts.type == BT_CLASS
6840 && e->ref && e->ref->type == REF_COMPONENT
6841 && strcmp (e->ref->u.c.component->name, "_data") == 0)
6842 sym = e->symtree->n.sym;
6843
6844 argse.data_not_needed = 1;
6845 if (gfc_is_class_array_function (e))
6846 {
6847 /* For functions that return a class array conv_expr_descriptor is not
6848 able to get the descriptor right. Therefore this special case. */
6849 gfc_conv_expr_reference (&argse, e);
6850 argse.expr = gfc_build_addr_expr (NULL_TREE,
6851 gfc_class_data_get (argse.expr));
6852 }
6853 else if (sym && sym->backend_decl)
6854 {
6855 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
6856 argse.expr = sym->backend_decl;
6857 argse.expr = gfc_build_addr_expr (NULL_TREE,
6858 gfc_class_data_get (argse.expr));
6859 }
6860 else
6861 {
6862 argse.want_pointer = 1;
6863 gfc_conv_expr_descriptor (&argse, actual->expr);
6864 }
6865 gfc_add_block_to_block (&se->pre, &argse.pre);
6866 gfc_add_block_to_block (&se->post, &argse.post);
6867 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
6868
6869 /* Build the call to size0. */
6870 fncall0 = build_call_expr_loc (input_location,
6871 gfor_fndecl_size0, 1, arg1);
6872
6873 actual = actual->next;
6874
6875 if (actual->expr)
6876 {
6877 gfc_init_se (&argse, NULL);
6878 gfc_conv_expr_type (&argse, actual->expr,
6879 gfc_array_index_type);
6880 gfc_add_block_to_block (&se->pre, &argse.pre);
6881
6882 /* Unusually, for an intrinsic, size does not exclude
6883 an optional arg2, so we must test for it. */
6884 if (actual->expr->expr_type == EXPR_VARIABLE
6885 && actual->expr->symtree->n.sym->attr.dummy
6886 && actual->expr->symtree->n.sym->attr.optional)
6887 {
6888 tree tmp;
6889 /* Build the call to size1. */
6890 fncall1 = build_call_expr_loc (input_location,
6891 gfor_fndecl_size1, 2,
6892 arg1, argse.expr);
6893
6894 gfc_init_se (&argse, NULL);
6895 argse.want_pointer = 1;
6896 argse.data_not_needed = 1;
6897 gfc_conv_expr (&argse, actual->expr);
6898 gfc_add_block_to_block (&se->pre, &argse.pre);
6899 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6900 argse.expr, null_pointer_node);
6901 tmp = gfc_evaluate_now (tmp, &se->pre);
6902 se->expr = fold_build3_loc (input_location, COND_EXPR,
6903 pvoid_type_node, tmp, fncall1, fncall0);
6904 }
6905 else
6906 {
6907 se->expr = NULL_TREE;
6908 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
6909 gfc_array_index_type,
6910 argse.expr, gfc_index_one_node);
6911 }
6912 }
6913 else if (expr->value.function.actual->expr->rank == 1)
6914 {
6915 argse.expr = gfc_index_zero_node;
6916 se->expr = NULL_TREE;
6917 }
6918 else
6919 se->expr = fncall0;
6920
6921 if (se->expr == NULL_TREE)
6922 {
6923 tree ubound, lbound;
6924
6925 arg1 = build_fold_indirect_ref_loc (input_location,
6926 arg1);
6927 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
6928 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
6929 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
6930 gfc_array_index_type, ubound, lbound);
6931 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
6932 gfc_array_index_type,
6933 se->expr, gfc_index_one_node);
6934 se->expr = fold_build2_loc (input_location, MAX_EXPR,
6935 gfc_array_index_type, se->expr,
6936 gfc_index_zero_node);
6937 }
6938
6939 type = gfc_typenode_for_spec (&expr->ts);
6940 se->expr = convert (type, se->expr);
6941 }
6942
6943
6944 /* Helper function to compute the size of a character variable,
6945 excluding the terminating null characters. The result has
6946 gfc_array_index_type type. */
6947
6948 tree
size_of_string_in_bytes(int kind,tree string_length)6949 size_of_string_in_bytes (int kind, tree string_length)
6950 {
6951 tree bytesize;
6952 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
6953
6954 bytesize = build_int_cst (gfc_array_index_type,
6955 gfc_character_kinds[i].bit_size / 8);
6956
6957 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6958 bytesize,
6959 fold_convert (gfc_array_index_type, string_length));
6960 }
6961
6962
6963 static void
gfc_conv_intrinsic_sizeof(gfc_se * se,gfc_expr * expr)6964 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
6965 {
6966 gfc_expr *arg;
6967 gfc_se argse;
6968 tree source_bytes;
6969 tree tmp;
6970 tree lower;
6971 tree upper;
6972 tree byte_size;
6973 tree field;
6974 int n;
6975
6976 gfc_init_se (&argse, NULL);
6977 arg = expr->value.function.actual->expr;
6978
6979 if (arg->rank || arg->ts.type == BT_ASSUMED)
6980 gfc_conv_expr_descriptor (&argse, arg);
6981 else
6982 gfc_conv_expr_reference (&argse, arg);
6983
6984 if (arg->ts.type == BT_ASSUMED)
6985 {
6986 /* This only works if an array descriptor has been passed; thus, extract
6987 the size from the descriptor. */
6988 gcc_assert (TYPE_PRECISION (gfc_array_index_type)
6989 == TYPE_PRECISION (size_type_node));
6990 tmp = arg->symtree->n.sym->backend_decl;
6991 tmp = DECL_LANG_SPECIFIC (tmp)
6992 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
6993 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
6994 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
6995 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6996
6997 tmp = gfc_conv_descriptor_dtype (tmp);
6998 field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
6999 GFC_DTYPE_ELEM_LEN);
7000 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7001 tmp, field, NULL_TREE);
7002
7003 byte_size = fold_convert (gfc_array_index_type, tmp);
7004 }
7005 else if (arg->ts.type == BT_CLASS)
7006 {
7007 /* Conv_expr_descriptor returns a component_ref to _data component of the
7008 class object. The class object may be a non-pointer object, e.g.
7009 located on the stack, or a memory location pointed to, e.g. a
7010 parameter, i.e., an indirect_ref. */
7011 if (arg->rank < 0
7012 || (arg->rank > 0 && !VAR_P (argse.expr)
7013 && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
7014 && GFC_DECL_CLASS (TREE_OPERAND (
7015 TREE_OPERAND (argse.expr, 0), 0)))
7016 || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
7017 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
7018 else if (arg->rank > 0
7019 || (arg->rank == 0
7020 && arg->ref && arg->ref->type == REF_COMPONENT))
7021 /* The scalarizer added an additional temp. To get the class' vptr
7022 one has to look at the original backend_decl. */
7023 byte_size = gfc_class_vtab_size_get (
7024 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
7025 else
7026 byte_size = gfc_class_vtab_size_get (argse.expr);
7027 }
7028 else
7029 {
7030 if (arg->ts.type == BT_CHARACTER)
7031 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
7032 else
7033 {
7034 if (arg->rank == 0)
7035 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7036 argse.expr));
7037 else
7038 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
7039 byte_size = fold_convert (gfc_array_index_type,
7040 size_in_bytes (byte_size));
7041 }
7042 }
7043
7044 if (arg->rank == 0)
7045 se->expr = byte_size;
7046 else
7047 {
7048 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
7049 gfc_add_modify (&argse.pre, source_bytes, byte_size);
7050
7051 if (arg->rank == -1)
7052 {
7053 tree cond, loop_var, exit_label;
7054 stmtblock_t body;
7055
7056 tmp = fold_convert (gfc_array_index_type,
7057 gfc_conv_descriptor_rank (argse.expr));
7058 loop_var = gfc_create_var (gfc_array_index_type, "i");
7059 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
7060 exit_label = gfc_build_label_decl (NULL_TREE);
7061
7062 /* Create loop:
7063 for (;;)
7064 {
7065 if (i >= rank)
7066 goto exit;
7067 source_bytes = source_bytes * array.dim[i].extent;
7068 i = i + 1;
7069 }
7070 exit: */
7071 gfc_start_block (&body);
7072 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7073 loop_var, tmp);
7074 tmp = build1_v (GOTO_EXPR, exit_label);
7075 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7076 cond, tmp, build_empty_stmt (input_location));
7077 gfc_add_expr_to_block (&body, tmp);
7078
7079 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
7080 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
7081 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
7082 tmp = fold_build2_loc (input_location, MULT_EXPR,
7083 gfc_array_index_type, tmp, source_bytes);
7084 gfc_add_modify (&body, source_bytes, tmp);
7085
7086 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7087 gfc_array_index_type, loop_var,
7088 gfc_index_one_node);
7089 gfc_add_modify_loc (input_location, &body, loop_var, tmp);
7090
7091 tmp = gfc_finish_block (&body);
7092
7093 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
7094 tmp);
7095 gfc_add_expr_to_block (&argse.pre, tmp);
7096
7097 tmp = build1_v (LABEL_EXPR, exit_label);
7098 gfc_add_expr_to_block (&argse.pre, tmp);
7099 }
7100 else
7101 {
7102 /* Obtain the size of the array in bytes. */
7103 for (n = 0; n < arg->rank; n++)
7104 {
7105 tree idx;
7106 idx = gfc_rank_cst[n];
7107 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
7108 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
7109 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
7110 tmp = fold_build2_loc (input_location, MULT_EXPR,
7111 gfc_array_index_type, tmp, source_bytes);
7112 gfc_add_modify (&argse.pre, source_bytes, tmp);
7113 }
7114 }
7115 se->expr = source_bytes;
7116 }
7117
7118 gfc_add_block_to_block (&se->pre, &argse.pre);
7119 }
7120
7121
7122 static void
gfc_conv_intrinsic_storage_size(gfc_se * se,gfc_expr * expr)7123 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
7124 {
7125 gfc_expr *arg;
7126 gfc_se argse;
7127 tree type, result_type, tmp;
7128
7129 arg = expr->value.function.actual->expr;
7130
7131 gfc_init_se (&argse, NULL);
7132 result_type = gfc_get_int_type (expr->ts.kind);
7133
7134 if (arg->rank == 0)
7135 {
7136 if (arg->ts.type == BT_CLASS)
7137 {
7138 gfc_add_vptr_component (arg);
7139 gfc_add_size_component (arg);
7140 gfc_conv_expr (&argse, arg);
7141 tmp = fold_convert (result_type, argse.expr);
7142 goto done;
7143 }
7144
7145 gfc_conv_expr_reference (&argse, arg);
7146 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7147 argse.expr));
7148 }
7149 else
7150 {
7151 argse.want_pointer = 0;
7152 gfc_conv_expr_descriptor (&argse, arg);
7153 if (arg->ts.type == BT_CLASS)
7154 {
7155 if (arg->rank > 0)
7156 tmp = gfc_class_vtab_size_get (
7157 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
7158 else
7159 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
7160 tmp = fold_convert (result_type, tmp);
7161 goto done;
7162 }
7163 type = gfc_get_element_type (TREE_TYPE (argse.expr));
7164 }
7165
7166 /* Obtain the argument's word length. */
7167 if (arg->ts.type == BT_CHARACTER)
7168 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
7169 else
7170 tmp = size_in_bytes (type);
7171 tmp = fold_convert (result_type, tmp);
7172
7173 done:
7174 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
7175 build_int_cst (result_type, BITS_PER_UNIT));
7176 gfc_add_block_to_block (&se->pre, &argse.pre);
7177 }
7178
7179
7180 /* Intrinsic string comparison functions. */
7181
7182 static void
gfc_conv_intrinsic_strcmp(gfc_se * se,gfc_expr * expr,enum tree_code op)7183 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
7184 {
7185 tree args[4];
7186
7187 gfc_conv_intrinsic_function_args (se, expr, args, 4);
7188
7189 se->expr
7190 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
7191 expr->value.function.actual->expr->ts.kind,
7192 op);
7193 se->expr = fold_build2_loc (input_location, op,
7194 gfc_typenode_for_spec (&expr->ts), se->expr,
7195 build_int_cst (TREE_TYPE (se->expr), 0));
7196 }
7197
7198 /* Generate a call to the adjustl/adjustr library function. */
7199 static void
gfc_conv_intrinsic_adjust(gfc_se * se,gfc_expr * expr,tree fndecl)7200 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
7201 {
7202 tree args[3];
7203 tree len;
7204 tree type;
7205 tree var;
7206 tree tmp;
7207
7208 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
7209 len = args[1];
7210
7211 type = TREE_TYPE (args[2]);
7212 var = gfc_conv_string_tmp (se, type, len);
7213 args[0] = var;
7214
7215 tmp = build_call_expr_loc (input_location,
7216 fndecl, 3, args[0], args[1], args[2]);
7217 gfc_add_expr_to_block (&se->pre, tmp);
7218 se->expr = var;
7219 se->string_length = len;
7220 }
7221
7222
7223 /* Generate code for the TRANSFER intrinsic:
7224 For scalar results:
7225 DEST = TRANSFER (SOURCE, MOLD)
7226 where:
7227 typeof<DEST> = typeof<MOLD>
7228 and:
7229 MOLD is scalar.
7230
7231 For array results:
7232 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7233 where:
7234 typeof<DEST> = typeof<MOLD>
7235 and:
7236 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7237 sizeof (DEST(0) * SIZE). */
7238 static void
gfc_conv_intrinsic_transfer(gfc_se * se,gfc_expr * expr)7239 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
7240 {
7241 tree tmp;
7242 tree tmpdecl;
7243 tree ptr;
7244 tree extent;
7245 tree source;
7246 tree source_type;
7247 tree source_bytes;
7248 tree mold_type;
7249 tree dest_word_len;
7250 tree size_words;
7251 tree size_bytes;
7252 tree upper;
7253 tree lower;
7254 tree stmt;
7255 gfc_actual_arglist *arg;
7256 gfc_se argse;
7257 gfc_array_info *info;
7258 stmtblock_t block;
7259 int n;
7260 bool scalar_mold;
7261 gfc_expr *source_expr, *mold_expr;
7262
7263 info = NULL;
7264 if (se->loop)
7265 info = &se->ss->info->data.array;
7266
7267 /* Convert SOURCE. The output from this stage is:-
7268 source_bytes = length of the source in bytes
7269 source = pointer to the source data. */
7270 arg = expr->value.function.actual;
7271 source_expr = arg->expr;
7272
7273 /* Ensure double transfer through LOGICAL preserves all
7274 the needed bits. */
7275 if (arg->expr->expr_type == EXPR_FUNCTION
7276 && arg->expr->value.function.esym == NULL
7277 && arg->expr->value.function.isym != NULL
7278 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
7279 && arg->expr->ts.type == BT_LOGICAL
7280 && expr->ts.type != arg->expr->ts.type)
7281 arg->expr->value.function.name = "__transfer_in_transfer";
7282
7283 gfc_init_se (&argse, NULL);
7284
7285 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
7286
7287 /* Obtain the pointer to source and the length of source in bytes. */
7288 if (arg->expr->rank == 0)
7289 {
7290 gfc_conv_expr_reference (&argse, arg->expr);
7291 if (arg->expr->ts.type == BT_CLASS)
7292 source = gfc_class_data_get (argse.expr);
7293 else
7294 source = argse.expr;
7295
7296 /* Obtain the source word length. */
7297 switch (arg->expr->ts.type)
7298 {
7299 case BT_CHARACTER:
7300 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7301 argse.string_length);
7302 break;
7303 case BT_CLASS:
7304 tmp = gfc_class_vtab_size_get (argse.expr);
7305 break;
7306 default:
7307 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7308 source));
7309 tmp = fold_convert (gfc_array_index_type,
7310 size_in_bytes (source_type));
7311 break;
7312 }
7313 }
7314 else
7315 {
7316 argse.want_pointer = 0;
7317 gfc_conv_expr_descriptor (&argse, arg->expr);
7318 source = gfc_conv_descriptor_data_get (argse.expr);
7319 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7320
7321 /* Repack the source if not simply contiguous. */
7322 if (!gfc_is_simply_contiguous (arg->expr, false, true))
7323 {
7324 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
7325
7326 if (warn_array_temporaries)
7327 gfc_warning (OPT_Warray_temporaries,
7328 "Creating array temporary at %L", &expr->where);
7329
7330 source = build_call_expr_loc (input_location,
7331 gfor_fndecl_in_pack, 1, tmp);
7332 source = gfc_evaluate_now (source, &argse.pre);
7333
7334 /* Free the temporary. */
7335 gfc_start_block (&block);
7336 tmp = gfc_call_free (source);
7337 gfc_add_expr_to_block (&block, tmp);
7338 stmt = gfc_finish_block (&block);
7339
7340 /* Clean up if it was repacked. */
7341 gfc_init_block (&block);
7342 tmp = gfc_conv_array_data (argse.expr);
7343 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7344 source, tmp);
7345 tmp = build3_v (COND_EXPR, tmp, stmt,
7346 build_empty_stmt (input_location));
7347 gfc_add_expr_to_block (&block, tmp);
7348 gfc_add_block_to_block (&block, &se->post);
7349 gfc_init_block (&se->post);
7350 gfc_add_block_to_block (&se->post, &block);
7351 }
7352
7353 /* Obtain the source word length. */
7354 if (arg->expr->ts.type == BT_CHARACTER)
7355 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7356 argse.string_length);
7357 else
7358 tmp = fold_convert (gfc_array_index_type,
7359 size_in_bytes (source_type));
7360
7361 /* Obtain the size of the array in bytes. */
7362 extent = gfc_create_var (gfc_array_index_type, NULL);
7363 for (n = 0; n < arg->expr->rank; n++)
7364 {
7365 tree idx;
7366 idx = gfc_rank_cst[n];
7367 gfc_add_modify (&argse.pre, source_bytes, tmp);
7368 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
7369 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
7370 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7371 gfc_array_index_type, upper, lower);
7372 gfc_add_modify (&argse.pre, extent, tmp);
7373 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7374 gfc_array_index_type, extent,
7375 gfc_index_one_node);
7376 tmp = fold_build2_loc (input_location, MULT_EXPR,
7377 gfc_array_index_type, tmp, source_bytes);
7378 }
7379 }
7380
7381 gfc_add_modify (&argse.pre, source_bytes, tmp);
7382 gfc_add_block_to_block (&se->pre, &argse.pre);
7383 gfc_add_block_to_block (&se->post, &argse.post);
7384
7385 /* Now convert MOLD. The outputs are:
7386 mold_type = the TREE type of MOLD
7387 dest_word_len = destination word length in bytes. */
7388 arg = arg->next;
7389 mold_expr = arg->expr;
7390
7391 gfc_init_se (&argse, NULL);
7392
7393 scalar_mold = arg->expr->rank == 0;
7394
7395 if (arg->expr->rank == 0)
7396 {
7397 gfc_conv_expr_reference (&argse, arg->expr);
7398 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7399 argse.expr));
7400 }
7401 else
7402 {
7403 gfc_init_se (&argse, NULL);
7404 argse.want_pointer = 0;
7405 gfc_conv_expr_descriptor (&argse, arg->expr);
7406 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7407 }
7408
7409 gfc_add_block_to_block (&se->pre, &argse.pre);
7410 gfc_add_block_to_block (&se->post, &argse.post);
7411
7412 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
7413 {
7414 /* If this TRANSFER is nested in another TRANSFER, use a type
7415 that preserves all bits. */
7416 if (arg->expr->ts.type == BT_LOGICAL)
7417 mold_type = gfc_get_int_type (arg->expr->ts.kind);
7418 }
7419
7420 /* Obtain the destination word length. */
7421 switch (arg->expr->ts.type)
7422 {
7423 case BT_CHARACTER:
7424 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
7425 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
7426 break;
7427 case BT_CLASS:
7428 tmp = gfc_class_vtab_size_get (argse.expr);
7429 break;
7430 default:
7431 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
7432 break;
7433 }
7434 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
7435 gfc_add_modify (&se->pre, dest_word_len, tmp);
7436
7437 /* Finally convert SIZE, if it is present. */
7438 arg = arg->next;
7439 size_words = gfc_create_var (gfc_array_index_type, NULL);
7440
7441 if (arg->expr)
7442 {
7443 gfc_init_se (&argse, NULL);
7444 gfc_conv_expr_reference (&argse, arg->expr);
7445 tmp = convert (gfc_array_index_type,
7446 build_fold_indirect_ref_loc (input_location,
7447 argse.expr));
7448 gfc_add_block_to_block (&se->pre, &argse.pre);
7449 gfc_add_block_to_block (&se->post, &argse.post);
7450 }
7451 else
7452 tmp = NULL_TREE;
7453
7454 /* Separate array and scalar results. */
7455 if (scalar_mold && tmp == NULL_TREE)
7456 goto scalar_transfer;
7457
7458 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
7459 if (tmp != NULL_TREE)
7460 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7461 tmp, dest_word_len);
7462 else
7463 tmp = source_bytes;
7464
7465 gfc_add_modify (&se->pre, size_bytes, tmp);
7466 gfc_add_modify (&se->pre, size_words,
7467 fold_build2_loc (input_location, CEIL_DIV_EXPR,
7468 gfc_array_index_type,
7469 size_bytes, dest_word_len));
7470
7471 /* Evaluate the bounds of the result. If the loop range exists, we have
7472 to check if it is too large. If so, we modify loop->to be consistent
7473 with min(size, size(source)). Otherwise, size is made consistent with
7474 the loop range, so that the right number of bytes is transferred.*/
7475 n = se->loop->order[0];
7476 if (se->loop->to[n] != NULL_TREE)
7477 {
7478 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7479 se->loop->to[n], se->loop->from[n]);
7480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7481 tmp, gfc_index_one_node);
7482 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7483 tmp, size_words);
7484 gfc_add_modify (&se->pre, size_words, tmp);
7485 gfc_add_modify (&se->pre, size_bytes,
7486 fold_build2_loc (input_location, MULT_EXPR,
7487 gfc_array_index_type,
7488 size_words, dest_word_len));
7489 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7490 size_words, se->loop->from[n]);
7491 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7492 upper, gfc_index_one_node);
7493 }
7494 else
7495 {
7496 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7497 size_words, gfc_index_one_node);
7498 se->loop->from[n] = gfc_index_zero_node;
7499 }
7500
7501 se->loop->to[n] = upper;
7502
7503 /* Build a destination descriptor, using the pointer, source, as the
7504 data field. */
7505 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
7506 NULL_TREE, false, true, false, &expr->where);
7507
7508 /* Cast the pointer to the result. */
7509 tmp = gfc_conv_descriptor_data_get (info->descriptor);
7510 tmp = fold_convert (pvoid_type_node, tmp);
7511
7512 /* Use memcpy to do the transfer. */
7513 tmp
7514 = build_call_expr_loc (input_location,
7515 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
7516 fold_convert (pvoid_type_node, source),
7517 fold_convert (size_type_node,
7518 fold_build2_loc (input_location,
7519 MIN_EXPR,
7520 gfc_array_index_type,
7521 size_bytes,
7522 source_bytes)));
7523 gfc_add_expr_to_block (&se->pre, tmp);
7524
7525 se->expr = info->descriptor;
7526 if (expr->ts.type == BT_CHARACTER)
7527 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7528
7529 return;
7530
7531 /* Deal with scalar results. */
7532 scalar_transfer:
7533 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7534 dest_word_len, source_bytes);
7535 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
7536 extent, gfc_index_zero_node);
7537
7538 if (expr->ts.type == BT_CHARACTER)
7539 {
7540 tree direct, indirect, free;
7541
7542 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
7543 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
7544 "transfer");
7545
7546 /* If source is longer than the destination, use a pointer to
7547 the source directly. */
7548 gfc_init_block (&block);
7549 gfc_add_modify (&block, tmpdecl, ptr);
7550 direct = gfc_finish_block (&block);
7551
7552 /* Otherwise, allocate a string with the length of the destination
7553 and copy the source into it. */
7554 gfc_init_block (&block);
7555 tmp = gfc_get_pchar_type (expr->ts.kind);
7556 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
7557 gfc_add_modify (&block, tmpdecl,
7558 fold_convert (TREE_TYPE (ptr), tmp));
7559 tmp = build_call_expr_loc (input_location,
7560 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7561 fold_convert (pvoid_type_node, tmpdecl),
7562 fold_convert (pvoid_type_node, ptr),
7563 fold_convert (size_type_node, extent));
7564 gfc_add_expr_to_block (&block, tmp);
7565 indirect = gfc_finish_block (&block);
7566
7567 /* Wrap it up with the condition. */
7568 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
7569 dest_word_len, source_bytes);
7570 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
7571 gfc_add_expr_to_block (&se->pre, tmp);
7572
7573 /* Free the temporary string, if necessary. */
7574 free = gfc_call_free (tmpdecl);
7575 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
7576 dest_word_len, source_bytes);
7577 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
7578 gfc_add_expr_to_block (&se->post, tmp);
7579
7580 se->expr = tmpdecl;
7581 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7582 }
7583 else
7584 {
7585 tmpdecl = gfc_create_var (mold_type, "transfer");
7586
7587 ptr = convert (build_pointer_type (mold_type), source);
7588
7589 /* For CLASS results, allocate the needed memory first. */
7590 if (mold_expr->ts.type == BT_CLASS)
7591 {
7592 tree cdata;
7593 cdata = gfc_class_data_get (tmpdecl);
7594 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
7595 gfc_add_modify (&se->pre, cdata, tmp);
7596 }
7597
7598 /* Use memcpy to do the transfer. */
7599 if (mold_expr->ts.type == BT_CLASS)
7600 tmp = gfc_class_data_get (tmpdecl);
7601 else
7602 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
7603
7604 tmp = build_call_expr_loc (input_location,
7605 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7606 fold_convert (pvoid_type_node, tmp),
7607 fold_convert (pvoid_type_node, ptr),
7608 fold_convert (size_type_node, extent));
7609 gfc_add_expr_to_block (&se->pre, tmp);
7610
7611 /* For CLASS results, set the _vptr. */
7612 if (mold_expr->ts.type == BT_CLASS)
7613 {
7614 tree vptr;
7615 gfc_symbol *vtab;
7616 vptr = gfc_class_vptr_get (tmpdecl);
7617 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
7618 gcc_assert (vtab);
7619 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
7620 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
7621 }
7622
7623 se->expr = tmpdecl;
7624 }
7625 }
7626
7627
7628 /* Generate a call to caf_is_present. */
7629
7630 static tree
trans_caf_is_present(gfc_se * se,gfc_expr * expr)7631 trans_caf_is_present (gfc_se *se, gfc_expr *expr)
7632 {
7633 tree caf_reference, caf_decl, token, image_index;
7634
7635 /* Compile the reference chain. */
7636 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
7637 gcc_assert (caf_reference != NULL_TREE);
7638
7639 caf_decl = gfc_get_tree_for_caf_expr (expr);
7640 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
7641 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
7642 image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
7643 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
7644 expr);
7645
7646 return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
7647 3, token, image_index, caf_reference);
7648 }
7649
7650
7651 /* Test whether this ref-chain refs this image only. */
7652
7653 static bool
caf_this_image_ref(gfc_ref * ref)7654 caf_this_image_ref (gfc_ref *ref)
7655 {
7656 for ( ; ref; ref = ref->next)
7657 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
7658 return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
7659
7660 return false;
7661 }
7662
7663
7664 /* Generate code for the ALLOCATED intrinsic.
7665 Generate inline code that directly check the address of the argument. */
7666
7667 static void
gfc_conv_allocated(gfc_se * se,gfc_expr * expr)7668 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
7669 {
7670 gfc_actual_arglist *arg1;
7671 gfc_se arg1se;
7672 tree tmp;
7673 symbol_attribute caf_attr;
7674
7675 gfc_init_se (&arg1se, NULL);
7676 arg1 = expr->value.function.actual;
7677
7678 if (arg1->expr->ts.type == BT_CLASS)
7679 {
7680 /* Make sure that class array expressions have both a _data
7681 component reference and an array reference.... */
7682 if (CLASS_DATA (arg1->expr)->attr.dimension)
7683 gfc_add_class_array_ref (arg1->expr);
7684 /* .... whilst scalars only need the _data component. */
7685 else
7686 gfc_add_data_component (arg1->expr);
7687 }
7688
7689 /* When arg1 references an allocatable component in a coarray, then call
7690 the caf-library function caf_is_present (). */
7691 if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
7692 && arg1->expr->value.function.isym
7693 && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
7694 caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
7695 else
7696 gfc_clear_attr (&caf_attr);
7697 if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
7698 && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
7699 tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
7700 else
7701 {
7702 if (arg1->expr->rank == 0)
7703 {
7704 /* Allocatable scalar. */
7705 arg1se.want_pointer = 1;
7706 gfc_conv_expr (&arg1se, arg1->expr);
7707 tmp = arg1se.expr;
7708 }
7709 else
7710 {
7711 /* Allocatable array. */
7712 arg1se.descriptor_only = 1;
7713 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7714 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
7715 }
7716
7717 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
7718 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7719 }
7720
7721 /* Components of pointer array references sometimes come back with a pre block. */
7722 if (arg1se.pre.head)
7723 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7724
7725 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7726 }
7727
7728
7729 /* Generate code for the ASSOCIATED intrinsic.
7730 If both POINTER and TARGET are arrays, generate a call to library function
7731 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7732 In other cases, generate inline code that directly compare the address of
7733 POINTER with the address of TARGET. */
7734
7735 static void
gfc_conv_associated(gfc_se * se,gfc_expr * expr)7736 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
7737 {
7738 gfc_actual_arglist *arg1;
7739 gfc_actual_arglist *arg2;
7740 gfc_se arg1se;
7741 gfc_se arg2se;
7742 tree tmp2;
7743 tree tmp;
7744 tree nonzero_charlen;
7745 tree nonzero_arraylen;
7746 gfc_ss *ss;
7747 bool scalar;
7748
7749 gfc_init_se (&arg1se, NULL);
7750 gfc_init_se (&arg2se, NULL);
7751 arg1 = expr->value.function.actual;
7752 arg2 = arg1->next;
7753
7754 /* Check whether the expression is a scalar or not; we cannot use
7755 arg1->expr->rank as it can be nonzero for proc pointers. */
7756 ss = gfc_walk_expr (arg1->expr);
7757 scalar = ss == gfc_ss_terminator;
7758 if (!scalar)
7759 gfc_free_ss_chain (ss);
7760
7761 if (!arg2->expr)
7762 {
7763 /* No optional target. */
7764 if (scalar)
7765 {
7766 /* A pointer to a scalar. */
7767 arg1se.want_pointer = 1;
7768 gfc_conv_expr (&arg1se, arg1->expr);
7769 if (arg1->expr->symtree->n.sym->attr.proc_pointer
7770 && arg1->expr->symtree->n.sym->attr.dummy)
7771 arg1se.expr = build_fold_indirect_ref_loc (input_location,
7772 arg1se.expr);
7773 if (arg1->expr->ts.type == BT_CLASS)
7774 {
7775 tmp2 = gfc_class_data_get (arg1se.expr);
7776 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7777 tmp2 = gfc_conv_descriptor_data_get (tmp2);
7778 }
7779 else
7780 tmp2 = arg1se.expr;
7781 }
7782 else
7783 {
7784 /* A pointer to an array. */
7785 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7786 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
7787 }
7788 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7789 gfc_add_block_to_block (&se->post, &arg1se.post);
7790 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
7791 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
7792 se->expr = tmp;
7793 }
7794 else
7795 {
7796 /* An optional target. */
7797 if (arg2->expr->ts.type == BT_CLASS)
7798 gfc_add_data_component (arg2->expr);
7799
7800 nonzero_charlen = NULL_TREE;
7801 if (arg1->expr->ts.type == BT_CHARACTER)
7802 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
7803 logical_type_node,
7804 arg1->expr->ts.u.cl->backend_decl,
7805 build_zero_cst
7806 (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl)));
7807 if (scalar)
7808 {
7809 /* A pointer to a scalar. */
7810 arg1se.want_pointer = 1;
7811 gfc_conv_expr (&arg1se, arg1->expr);
7812 if (arg1->expr->symtree->n.sym->attr.proc_pointer
7813 && arg1->expr->symtree->n.sym->attr.dummy)
7814 arg1se.expr = build_fold_indirect_ref_loc (input_location,
7815 arg1se.expr);
7816 if (arg1->expr->ts.type == BT_CLASS)
7817 arg1se.expr = gfc_class_data_get (arg1se.expr);
7818
7819 arg2se.want_pointer = 1;
7820 gfc_conv_expr (&arg2se, arg2->expr);
7821 if (arg2->expr->symtree->n.sym->attr.proc_pointer
7822 && arg2->expr->symtree->n.sym->attr.dummy)
7823 arg2se.expr = build_fold_indirect_ref_loc (input_location,
7824 arg2se.expr);
7825 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7826 gfc_add_block_to_block (&se->post, &arg1se.post);
7827 gfc_add_block_to_block (&se->pre, &arg2se.pre);
7828 gfc_add_block_to_block (&se->post, &arg2se.post);
7829 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7830 arg1se.expr, arg2se.expr);
7831 tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7832 arg1se.expr, null_pointer_node);
7833 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7834 logical_type_node, tmp, tmp2);
7835 }
7836 else
7837 {
7838 /* An array pointer of zero length is not associated if target is
7839 present. */
7840 arg1se.descriptor_only = 1;
7841 gfc_conv_expr_lhs (&arg1se, arg1->expr);
7842 if (arg1->expr->rank == -1)
7843 {
7844 tmp = gfc_conv_descriptor_rank (arg1se.expr);
7845 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7846 TREE_TYPE (tmp), tmp, gfc_index_one_node);
7847 }
7848 else
7849 tmp = gfc_rank_cst[arg1->expr->rank - 1];
7850 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
7851 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
7852 logical_type_node, tmp,
7853 build_int_cst (TREE_TYPE (tmp), 0));
7854
7855 /* A pointer to an array, call library function _gfor_associated. */
7856 arg1se.want_pointer = 1;
7857 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7858 gfc_add_block_to_block (&se->pre, &arg1se.pre);
7859 gfc_add_block_to_block (&se->post, &arg1se.post);
7860
7861 arg2se.want_pointer = 1;
7862 gfc_conv_expr_descriptor (&arg2se, arg2->expr);
7863 gfc_add_block_to_block (&se->pre, &arg2se.pre);
7864 gfc_add_block_to_block (&se->post, &arg2se.post);
7865 se->expr = build_call_expr_loc (input_location,
7866 gfor_fndecl_associated, 2,
7867 arg1se.expr, arg2se.expr);
7868 se->expr = convert (logical_type_node, se->expr);
7869 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7870 logical_type_node, se->expr,
7871 nonzero_arraylen);
7872 }
7873
7874 /* If target is present zero character length pointers cannot
7875 be associated. */
7876 if (nonzero_charlen != NULL_TREE)
7877 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7878 logical_type_node,
7879 se->expr, nonzero_charlen);
7880 }
7881
7882 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7883 }
7884
7885
7886 /* Generate code for the SAME_TYPE_AS intrinsic.
7887 Generate inline code that directly checks the vindices. */
7888
7889 static void
gfc_conv_same_type_as(gfc_se * se,gfc_expr * expr)7890 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
7891 {
7892 gfc_expr *a, *b;
7893 gfc_se se1, se2;
7894 tree tmp;
7895 tree conda = NULL_TREE, condb = NULL_TREE;
7896
7897 gfc_init_se (&se1, NULL);
7898 gfc_init_se (&se2, NULL);
7899
7900 a = expr->value.function.actual->expr;
7901 b = expr->value.function.actual->next->expr;
7902
7903 if (UNLIMITED_POLY (a))
7904 {
7905 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
7906 conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7907 tmp, build_int_cst (TREE_TYPE (tmp), 0));
7908 }
7909
7910 if (UNLIMITED_POLY (b))
7911 {
7912 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
7913 condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7914 tmp, build_int_cst (TREE_TYPE (tmp), 0));
7915 }
7916
7917 if (a->ts.type == BT_CLASS)
7918 {
7919 gfc_add_vptr_component (a);
7920 gfc_add_hash_component (a);
7921 }
7922 else if (a->ts.type == BT_DERIVED)
7923 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7924 a->ts.u.derived->hash_value);
7925
7926 if (b->ts.type == BT_CLASS)
7927 {
7928 gfc_add_vptr_component (b);
7929 gfc_add_hash_component (b);
7930 }
7931 else if (b->ts.type == BT_DERIVED)
7932 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7933 b->ts.u.derived->hash_value);
7934
7935 gfc_conv_expr (&se1, a);
7936 gfc_conv_expr (&se2, b);
7937
7938 tmp = fold_build2_loc (input_location, EQ_EXPR,
7939 logical_type_node, se1.expr,
7940 fold_convert (TREE_TYPE (se1.expr), se2.expr));
7941
7942 if (conda)
7943 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7944 logical_type_node, conda, tmp);
7945
7946 if (condb)
7947 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7948 logical_type_node, condb, tmp);
7949
7950 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7951 }
7952
7953
7954 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
7955
7956 static void
gfc_conv_intrinsic_sc_kind(gfc_se * se,gfc_expr * expr)7957 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
7958 {
7959 tree args[2];
7960
7961 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7962 se->expr = build_call_expr_loc (input_location,
7963 gfor_fndecl_sc_kind, 2, args[0], args[1]);
7964 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7965 }
7966
7967
7968 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
7969
7970 static void
gfc_conv_intrinsic_si_kind(gfc_se * se,gfc_expr * expr)7971 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
7972 {
7973 tree arg, type;
7974
7975 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7976
7977 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
7978 type = gfc_get_int_type (4);
7979 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
7980
7981 /* Convert it to the required type. */
7982 type = gfc_typenode_for_spec (&expr->ts);
7983 se->expr = build_call_expr_loc (input_location,
7984 gfor_fndecl_si_kind, 1, arg);
7985 se->expr = fold_convert (type, se->expr);
7986 }
7987
7988
7989 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
7990
7991 static void
gfc_conv_intrinsic_sr_kind(gfc_se * se,gfc_expr * expr)7992 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
7993 {
7994 gfc_actual_arglist *actual;
7995 tree type;
7996 gfc_se argse;
7997 vec<tree, va_gc> *args = NULL;
7998
7999 for (actual = expr->value.function.actual; actual; actual = actual->next)
8000 {
8001 gfc_init_se (&argse, se);
8002
8003 /* Pass a NULL pointer for an absent arg. */
8004 if (actual->expr == NULL)
8005 argse.expr = null_pointer_node;
8006 else
8007 {
8008 gfc_typespec ts;
8009 gfc_clear_ts (&ts);
8010
8011 if (actual->expr->ts.kind != gfc_c_int_kind)
8012 {
8013 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8014 ts.type = BT_INTEGER;
8015 ts.kind = gfc_c_int_kind;
8016 gfc_convert_type (actual->expr, &ts, 2);
8017 }
8018 gfc_conv_expr_reference (&argse, actual->expr);
8019 }
8020
8021 gfc_add_block_to_block (&se->pre, &argse.pre);
8022 gfc_add_block_to_block (&se->post, &argse.post);
8023 vec_safe_push (args, argse.expr);
8024 }
8025
8026 /* Convert it to the required type. */
8027 type = gfc_typenode_for_spec (&expr->ts);
8028 se->expr = build_call_expr_loc_vec (input_location,
8029 gfor_fndecl_sr_kind, args);
8030 se->expr = fold_convert (type, se->expr);
8031 }
8032
8033
8034 /* Generate code for TRIM (A) intrinsic function. */
8035
8036 static void
gfc_conv_intrinsic_trim(gfc_se * se,gfc_expr * expr)8037 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
8038 {
8039 tree var;
8040 tree len;
8041 tree addr;
8042 tree tmp;
8043 tree cond;
8044 tree fndecl;
8045 tree function;
8046 tree *args;
8047 unsigned int num_args;
8048
8049 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
8050 args = XALLOCAVEC (tree, num_args);
8051
8052 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
8053 addr = gfc_build_addr_expr (ppvoid_type_node, var);
8054 len = gfc_create_var (gfc_charlen_type_node, "len");
8055
8056 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
8057 args[0] = gfc_build_addr_expr (NULL_TREE, len);
8058 args[1] = addr;
8059
8060 if (expr->ts.kind == 1)
8061 function = gfor_fndecl_string_trim;
8062 else if (expr->ts.kind == 4)
8063 function = gfor_fndecl_string_trim_char4;
8064 else
8065 gcc_unreachable ();
8066
8067 fndecl = build_addr (function);
8068 tmp = build_call_array_loc (input_location,
8069 TREE_TYPE (TREE_TYPE (function)), fndecl,
8070 num_args, args);
8071 gfc_add_expr_to_block (&se->pre, tmp);
8072
8073 /* Free the temporary afterwards, if necessary. */
8074 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8075 len, build_int_cst (TREE_TYPE (len), 0));
8076 tmp = gfc_call_free (var);
8077 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
8078 gfc_add_expr_to_block (&se->post, tmp);
8079
8080 se->expr = var;
8081 se->string_length = len;
8082 }
8083
8084
8085 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8086
8087 static void
gfc_conv_intrinsic_repeat(gfc_se * se,gfc_expr * expr)8088 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
8089 {
8090 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
8091 tree type, cond, tmp, count, exit_label, n, max, largest;
8092 tree size;
8093 stmtblock_t block, body;
8094 int i;
8095
8096 /* We store in charsize the size of a character. */
8097 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
8098 size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
8099
8100 /* Get the arguments. */
8101 gfc_conv_intrinsic_function_args (se, expr, args, 3);
8102 slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
8103 src = args[1];
8104 ncopies = gfc_evaluate_now (args[2], &se->pre);
8105 ncopies_type = TREE_TYPE (ncopies);
8106
8107 /* Check that NCOPIES is not negative. */
8108 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
8109 build_int_cst (ncopies_type, 0));
8110 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
8111 "Argument NCOPIES of REPEAT intrinsic is negative "
8112 "(its value is %ld)",
8113 fold_convert (long_integer_type_node, ncopies));
8114
8115 /* If the source length is zero, any non negative value of NCOPIES
8116 is valid, and nothing happens. */
8117 n = gfc_create_var (ncopies_type, "ncopies");
8118 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
8119 size_zero_node);
8120 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
8121 build_int_cst (ncopies_type, 0), ncopies);
8122 gfc_add_modify (&se->pre, n, tmp);
8123 ncopies = n;
8124
8125 /* Check that ncopies is not too large: ncopies should be less than
8126 (or equal to) MAX / slen, where MAX is the maximal integer of
8127 the gfc_charlen_type_node type. If slen == 0, we need a special
8128 case to avoid the division by zero. */
8129 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
8130 fold_convert (sizetype,
8131 TYPE_MAX_VALUE (gfc_charlen_type_node)),
8132 slen);
8133 largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
8134 ? sizetype : ncopies_type;
8135 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8136 fold_convert (largest, ncopies),
8137 fold_convert (largest, max));
8138 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
8139 size_zero_node);
8140 cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
8141 logical_false_node, cond);
8142 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
8143 "Argument NCOPIES of REPEAT intrinsic is too large");
8144
8145 /* Compute the destination length. */
8146 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
8147 fold_convert (gfc_charlen_type_node, slen),
8148 fold_convert (gfc_charlen_type_node, ncopies));
8149 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
8150 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
8151
8152 /* Generate the code to do the repeat operation:
8153 for (i = 0; i < ncopies; i++)
8154 memmove (dest + (i * slen * size), src, slen*size); */
8155 gfc_start_block (&block);
8156 count = gfc_create_var (sizetype, "count");
8157 gfc_add_modify (&block, count, size_zero_node);
8158 exit_label = gfc_build_label_decl (NULL_TREE);
8159
8160 /* Start the loop body. */
8161 gfc_start_block (&body);
8162
8163 /* Exit the loop if count >= ncopies. */
8164 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
8165 fold_convert (sizetype, ncopies));
8166 tmp = build1_v (GOTO_EXPR, exit_label);
8167 TREE_USED (exit_label) = 1;
8168 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8169 build_empty_stmt (input_location));
8170 gfc_add_expr_to_block (&body, tmp);
8171
8172 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8173 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
8174 count);
8175 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
8176 size);
8177 tmp = fold_build_pointer_plus_loc (input_location,
8178 fold_convert (pvoid_type_node, dest), tmp);
8179 tmp = build_call_expr_loc (input_location,
8180 builtin_decl_explicit (BUILT_IN_MEMMOVE),
8181 3, tmp, src,
8182 fold_build2_loc (input_location, MULT_EXPR,
8183 size_type_node, slen, size));
8184 gfc_add_expr_to_block (&body, tmp);
8185
8186 /* Increment count. */
8187 tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
8188 count, size_one_node);
8189 gfc_add_modify (&body, count, tmp);
8190
8191 /* Build the loop. */
8192 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
8193 gfc_add_expr_to_block (&block, tmp);
8194
8195 /* Add the exit label. */
8196 tmp = build1_v (LABEL_EXPR, exit_label);
8197 gfc_add_expr_to_block (&block, tmp);
8198
8199 /* Finish the block. */
8200 tmp = gfc_finish_block (&block);
8201 gfc_add_expr_to_block (&se->pre, tmp);
8202
8203 /* Set the result value. */
8204 se->expr = dest;
8205 se->string_length = dlen;
8206 }
8207
8208
8209 /* Generate code for the IARGC intrinsic. */
8210
8211 static void
gfc_conv_intrinsic_iargc(gfc_se * se,gfc_expr * expr)8212 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
8213 {
8214 tree tmp;
8215 tree fndecl;
8216 tree type;
8217
8218 /* Call the library function. This always returns an INTEGER(4). */
8219 fndecl = gfor_fndecl_iargc;
8220 tmp = build_call_expr_loc (input_location,
8221 fndecl, 0);
8222
8223 /* Convert it to the required type. */
8224 type = gfc_typenode_for_spec (&expr->ts);
8225 tmp = fold_convert (type, tmp);
8226
8227 se->expr = tmp;
8228 }
8229
8230
8231 /* Generate code for the KILL intrinsic. */
8232
8233 static void
conv_intrinsic_kill(gfc_se * se,gfc_expr * expr)8234 conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
8235 {
8236 tree *args;
8237 tree int4_type_node = gfc_get_int_type (4);
8238 tree pid;
8239 tree sig;
8240 tree tmp;
8241 unsigned int num_args;
8242
8243 num_args = gfc_intrinsic_argument_list_length (expr);
8244 args = XALLOCAVEC (tree, num_args);
8245 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
8246
8247 /* Convert PID to a INTEGER(4) entity. */
8248 pid = convert (int4_type_node, args[0]);
8249
8250 /* Convert SIG to a INTEGER(4) entity. */
8251 sig = convert (int4_type_node, args[1]);
8252
8253 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
8254
8255 se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
8256 }
8257
8258
8259 static tree
conv_intrinsic_kill_sub(gfc_code * code)8260 conv_intrinsic_kill_sub (gfc_code *code)
8261 {
8262 stmtblock_t block;
8263 gfc_se se, se_stat;
8264 tree int4_type_node = gfc_get_int_type (4);
8265 tree pid;
8266 tree sig;
8267 tree statp;
8268 tree tmp;
8269
8270 /* Make the function call. */
8271 gfc_init_block (&block);
8272 gfc_init_se (&se, NULL);
8273
8274 /* Convert PID to a INTEGER(4) entity. */
8275 gfc_conv_expr (&se, code->ext.actual->expr);
8276 gfc_add_block_to_block (&block, &se.pre);
8277 pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
8278 gfc_add_block_to_block (&block, &se.post);
8279
8280 /* Convert SIG to a INTEGER(4) entity. */
8281 gfc_conv_expr (&se, code->ext.actual->next->expr);
8282 gfc_add_block_to_block (&block, &se.pre);
8283 sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
8284 gfc_add_block_to_block (&block, &se.post);
8285
8286 /* Deal with an optional STATUS. */
8287 if (code->ext.actual->next->next->expr)
8288 {
8289 gfc_init_se (&se_stat, NULL);
8290 gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
8291 statp = gfc_create_var (gfc_get_int_type (4), "_statp");
8292 }
8293 else
8294 statp = NULL_TREE;
8295
8296 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
8297 statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
8298
8299 gfc_add_expr_to_block (&block, tmp);
8300
8301 if (statp && statp != se_stat.expr)
8302 gfc_add_modify (&block, se_stat.expr,
8303 fold_convert (TREE_TYPE (se_stat.expr), statp));
8304
8305 return gfc_finish_block (&block);
8306 }
8307
8308
8309
8310 /* The loc intrinsic returns the address of its argument as
8311 gfc_index_integer_kind integer. */
8312
8313 static void
gfc_conv_intrinsic_loc(gfc_se * se,gfc_expr * expr)8314 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
8315 {
8316 tree temp_var;
8317 gfc_expr *arg_expr;
8318
8319 gcc_assert (!se->ss);
8320
8321 arg_expr = expr->value.function.actual->expr;
8322 if (arg_expr->rank == 0)
8323 {
8324 if (arg_expr->ts.type == BT_CLASS)
8325 gfc_add_data_component (arg_expr);
8326 gfc_conv_expr_reference (se, arg_expr);
8327 }
8328 else
8329 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
8330 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
8331
8332 /* Create a temporary variable for loc return value. Without this,
8333 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8334 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
8335 gfc_add_modify (&se->pre, temp_var, se->expr);
8336 se->expr = temp_var;
8337 }
8338
8339
8340 /* The following routine generates code for the intrinsic
8341 functions from the ISO_C_BINDING module:
8342 * C_LOC
8343 * C_FUNLOC
8344 * C_ASSOCIATED */
8345
8346 static void
conv_isocbinding_function(gfc_se * se,gfc_expr * expr)8347 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
8348 {
8349 gfc_actual_arglist *arg = expr->value.function.actual;
8350
8351 if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
8352 {
8353 if (arg->expr->rank == 0)
8354 gfc_conv_expr_reference (se, arg->expr);
8355 else if (gfc_is_simply_contiguous (arg->expr, false, false))
8356 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
8357 else
8358 {
8359 gfc_conv_expr_descriptor (se, arg->expr);
8360 se->expr = gfc_conv_descriptor_data_get (se->expr);
8361 }
8362
8363 /* TODO -- the following two lines shouldn't be necessary, but if
8364 they're removed, a bug is exposed later in the code path.
8365 This workaround was thus introduced, but will have to be
8366 removed; please see PR 35150 for details about the issue. */
8367 se->expr = convert (pvoid_type_node, se->expr);
8368 se->expr = gfc_evaluate_now (se->expr, &se->pre);
8369 }
8370 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
8371 gfc_conv_expr_reference (se, arg->expr);
8372 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
8373 {
8374 gfc_se arg1se;
8375 gfc_se arg2se;
8376
8377 /* Build the addr_expr for the first argument. The argument is
8378 already an *address* so we don't need to set want_pointer in
8379 the gfc_se. */
8380 gfc_init_se (&arg1se, NULL);
8381 gfc_conv_expr (&arg1se, arg->expr);
8382 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8383 gfc_add_block_to_block (&se->post, &arg1se.post);
8384
8385 /* See if we were given two arguments. */
8386 if (arg->next->expr == NULL)
8387 /* Only given one arg so generate a null and do a
8388 not-equal comparison against the first arg. */
8389 se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8390 arg1se.expr,
8391 fold_convert (TREE_TYPE (arg1se.expr),
8392 null_pointer_node));
8393 else
8394 {
8395 tree eq_expr;
8396 tree not_null_expr;
8397
8398 /* Given two arguments so build the arg2se from second arg. */
8399 gfc_init_se (&arg2se, NULL);
8400 gfc_conv_expr (&arg2se, arg->next->expr);
8401 gfc_add_block_to_block (&se->pre, &arg2se.pre);
8402 gfc_add_block_to_block (&se->post, &arg2se.post);
8403
8404 /* Generate test to compare that the two args are equal. */
8405 eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8406 arg1se.expr, arg2se.expr);
8407 /* Generate test to ensure that the first arg is not null. */
8408 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
8409 logical_type_node,
8410 arg1se.expr, null_pointer_node);
8411
8412 /* Finally, the generated test must check that both arg1 is not
8413 NULL and that it is equal to the second arg. */
8414 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8415 logical_type_node,
8416 not_null_expr, eq_expr);
8417 }
8418 }
8419 else
8420 gcc_unreachable ();
8421 }
8422
8423
8424 /* The following routine generates code for the intrinsic
8425 subroutines from the ISO_C_BINDING module:
8426 * C_F_POINTER
8427 * C_F_PROCPOINTER. */
8428
8429 static tree
conv_isocbinding_subroutine(gfc_code * code)8430 conv_isocbinding_subroutine (gfc_code *code)
8431 {
8432 gfc_se se;
8433 gfc_se cptrse;
8434 gfc_se fptrse;
8435 gfc_se shapese;
8436 gfc_ss *shape_ss;
8437 tree desc, dim, tmp, stride, offset;
8438 stmtblock_t body, block;
8439 gfc_loopinfo loop;
8440 gfc_actual_arglist *arg = code->ext.actual;
8441
8442 gfc_init_se (&se, NULL);
8443 gfc_init_se (&cptrse, NULL);
8444 gfc_conv_expr (&cptrse, arg->expr);
8445 gfc_add_block_to_block (&se.pre, &cptrse.pre);
8446 gfc_add_block_to_block (&se.post, &cptrse.post);
8447
8448 gfc_init_se (&fptrse, NULL);
8449 if (arg->next->expr->rank == 0)
8450 {
8451 fptrse.want_pointer = 1;
8452 gfc_conv_expr (&fptrse, arg->next->expr);
8453 gfc_add_block_to_block (&se.pre, &fptrse.pre);
8454 gfc_add_block_to_block (&se.post, &fptrse.post);
8455 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
8456 && arg->next->expr->symtree->n.sym->attr.dummy)
8457 fptrse.expr = build_fold_indirect_ref_loc (input_location,
8458 fptrse.expr);
8459 se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
8460 TREE_TYPE (fptrse.expr),
8461 fptrse.expr,
8462 fold_convert (TREE_TYPE (fptrse.expr),
8463 cptrse.expr));
8464 gfc_add_expr_to_block (&se.pre, se.expr);
8465 gfc_add_block_to_block (&se.pre, &se.post);
8466 return gfc_finish_block (&se.pre);
8467 }
8468
8469 gfc_start_block (&block);
8470
8471 /* Get the descriptor of the Fortran pointer. */
8472 fptrse.descriptor_only = 1;
8473 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
8474 gfc_add_block_to_block (&block, &fptrse.pre);
8475 desc = fptrse.expr;
8476
8477 /* Set the span field. */
8478 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8479 tmp = fold_convert (gfc_array_index_type, tmp);
8480 gfc_conv_descriptor_span_set (&block, desc, tmp);
8481
8482 /* Set data value, dtype, and offset. */
8483 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
8484 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
8485 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
8486 gfc_get_dtype (TREE_TYPE (desc)));
8487
8488 /* Start scalarization of the bounds, using the shape argument. */
8489
8490 shape_ss = gfc_walk_expr (arg->next->next->expr);
8491 gcc_assert (shape_ss != gfc_ss_terminator);
8492 gfc_init_se (&shapese, NULL);
8493
8494 gfc_init_loopinfo (&loop);
8495 gfc_add_ss_to_loop (&loop, shape_ss);
8496 gfc_conv_ss_startstride (&loop);
8497 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
8498 gfc_mark_ss_chain_used (shape_ss, 1);
8499
8500 gfc_copy_loopinfo_to_se (&shapese, &loop);
8501 shapese.ss = shape_ss;
8502
8503 stride = gfc_create_var (gfc_array_index_type, "stride");
8504 offset = gfc_create_var (gfc_array_index_type, "offset");
8505 gfc_add_modify (&block, stride, gfc_index_one_node);
8506 gfc_add_modify (&block, offset, gfc_index_zero_node);
8507
8508 /* Loop body. */
8509 gfc_start_scalarized_body (&loop, &body);
8510
8511 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8512 loop.loopvar[0], loop.from[0]);
8513
8514 /* Set bounds and stride. */
8515 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
8516 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
8517
8518 gfc_conv_expr (&shapese, arg->next->next->expr);
8519 gfc_add_block_to_block (&body, &shapese.pre);
8520 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
8521 gfc_add_block_to_block (&body, &shapese.post);
8522
8523 /* Calculate offset. */
8524 gfc_add_modify (&body, offset,
8525 fold_build2_loc (input_location, PLUS_EXPR,
8526 gfc_array_index_type, offset, stride));
8527 /* Update stride. */
8528 gfc_add_modify (&body, stride,
8529 fold_build2_loc (input_location, MULT_EXPR,
8530 gfc_array_index_type, stride,
8531 fold_convert (gfc_array_index_type,
8532 shapese.expr)));
8533 /* Finish scalarization loop. */
8534 gfc_trans_scalarizing_loops (&loop, &body);
8535 gfc_add_block_to_block (&block, &loop.pre);
8536 gfc_add_block_to_block (&block, &loop.post);
8537 gfc_add_block_to_block (&block, &fptrse.post);
8538 gfc_cleanup_loop (&loop);
8539
8540 gfc_add_modify (&block, offset,
8541 fold_build1_loc (input_location, NEGATE_EXPR,
8542 gfc_array_index_type, offset));
8543 gfc_conv_descriptor_offset_set (&block, desc, offset);
8544
8545 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
8546 gfc_add_block_to_block (&se.pre, &se.post);
8547 return gfc_finish_block (&se.pre);
8548 }
8549
8550
8551 /* Save and restore floating-point state. */
8552
8553 tree
gfc_save_fp_state(stmtblock_t * block)8554 gfc_save_fp_state (stmtblock_t *block)
8555 {
8556 tree type, fpstate, tmp;
8557
8558 type = build_array_type (char_type_node,
8559 build_range_type (size_type_node, size_zero_node,
8560 size_int (GFC_FPE_STATE_BUFFER_SIZE)));
8561 fpstate = gfc_create_var (type, "fpstate");
8562 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
8563
8564 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
8565 1, fpstate);
8566 gfc_add_expr_to_block (block, tmp);
8567
8568 return fpstate;
8569 }
8570
8571
8572 void
gfc_restore_fp_state(stmtblock_t * block,tree fpstate)8573 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
8574 {
8575 tree tmp;
8576
8577 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
8578 1, fpstate);
8579 gfc_add_expr_to_block (block, tmp);
8580 }
8581
8582
8583 /* Generate code for arguments of IEEE functions. */
8584
8585 static void
conv_ieee_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)8586 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
8587 int nargs)
8588 {
8589 gfc_actual_arglist *actual;
8590 gfc_expr *e;
8591 gfc_se argse;
8592 int arg;
8593
8594 actual = expr->value.function.actual;
8595 for (arg = 0; arg < nargs; arg++, actual = actual->next)
8596 {
8597 gcc_assert (actual);
8598 e = actual->expr;
8599
8600 gfc_init_se (&argse, se);
8601 gfc_conv_expr_val (&argse, e);
8602
8603 gfc_add_block_to_block (&se->pre, &argse.pre);
8604 gfc_add_block_to_block (&se->post, &argse.post);
8605 argarray[arg] = argse.expr;
8606 }
8607 }
8608
8609
8610 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8611 and IEEE_UNORDERED, which translate directly to GCC type-generic
8612 built-ins. */
8613
8614 static void
conv_intrinsic_ieee_builtin(gfc_se * se,gfc_expr * expr,enum built_in_function code,int nargs)8615 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
8616 enum built_in_function code, int nargs)
8617 {
8618 tree args[2];
8619 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
8620
8621 conv_ieee_function_args (se, expr, args, nargs);
8622 se->expr = build_call_expr_loc_array (input_location,
8623 builtin_decl_explicit (code),
8624 nargs, args);
8625 STRIP_TYPE_NOPS (se->expr);
8626 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8627 }
8628
8629
8630 /* Generate code for IEEE_IS_NORMAL intrinsic:
8631 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
8632
8633 static void
conv_intrinsic_ieee_is_normal(gfc_se * se,gfc_expr * expr)8634 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
8635 {
8636 tree arg, isnormal, iszero;
8637
8638 /* Convert arg, evaluate it only once. */
8639 conv_ieee_function_args (se, expr, &arg, 1);
8640 arg = gfc_evaluate_now (arg, &se->pre);
8641
8642 isnormal = build_call_expr_loc (input_location,
8643 builtin_decl_explicit (BUILT_IN_ISNORMAL),
8644 1, arg);
8645 iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8646 build_real_from_int_cst (TREE_TYPE (arg),
8647 integer_zero_node));
8648 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8649 logical_type_node, isnormal, iszero);
8650 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8651 }
8652
8653
8654 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8655 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
8656
8657 static void
conv_intrinsic_ieee_is_negative(gfc_se * se,gfc_expr * expr)8658 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
8659 {
8660 tree arg, signbit, isnan;
8661
8662 /* Convert arg, evaluate it only once. */
8663 conv_ieee_function_args (se, expr, &arg, 1);
8664 arg = gfc_evaluate_now (arg, &se->pre);
8665
8666 isnan = build_call_expr_loc (input_location,
8667 builtin_decl_explicit (BUILT_IN_ISNAN),
8668 1, arg);
8669 STRIP_TYPE_NOPS (isnan);
8670
8671 signbit = build_call_expr_loc (input_location,
8672 builtin_decl_explicit (BUILT_IN_SIGNBIT),
8673 1, arg);
8674 signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8675 signbit, integer_zero_node);
8676
8677 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8678 logical_type_node, signbit,
8679 fold_build1_loc (input_location, TRUTH_NOT_EXPR,
8680 TREE_TYPE(isnan), isnan));
8681
8682 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8683 }
8684
8685
8686 /* Generate code for IEEE_LOGB and IEEE_RINT. */
8687
8688 static void
conv_intrinsic_ieee_logb_rint(gfc_se * se,gfc_expr * expr,enum built_in_function code)8689 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
8690 enum built_in_function code)
8691 {
8692 tree arg, decl, call, fpstate;
8693 int argprec;
8694
8695 conv_ieee_function_args (se, expr, &arg, 1);
8696 argprec = TYPE_PRECISION (TREE_TYPE (arg));
8697 decl = builtin_decl_for_precision (code, argprec);
8698
8699 /* Save floating-point state. */
8700 fpstate = gfc_save_fp_state (&se->pre);
8701
8702 /* Make the function call. */
8703 call = build_call_expr_loc (input_location, decl, 1, arg);
8704 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
8705
8706 /* Restore floating-point state. */
8707 gfc_restore_fp_state (&se->post, fpstate);
8708 }
8709
8710
8711 /* Generate code for IEEE_REM. */
8712
8713 static void
conv_intrinsic_ieee_rem(gfc_se * se,gfc_expr * expr)8714 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
8715 {
8716 tree args[2], decl, call, fpstate;
8717 int argprec;
8718
8719 conv_ieee_function_args (se, expr, args, 2);
8720
8721 /* If arguments have unequal size, convert them to the larger. */
8722 if (TYPE_PRECISION (TREE_TYPE (args[0]))
8723 > TYPE_PRECISION (TREE_TYPE (args[1])))
8724 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8725 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
8726 > TYPE_PRECISION (TREE_TYPE (args[0])))
8727 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
8728
8729 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8730 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
8731
8732 /* Save floating-point state. */
8733 fpstate = gfc_save_fp_state (&se->pre);
8734
8735 /* Make the function call. */
8736 call = build_call_expr_loc_array (input_location, decl, 2, args);
8737 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8738
8739 /* Restore floating-point state. */
8740 gfc_restore_fp_state (&se->post, fpstate);
8741 }
8742
8743
8744 /* Generate code for IEEE_NEXT_AFTER. */
8745
8746 static void
conv_intrinsic_ieee_next_after(gfc_se * se,gfc_expr * expr)8747 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
8748 {
8749 tree args[2], decl, call, fpstate;
8750 int argprec;
8751
8752 conv_ieee_function_args (se, expr, args, 2);
8753
8754 /* Result has the characteristics of first argument. */
8755 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8756 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8757 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
8758
8759 /* Save floating-point state. */
8760 fpstate = gfc_save_fp_state (&se->pre);
8761
8762 /* Make the function call. */
8763 call = build_call_expr_loc_array (input_location, decl, 2, args);
8764 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8765
8766 /* Restore floating-point state. */
8767 gfc_restore_fp_state (&se->post, fpstate);
8768 }
8769
8770
8771 /* Generate code for IEEE_SCALB. */
8772
8773 static void
conv_intrinsic_ieee_scalb(gfc_se * se,gfc_expr * expr)8774 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
8775 {
8776 tree args[2], decl, call, huge, type;
8777 int argprec, n;
8778
8779 conv_ieee_function_args (se, expr, args, 2);
8780
8781 /* Result has the characteristics of first argument. */
8782 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8783 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
8784
8785 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
8786 {
8787 /* We need to fold the integer into the range of a C int. */
8788 args[1] = gfc_evaluate_now (args[1], &se->pre);
8789 type = TREE_TYPE (args[1]);
8790
8791 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
8792 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
8793 gfc_c_int_kind);
8794 huge = fold_convert (type, huge);
8795 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
8796 huge);
8797 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
8798 fold_build1_loc (input_location, NEGATE_EXPR,
8799 type, huge));
8800 }
8801
8802 args[1] = fold_convert (integer_type_node, args[1]);
8803
8804 /* Make the function call. */
8805 call = build_call_expr_loc_array (input_location, decl, 2, args);
8806 se->expr = fold_convert (TREE_TYPE (args[0]), call);
8807 }
8808
8809
8810 /* Generate code for IEEE_COPY_SIGN. */
8811
8812 static void
conv_intrinsic_ieee_copy_sign(gfc_se * se,gfc_expr * expr)8813 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
8814 {
8815 tree args[2], decl, sign;
8816 int argprec;
8817
8818 conv_ieee_function_args (se, expr, args, 2);
8819
8820 /* Get the sign of the second argument. */
8821 sign = build_call_expr_loc (input_location,
8822 builtin_decl_explicit (BUILT_IN_SIGNBIT),
8823 1, args[1]);
8824 sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8825 sign, integer_zero_node);
8826
8827 /* Create a value of one, with the right sign. */
8828 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
8829 sign,
8830 fold_build1_loc (input_location, NEGATE_EXPR,
8831 integer_type_node,
8832 integer_one_node),
8833 integer_one_node);
8834 args[1] = fold_convert (TREE_TYPE (args[0]), sign);
8835
8836 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8837 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
8838
8839 se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
8840 }
8841
8842
8843 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8844 module. */
8845
8846 bool
gfc_conv_ieee_arithmetic_function(gfc_se * se,gfc_expr * expr)8847 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
8848 {
8849 const char *name = expr->value.function.name;
8850
8851 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8852
8853 if (STARTS_WITH (name, "_gfortran_ieee_is_nan"))
8854 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
8855 else if (STARTS_WITH (name, "_gfortran_ieee_is_finite"))
8856 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
8857 else if (STARTS_WITH (name, "_gfortran_ieee_unordered"))
8858 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
8859 else if (STARTS_WITH (name, "_gfortran_ieee_is_normal"))
8860 conv_intrinsic_ieee_is_normal (se, expr);
8861 else if (STARTS_WITH (name, "_gfortran_ieee_is_negative"))
8862 conv_intrinsic_ieee_is_negative (se, expr);
8863 else if (STARTS_WITH (name, "_gfortran_ieee_copy_sign"))
8864 conv_intrinsic_ieee_copy_sign (se, expr);
8865 else if (STARTS_WITH (name, "_gfortran_ieee_scalb"))
8866 conv_intrinsic_ieee_scalb (se, expr);
8867 else if (STARTS_WITH (name, "_gfortran_ieee_next_after"))
8868 conv_intrinsic_ieee_next_after (se, expr);
8869 else if (STARTS_WITH (name, "_gfortran_ieee_rem"))
8870 conv_intrinsic_ieee_rem (se, expr);
8871 else if (STARTS_WITH (name, "_gfortran_ieee_logb"))
8872 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
8873 else if (STARTS_WITH (name, "_gfortran_ieee_rint"))
8874 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
8875 else
8876 /* It is not among the functions we translate directly. We return
8877 false, so a library function call is emitted. */
8878 return false;
8879
8880 #undef STARTS_WITH
8881
8882 return true;
8883 }
8884
8885
8886 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
8887
8888 static void
gfc_conv_intrinsic_malloc(gfc_se * se,gfc_expr * expr)8889 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
8890 {
8891 tree arg, res, restype;
8892
8893 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8894 arg = fold_convert (size_type_node, arg);
8895 res = build_call_expr_loc (input_location,
8896 builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
8897 restype = gfc_typenode_for_spec (&expr->ts);
8898 se->expr = fold_convert (restype, res);
8899 }
8900
8901
8902 /* Generate code for an intrinsic function. Some map directly to library
8903 calls, others get special handling. In some cases the name of the function
8904 used depends on the type specifiers. */
8905
8906 void
gfc_conv_intrinsic_function(gfc_se * se,gfc_expr * expr)8907 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
8908 {
8909 const char *name;
8910 int lib, kind;
8911 tree fndecl;
8912
8913 name = &expr->value.function.name[2];
8914
8915 if (expr->rank > 0)
8916 {
8917 lib = gfc_is_intrinsic_libcall (expr);
8918 if (lib != 0)
8919 {
8920 if (lib == 1)
8921 se->ignore_optional = 1;
8922
8923 switch (expr->value.function.isym->id)
8924 {
8925 case GFC_ISYM_EOSHIFT:
8926 case GFC_ISYM_PACK:
8927 case GFC_ISYM_RESHAPE:
8928 /* For all of those the first argument specifies the type and the
8929 third is optional. */
8930 conv_generic_with_optional_char_arg (se, expr, 1, 3);
8931 break;
8932
8933 case GFC_ISYM_MINLOC:
8934 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
8935 break;
8936
8937 case GFC_ISYM_MAXLOC:
8938 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
8939 break;
8940
8941 case GFC_ISYM_SHAPE:
8942 gfc_conv_intrinsic_shape (se, expr);
8943 break;
8944
8945 default:
8946 gfc_conv_intrinsic_funcall (se, expr);
8947 break;
8948 }
8949
8950 return;
8951 }
8952 }
8953
8954 switch (expr->value.function.isym->id)
8955 {
8956 case GFC_ISYM_NONE:
8957 gcc_unreachable ();
8958
8959 case GFC_ISYM_REPEAT:
8960 gfc_conv_intrinsic_repeat (se, expr);
8961 break;
8962
8963 case GFC_ISYM_TRIM:
8964 gfc_conv_intrinsic_trim (se, expr);
8965 break;
8966
8967 case GFC_ISYM_SC_KIND:
8968 gfc_conv_intrinsic_sc_kind (se, expr);
8969 break;
8970
8971 case GFC_ISYM_SI_KIND:
8972 gfc_conv_intrinsic_si_kind (se, expr);
8973 break;
8974
8975 case GFC_ISYM_SR_KIND:
8976 gfc_conv_intrinsic_sr_kind (se, expr);
8977 break;
8978
8979 case GFC_ISYM_EXPONENT:
8980 gfc_conv_intrinsic_exponent (se, expr);
8981 break;
8982
8983 case GFC_ISYM_SCAN:
8984 kind = expr->value.function.actual->expr->ts.kind;
8985 if (kind == 1)
8986 fndecl = gfor_fndecl_string_scan;
8987 else if (kind == 4)
8988 fndecl = gfor_fndecl_string_scan_char4;
8989 else
8990 gcc_unreachable ();
8991
8992 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8993 break;
8994
8995 case GFC_ISYM_VERIFY:
8996 kind = expr->value.function.actual->expr->ts.kind;
8997 if (kind == 1)
8998 fndecl = gfor_fndecl_string_verify;
8999 else if (kind == 4)
9000 fndecl = gfor_fndecl_string_verify_char4;
9001 else
9002 gcc_unreachable ();
9003
9004 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
9005 break;
9006
9007 case GFC_ISYM_ALLOCATED:
9008 gfc_conv_allocated (se, expr);
9009 break;
9010
9011 case GFC_ISYM_ASSOCIATED:
9012 gfc_conv_associated(se, expr);
9013 break;
9014
9015 case GFC_ISYM_SAME_TYPE_AS:
9016 gfc_conv_same_type_as (se, expr);
9017 break;
9018
9019 case GFC_ISYM_ABS:
9020 gfc_conv_intrinsic_abs (se, expr);
9021 break;
9022
9023 case GFC_ISYM_ADJUSTL:
9024 if (expr->ts.kind == 1)
9025 fndecl = gfor_fndecl_adjustl;
9026 else if (expr->ts.kind == 4)
9027 fndecl = gfor_fndecl_adjustl_char4;
9028 else
9029 gcc_unreachable ();
9030
9031 gfc_conv_intrinsic_adjust (se, expr, fndecl);
9032 break;
9033
9034 case GFC_ISYM_ADJUSTR:
9035 if (expr->ts.kind == 1)
9036 fndecl = gfor_fndecl_adjustr;
9037 else if (expr->ts.kind == 4)
9038 fndecl = gfor_fndecl_adjustr_char4;
9039 else
9040 gcc_unreachable ();
9041
9042 gfc_conv_intrinsic_adjust (se, expr, fndecl);
9043 break;
9044
9045 case GFC_ISYM_AIMAG:
9046 gfc_conv_intrinsic_imagpart (se, expr);
9047 break;
9048
9049 case GFC_ISYM_AINT:
9050 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
9051 break;
9052
9053 case GFC_ISYM_ALL:
9054 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
9055 break;
9056
9057 case GFC_ISYM_ANINT:
9058 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
9059 break;
9060
9061 case GFC_ISYM_AND:
9062 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
9063 break;
9064
9065 case GFC_ISYM_ANY:
9066 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
9067 break;
9068
9069 case GFC_ISYM_BTEST:
9070 gfc_conv_intrinsic_btest (se, expr);
9071 break;
9072
9073 case GFC_ISYM_BGE:
9074 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
9075 break;
9076
9077 case GFC_ISYM_BGT:
9078 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
9079 break;
9080
9081 case GFC_ISYM_BLE:
9082 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
9083 break;
9084
9085 case GFC_ISYM_BLT:
9086 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
9087 break;
9088
9089 case GFC_ISYM_C_ASSOCIATED:
9090 case GFC_ISYM_C_FUNLOC:
9091 case GFC_ISYM_C_LOC:
9092 conv_isocbinding_function (se, expr);
9093 break;
9094
9095 case GFC_ISYM_ACHAR:
9096 case GFC_ISYM_CHAR:
9097 gfc_conv_intrinsic_char (se, expr);
9098 break;
9099
9100 case GFC_ISYM_CONVERSION:
9101 case GFC_ISYM_REAL:
9102 case GFC_ISYM_LOGICAL:
9103 case GFC_ISYM_DBLE:
9104 gfc_conv_intrinsic_conversion (se, expr);
9105 break;
9106
9107 /* Integer conversions are handled separately to make sure we get the
9108 correct rounding mode. */
9109 case GFC_ISYM_INT:
9110 case GFC_ISYM_INT2:
9111 case GFC_ISYM_INT8:
9112 case GFC_ISYM_LONG:
9113 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
9114 break;
9115
9116 case GFC_ISYM_NINT:
9117 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
9118 break;
9119
9120 case GFC_ISYM_CEILING:
9121 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
9122 break;
9123
9124 case GFC_ISYM_FLOOR:
9125 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
9126 break;
9127
9128 case GFC_ISYM_MOD:
9129 gfc_conv_intrinsic_mod (se, expr, 0);
9130 break;
9131
9132 case GFC_ISYM_MODULO:
9133 gfc_conv_intrinsic_mod (se, expr, 1);
9134 break;
9135
9136 case GFC_ISYM_CAF_GET:
9137 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
9138 false, NULL);
9139 break;
9140
9141 case GFC_ISYM_CMPLX:
9142 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
9143 break;
9144
9145 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
9146 gfc_conv_intrinsic_iargc (se, expr);
9147 break;
9148
9149 case GFC_ISYM_COMPLEX:
9150 gfc_conv_intrinsic_cmplx (se, expr, 1);
9151 break;
9152
9153 case GFC_ISYM_CONJG:
9154 gfc_conv_intrinsic_conjg (se, expr);
9155 break;
9156
9157 case GFC_ISYM_COUNT:
9158 gfc_conv_intrinsic_count (se, expr);
9159 break;
9160
9161 case GFC_ISYM_CTIME:
9162 gfc_conv_intrinsic_ctime (se, expr);
9163 break;
9164
9165 case GFC_ISYM_DIM:
9166 gfc_conv_intrinsic_dim (se, expr);
9167 break;
9168
9169 case GFC_ISYM_DOT_PRODUCT:
9170 gfc_conv_intrinsic_dot_product (se, expr);
9171 break;
9172
9173 case GFC_ISYM_DPROD:
9174 gfc_conv_intrinsic_dprod (se, expr);
9175 break;
9176
9177 case GFC_ISYM_DSHIFTL:
9178 gfc_conv_intrinsic_dshift (se, expr, true);
9179 break;
9180
9181 case GFC_ISYM_DSHIFTR:
9182 gfc_conv_intrinsic_dshift (se, expr, false);
9183 break;
9184
9185 case GFC_ISYM_FDATE:
9186 gfc_conv_intrinsic_fdate (se, expr);
9187 break;
9188
9189 case GFC_ISYM_FRACTION:
9190 gfc_conv_intrinsic_fraction (se, expr);
9191 break;
9192
9193 case GFC_ISYM_IALL:
9194 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
9195 break;
9196
9197 case GFC_ISYM_IAND:
9198 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
9199 break;
9200
9201 case GFC_ISYM_IANY:
9202 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
9203 break;
9204
9205 case GFC_ISYM_IBCLR:
9206 gfc_conv_intrinsic_singlebitop (se, expr, 0);
9207 break;
9208
9209 case GFC_ISYM_IBITS:
9210 gfc_conv_intrinsic_ibits (se, expr);
9211 break;
9212
9213 case GFC_ISYM_IBSET:
9214 gfc_conv_intrinsic_singlebitop (se, expr, 1);
9215 break;
9216
9217 case GFC_ISYM_IACHAR:
9218 case GFC_ISYM_ICHAR:
9219 /* We assume ASCII character sequence. */
9220 gfc_conv_intrinsic_ichar (se, expr);
9221 break;
9222
9223 case GFC_ISYM_IARGC:
9224 gfc_conv_intrinsic_iargc (se, expr);
9225 break;
9226
9227 case GFC_ISYM_IEOR:
9228 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
9229 break;
9230
9231 case GFC_ISYM_INDEX:
9232 kind = expr->value.function.actual->expr->ts.kind;
9233 if (kind == 1)
9234 fndecl = gfor_fndecl_string_index;
9235 else if (kind == 4)
9236 fndecl = gfor_fndecl_string_index_char4;
9237 else
9238 gcc_unreachable ();
9239
9240 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
9241 break;
9242
9243 case GFC_ISYM_IOR:
9244 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
9245 break;
9246
9247 case GFC_ISYM_IPARITY:
9248 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
9249 break;
9250
9251 case GFC_ISYM_IS_IOSTAT_END:
9252 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
9253 break;
9254
9255 case GFC_ISYM_IS_IOSTAT_EOR:
9256 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
9257 break;
9258
9259 case GFC_ISYM_ISNAN:
9260 gfc_conv_intrinsic_isnan (se, expr);
9261 break;
9262
9263 case GFC_ISYM_KILL:
9264 conv_intrinsic_kill (se, expr);
9265 break;
9266
9267 case GFC_ISYM_LSHIFT:
9268 gfc_conv_intrinsic_shift (se, expr, false, false);
9269 break;
9270
9271 case GFC_ISYM_RSHIFT:
9272 gfc_conv_intrinsic_shift (se, expr, true, true);
9273 break;
9274
9275 case GFC_ISYM_SHIFTA:
9276 gfc_conv_intrinsic_shift (se, expr, true, true);
9277 break;
9278
9279 case GFC_ISYM_SHIFTL:
9280 gfc_conv_intrinsic_shift (se, expr, false, false);
9281 break;
9282
9283 case GFC_ISYM_SHIFTR:
9284 gfc_conv_intrinsic_shift (se, expr, true, false);
9285 break;
9286
9287 case GFC_ISYM_ISHFT:
9288 gfc_conv_intrinsic_ishft (se, expr);
9289 break;
9290
9291 case GFC_ISYM_ISHFTC:
9292 gfc_conv_intrinsic_ishftc (se, expr);
9293 break;
9294
9295 case GFC_ISYM_LEADZ:
9296 gfc_conv_intrinsic_leadz (se, expr);
9297 break;
9298
9299 case GFC_ISYM_TRAILZ:
9300 gfc_conv_intrinsic_trailz (se, expr);
9301 break;
9302
9303 case GFC_ISYM_POPCNT:
9304 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
9305 break;
9306
9307 case GFC_ISYM_POPPAR:
9308 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
9309 break;
9310
9311 case GFC_ISYM_LBOUND:
9312 gfc_conv_intrinsic_bound (se, expr, 0);
9313 break;
9314
9315 case GFC_ISYM_LCOBOUND:
9316 conv_intrinsic_cobound (se, expr);
9317 break;
9318
9319 case GFC_ISYM_TRANSPOSE:
9320 /* The scalarizer has already been set up for reversed dimension access
9321 order ; now we just get the argument value normally. */
9322 gfc_conv_expr (se, expr->value.function.actual->expr);
9323 break;
9324
9325 case GFC_ISYM_LEN:
9326 gfc_conv_intrinsic_len (se, expr);
9327 break;
9328
9329 case GFC_ISYM_LEN_TRIM:
9330 gfc_conv_intrinsic_len_trim (se, expr);
9331 break;
9332
9333 case GFC_ISYM_LGE:
9334 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
9335 break;
9336
9337 case GFC_ISYM_LGT:
9338 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
9339 break;
9340
9341 case GFC_ISYM_LLE:
9342 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
9343 break;
9344
9345 case GFC_ISYM_LLT:
9346 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
9347 break;
9348
9349 case GFC_ISYM_MALLOC:
9350 gfc_conv_intrinsic_malloc (se, expr);
9351 break;
9352
9353 case GFC_ISYM_MASKL:
9354 gfc_conv_intrinsic_mask (se, expr, 1);
9355 break;
9356
9357 case GFC_ISYM_MASKR:
9358 gfc_conv_intrinsic_mask (se, expr, 0);
9359 break;
9360
9361 case GFC_ISYM_MAX:
9362 if (expr->ts.type == BT_CHARACTER)
9363 gfc_conv_intrinsic_minmax_char (se, expr, 1);
9364 else
9365 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
9366 break;
9367
9368 case GFC_ISYM_MAXLOC:
9369 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
9370 break;
9371
9372 case GFC_ISYM_MAXVAL:
9373 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
9374 break;
9375
9376 case GFC_ISYM_MERGE:
9377 gfc_conv_intrinsic_merge (se, expr);
9378 break;
9379
9380 case GFC_ISYM_MERGE_BITS:
9381 gfc_conv_intrinsic_merge_bits (se, expr);
9382 break;
9383
9384 case GFC_ISYM_MIN:
9385 if (expr->ts.type == BT_CHARACTER)
9386 gfc_conv_intrinsic_minmax_char (se, expr, -1);
9387 else
9388 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
9389 break;
9390
9391 case GFC_ISYM_MINLOC:
9392 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9393 break;
9394
9395 case GFC_ISYM_MINVAL:
9396 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
9397 break;
9398
9399 case GFC_ISYM_NEAREST:
9400 gfc_conv_intrinsic_nearest (se, expr);
9401 break;
9402
9403 case GFC_ISYM_NORM2:
9404 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
9405 break;
9406
9407 case GFC_ISYM_NOT:
9408 gfc_conv_intrinsic_not (se, expr);
9409 break;
9410
9411 case GFC_ISYM_OR:
9412 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
9413 break;
9414
9415 case GFC_ISYM_PARITY:
9416 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
9417 break;
9418
9419 case GFC_ISYM_PRESENT:
9420 gfc_conv_intrinsic_present (se, expr);
9421 break;
9422
9423 case GFC_ISYM_PRODUCT:
9424 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
9425 break;
9426
9427 case GFC_ISYM_RANK:
9428 gfc_conv_intrinsic_rank (se, expr);
9429 break;
9430
9431 case GFC_ISYM_RRSPACING:
9432 gfc_conv_intrinsic_rrspacing (se, expr);
9433 break;
9434
9435 case GFC_ISYM_SET_EXPONENT:
9436 gfc_conv_intrinsic_set_exponent (se, expr);
9437 break;
9438
9439 case GFC_ISYM_SCALE:
9440 gfc_conv_intrinsic_scale (se, expr);
9441 break;
9442
9443 case GFC_ISYM_SIGN:
9444 gfc_conv_intrinsic_sign (se, expr);
9445 break;
9446
9447 case GFC_ISYM_SIZE:
9448 gfc_conv_intrinsic_size (se, expr);
9449 break;
9450
9451 case GFC_ISYM_SIZEOF:
9452 case GFC_ISYM_C_SIZEOF:
9453 gfc_conv_intrinsic_sizeof (se, expr);
9454 break;
9455
9456 case GFC_ISYM_STORAGE_SIZE:
9457 gfc_conv_intrinsic_storage_size (se, expr);
9458 break;
9459
9460 case GFC_ISYM_SPACING:
9461 gfc_conv_intrinsic_spacing (se, expr);
9462 break;
9463
9464 case GFC_ISYM_STRIDE:
9465 conv_intrinsic_stride (se, expr);
9466 break;
9467
9468 case GFC_ISYM_SUM:
9469 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
9470 break;
9471
9472 case GFC_ISYM_TEAM_NUMBER:
9473 conv_intrinsic_team_number (se, expr);
9474 break;
9475
9476 case GFC_ISYM_TRANSFER:
9477 if (se->ss && se->ss->info->useflags)
9478 /* Access the previously obtained result. */
9479 gfc_conv_tmp_array_ref (se);
9480 else
9481 gfc_conv_intrinsic_transfer (se, expr);
9482 break;
9483
9484 case GFC_ISYM_TTYNAM:
9485 gfc_conv_intrinsic_ttynam (se, expr);
9486 break;
9487
9488 case GFC_ISYM_UBOUND:
9489 gfc_conv_intrinsic_bound (se, expr, 1);
9490 break;
9491
9492 case GFC_ISYM_UCOBOUND:
9493 conv_intrinsic_cobound (se, expr);
9494 break;
9495
9496 case GFC_ISYM_XOR:
9497 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
9498 break;
9499
9500 case GFC_ISYM_LOC:
9501 gfc_conv_intrinsic_loc (se, expr);
9502 break;
9503
9504 case GFC_ISYM_THIS_IMAGE:
9505 /* For num_images() == 1, handle as LCOBOUND. */
9506 if (expr->value.function.actual->expr
9507 && flag_coarray == GFC_FCOARRAY_SINGLE)
9508 conv_intrinsic_cobound (se, expr);
9509 else
9510 trans_this_image (se, expr);
9511 break;
9512
9513 case GFC_ISYM_IMAGE_INDEX:
9514 trans_image_index (se, expr);
9515 break;
9516
9517 case GFC_ISYM_IMAGE_STATUS:
9518 conv_intrinsic_image_status (se, expr);
9519 break;
9520
9521 case GFC_ISYM_NUM_IMAGES:
9522 trans_num_images (se, expr);
9523 break;
9524
9525 case GFC_ISYM_ACCESS:
9526 case GFC_ISYM_CHDIR:
9527 case GFC_ISYM_CHMOD:
9528 case GFC_ISYM_DTIME:
9529 case GFC_ISYM_ETIME:
9530 case GFC_ISYM_EXTENDS_TYPE_OF:
9531 case GFC_ISYM_FGET:
9532 case GFC_ISYM_FGETC:
9533 case GFC_ISYM_FNUM:
9534 case GFC_ISYM_FPUT:
9535 case GFC_ISYM_FPUTC:
9536 case GFC_ISYM_FSTAT:
9537 case GFC_ISYM_FTELL:
9538 case GFC_ISYM_GETCWD:
9539 case GFC_ISYM_GETGID:
9540 case GFC_ISYM_GETPID:
9541 case GFC_ISYM_GETUID:
9542 case GFC_ISYM_HOSTNM:
9543 case GFC_ISYM_IERRNO:
9544 case GFC_ISYM_IRAND:
9545 case GFC_ISYM_ISATTY:
9546 case GFC_ISYM_JN2:
9547 case GFC_ISYM_LINK:
9548 case GFC_ISYM_LSTAT:
9549 case GFC_ISYM_MATMUL:
9550 case GFC_ISYM_MCLOCK:
9551 case GFC_ISYM_MCLOCK8:
9552 case GFC_ISYM_RAND:
9553 case GFC_ISYM_RENAME:
9554 case GFC_ISYM_SECOND:
9555 case GFC_ISYM_SECNDS:
9556 case GFC_ISYM_SIGNAL:
9557 case GFC_ISYM_STAT:
9558 case GFC_ISYM_SYMLNK:
9559 case GFC_ISYM_SYSTEM:
9560 case GFC_ISYM_TIME:
9561 case GFC_ISYM_TIME8:
9562 case GFC_ISYM_UMASK:
9563 case GFC_ISYM_UNLINK:
9564 case GFC_ISYM_YN2:
9565 gfc_conv_intrinsic_funcall (se, expr);
9566 break;
9567
9568 case GFC_ISYM_EOSHIFT:
9569 case GFC_ISYM_PACK:
9570 case GFC_ISYM_RESHAPE:
9571 /* For those, expr->rank should always be >0 and thus the if above the
9572 switch should have matched. */
9573 gcc_unreachable ();
9574 break;
9575
9576 default:
9577 gfc_conv_intrinsic_lib_function (se, expr);
9578 break;
9579 }
9580 }
9581
9582
9583 static gfc_ss *
walk_inline_intrinsic_transpose(gfc_ss * ss,gfc_expr * expr)9584 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
9585 {
9586 gfc_ss *arg_ss, *tmp_ss;
9587 gfc_actual_arglist *arg;
9588
9589 arg = expr->value.function.actual;
9590
9591 gcc_assert (arg->expr);
9592
9593 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
9594 gcc_assert (arg_ss != gfc_ss_terminator);
9595
9596 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
9597 {
9598 if (tmp_ss->info->type != GFC_SS_SCALAR
9599 && tmp_ss->info->type != GFC_SS_REFERENCE)
9600 {
9601 gcc_assert (tmp_ss->dimen == 2);
9602
9603 /* We just invert dimensions. */
9604 std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
9605 }
9606
9607 /* Stop when tmp_ss points to the last valid element of the chain... */
9608 if (tmp_ss->next == gfc_ss_terminator)
9609 break;
9610 }
9611
9612 /* ... so that we can attach the rest of the chain to it. */
9613 tmp_ss->next = ss;
9614
9615 return arg_ss;
9616 }
9617
9618
9619 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9620 This has the side effect of reversing the nested list, so there is no
9621 need to call gfc_reverse_ss on it (the given list is assumed not to be
9622 reversed yet). */
9623
9624 static gfc_ss *
nest_loop_dimension(gfc_ss * ss,int dim)9625 nest_loop_dimension (gfc_ss *ss, int dim)
9626 {
9627 int ss_dim, i;
9628 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
9629 gfc_loopinfo *new_loop;
9630
9631 gcc_assert (ss != gfc_ss_terminator);
9632
9633 for (; ss != gfc_ss_terminator; ss = ss->next)
9634 {
9635 new_ss = gfc_get_ss ();
9636 new_ss->next = prev_ss;
9637 new_ss->parent = ss;
9638 new_ss->info = ss->info;
9639 new_ss->info->refcount++;
9640 if (ss->dimen != 0)
9641 {
9642 gcc_assert (ss->info->type != GFC_SS_SCALAR
9643 && ss->info->type != GFC_SS_REFERENCE);
9644
9645 new_ss->dimen = 1;
9646 new_ss->dim[0] = ss->dim[dim];
9647
9648 gcc_assert (dim < ss->dimen);
9649
9650 ss_dim = --ss->dimen;
9651 for (i = dim; i < ss_dim; i++)
9652 ss->dim[i] = ss->dim[i + 1];
9653
9654 ss->dim[ss_dim] = 0;
9655 }
9656 prev_ss = new_ss;
9657
9658 if (ss->nested_ss)
9659 {
9660 ss->nested_ss->parent = new_ss;
9661 new_ss->nested_ss = ss->nested_ss;
9662 }
9663 ss->nested_ss = new_ss;
9664 }
9665
9666 new_loop = gfc_get_loopinfo ();
9667 gfc_init_loopinfo (new_loop);
9668
9669 gcc_assert (prev_ss != NULL);
9670 gcc_assert (prev_ss != gfc_ss_terminator);
9671 gfc_add_ss_to_loop (new_loop, prev_ss);
9672 return new_ss->parent;
9673 }
9674
9675
9676 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9677 is to be inlined. */
9678
9679 static gfc_ss *
walk_inline_intrinsic_arith(gfc_ss * ss,gfc_expr * expr)9680 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
9681 {
9682 gfc_ss *tmp_ss, *tail, *array_ss;
9683 gfc_actual_arglist *arg1, *arg2, *arg3;
9684 int sum_dim;
9685 bool scalar_mask = false;
9686
9687 /* The rank of the result will be determined later. */
9688 arg1 = expr->value.function.actual;
9689 arg2 = arg1->next;
9690 arg3 = arg2->next;
9691 gcc_assert (arg3 != NULL);
9692
9693 if (expr->rank == 0)
9694 return ss;
9695
9696 tmp_ss = gfc_ss_terminator;
9697
9698 if (arg3->expr)
9699 {
9700 gfc_ss *mask_ss;
9701
9702 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
9703 if (mask_ss == tmp_ss)
9704 scalar_mask = 1;
9705
9706 tmp_ss = mask_ss;
9707 }
9708
9709 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
9710 gcc_assert (array_ss != tmp_ss);
9711
9712 /* Odd thing: If the mask is scalar, it is used by the frontend after
9713 the array (to make an if around the nested loop). Thus it shall
9714 be after array_ss once the gfc_ss list is reversed. */
9715 if (scalar_mask)
9716 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
9717 else
9718 tmp_ss = array_ss;
9719
9720 /* "Hide" the dimension on which we will sum in the first arg's scalarization
9721 chain. */
9722 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
9723 tail = nest_loop_dimension (tmp_ss, sum_dim);
9724 tail->next = ss;
9725
9726 return tmp_ss;
9727 }
9728
9729
9730 static gfc_ss *
walk_inline_intrinsic_function(gfc_ss * ss,gfc_expr * expr)9731 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
9732 {
9733
9734 switch (expr->value.function.isym->id)
9735 {
9736 case GFC_ISYM_PRODUCT:
9737 case GFC_ISYM_SUM:
9738 return walk_inline_intrinsic_arith (ss, expr);
9739
9740 case GFC_ISYM_TRANSPOSE:
9741 return walk_inline_intrinsic_transpose (ss, expr);
9742
9743 default:
9744 gcc_unreachable ();
9745 }
9746 gcc_unreachable ();
9747 }
9748
9749
9750 /* This generates code to execute before entering the scalarization loop.
9751 Currently does nothing. */
9752
9753 void
gfc_add_intrinsic_ss_code(gfc_loopinfo * loop ATTRIBUTE_UNUSED,gfc_ss * ss)9754 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
9755 {
9756 switch (ss->info->expr->value.function.isym->id)
9757 {
9758 case GFC_ISYM_UBOUND:
9759 case GFC_ISYM_LBOUND:
9760 case GFC_ISYM_UCOBOUND:
9761 case GFC_ISYM_LCOBOUND:
9762 case GFC_ISYM_THIS_IMAGE:
9763 break;
9764
9765 default:
9766 gcc_unreachable ();
9767 }
9768 }
9769
9770
9771 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9772 are expanded into code inside the scalarization loop. */
9773
9774 static gfc_ss *
gfc_walk_intrinsic_bound(gfc_ss * ss,gfc_expr * expr)9775 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
9776 {
9777 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
9778 gfc_add_class_array_ref (expr->value.function.actual->expr);
9779
9780 /* The two argument version returns a scalar. */
9781 if (expr->value.function.actual->next->expr)
9782 return ss;
9783
9784 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
9785 }
9786
9787
9788 /* Walk an intrinsic array libcall. */
9789
9790 static gfc_ss *
gfc_walk_intrinsic_libfunc(gfc_ss * ss,gfc_expr * expr)9791 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
9792 {
9793 gcc_assert (expr->rank > 0);
9794 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
9795 }
9796
9797
9798 /* Return whether the function call expression EXPR will be expanded
9799 inline by gfc_conv_intrinsic_function. */
9800
9801 bool
gfc_inline_intrinsic_function_p(gfc_expr * expr)9802 gfc_inline_intrinsic_function_p (gfc_expr *expr)
9803 {
9804 gfc_actual_arglist *args;
9805
9806 if (!expr->value.function.isym)
9807 return false;
9808
9809 switch (expr->value.function.isym->id)
9810 {
9811 case GFC_ISYM_PRODUCT:
9812 case GFC_ISYM_SUM:
9813 /* Disable inline expansion if code size matters. */
9814 if (optimize_size)
9815 return false;
9816
9817 args = expr->value.function.actual;
9818 /* We need to be able to subset the SUM argument at compile-time. */
9819 if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
9820 return false;
9821
9822 return true;
9823
9824 case GFC_ISYM_TRANSPOSE:
9825 return true;
9826
9827 default:
9828 return false;
9829 }
9830 }
9831
9832
9833 /* Returns nonzero if the specified intrinsic function call maps directly to
9834 an external library call. Should only be used for functions that return
9835 arrays. */
9836
9837 int
gfc_is_intrinsic_libcall(gfc_expr * expr)9838 gfc_is_intrinsic_libcall (gfc_expr * expr)
9839 {
9840 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
9841 gcc_assert (expr->rank > 0);
9842
9843 if (gfc_inline_intrinsic_function_p (expr))
9844 return 0;
9845
9846 switch (expr->value.function.isym->id)
9847 {
9848 case GFC_ISYM_ALL:
9849 case GFC_ISYM_ANY:
9850 case GFC_ISYM_COUNT:
9851 case GFC_ISYM_JN2:
9852 case GFC_ISYM_IANY:
9853 case GFC_ISYM_IALL:
9854 case GFC_ISYM_IPARITY:
9855 case GFC_ISYM_MATMUL:
9856 case GFC_ISYM_MAXLOC:
9857 case GFC_ISYM_MAXVAL:
9858 case GFC_ISYM_MINLOC:
9859 case GFC_ISYM_MINVAL:
9860 case GFC_ISYM_NORM2:
9861 case GFC_ISYM_PARITY:
9862 case GFC_ISYM_PRODUCT:
9863 case GFC_ISYM_SUM:
9864 case GFC_ISYM_SHAPE:
9865 case GFC_ISYM_SPREAD:
9866 case GFC_ISYM_YN2:
9867 /* Ignore absent optional parameters. */
9868 return 1;
9869
9870 case GFC_ISYM_CSHIFT:
9871 case GFC_ISYM_EOSHIFT:
9872 case GFC_ISYM_GET_TEAM:
9873 case GFC_ISYM_FAILED_IMAGES:
9874 case GFC_ISYM_STOPPED_IMAGES:
9875 case GFC_ISYM_PACK:
9876 case GFC_ISYM_RESHAPE:
9877 case GFC_ISYM_UNPACK:
9878 /* Pass absent optional parameters. */
9879 return 2;
9880
9881 default:
9882 return 0;
9883 }
9884 }
9885
9886 /* Walk an intrinsic function. */
9887 gfc_ss *
gfc_walk_intrinsic_function(gfc_ss * ss,gfc_expr * expr,gfc_intrinsic_sym * isym)9888 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
9889 gfc_intrinsic_sym * isym)
9890 {
9891 gcc_assert (isym);
9892
9893 if (isym->elemental)
9894 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
9895 NULL, GFC_SS_SCALAR);
9896
9897 if (expr->rank == 0)
9898 return ss;
9899
9900 if (gfc_inline_intrinsic_function_p (expr))
9901 return walk_inline_intrinsic_function (ss, expr);
9902
9903 if (gfc_is_intrinsic_libcall (expr))
9904 return gfc_walk_intrinsic_libfunc (ss, expr);
9905
9906 /* Special cases. */
9907 switch (isym->id)
9908 {
9909 case GFC_ISYM_LBOUND:
9910 case GFC_ISYM_LCOBOUND:
9911 case GFC_ISYM_UBOUND:
9912 case GFC_ISYM_UCOBOUND:
9913 case GFC_ISYM_THIS_IMAGE:
9914 return gfc_walk_intrinsic_bound (ss, expr);
9915
9916 case GFC_ISYM_TRANSFER:
9917 case GFC_ISYM_CAF_GET:
9918 return gfc_walk_intrinsic_libfunc (ss, expr);
9919
9920 default:
9921 /* This probably meant someone forgot to add an intrinsic to the above
9922 list(s) when they implemented it, or something's gone horribly
9923 wrong. */
9924 gcc_unreachable ();
9925 }
9926 }
9927
9928
9929 static tree
conv_co_collective(gfc_code * code)9930 conv_co_collective (gfc_code *code)
9931 {
9932 gfc_se argse;
9933 stmtblock_t block, post_block;
9934 tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
9935 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
9936
9937 gfc_start_block (&block);
9938 gfc_init_block (&post_block);
9939
9940 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
9941 {
9942 opr_expr = code->ext.actual->next->expr;
9943 image_idx_expr = code->ext.actual->next->next->expr;
9944 stat_expr = code->ext.actual->next->next->next->expr;
9945 errmsg_expr = code->ext.actual->next->next->next->next->expr;
9946 }
9947 else
9948 {
9949 opr_expr = NULL;
9950 image_idx_expr = code->ext.actual->next->expr;
9951 stat_expr = code->ext.actual->next->next->expr;
9952 errmsg_expr = code->ext.actual->next->next->next->expr;
9953 }
9954
9955 /* stat. */
9956 if (stat_expr)
9957 {
9958 gfc_init_se (&argse, NULL);
9959 gfc_conv_expr (&argse, stat_expr);
9960 gfc_add_block_to_block (&block, &argse.pre);
9961 gfc_add_block_to_block (&post_block, &argse.post);
9962 stat = argse.expr;
9963 if (flag_coarray != GFC_FCOARRAY_SINGLE)
9964 stat = gfc_build_addr_expr (NULL_TREE, stat);
9965 }
9966 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
9967 stat = NULL_TREE;
9968 else
9969 stat = null_pointer_node;
9970
9971 /* Early exit for GFC_FCOARRAY_SINGLE. */
9972 if (flag_coarray == GFC_FCOARRAY_SINGLE)
9973 {
9974 if (stat != NULL_TREE)
9975 gfc_add_modify (&block, stat,
9976 fold_convert (TREE_TYPE (stat), integer_zero_node));
9977 return gfc_finish_block (&block);
9978 }
9979
9980 /* Handle the array. */
9981 gfc_init_se (&argse, NULL);
9982 if (code->ext.actual->expr->rank == 0)
9983 {
9984 symbol_attribute attr;
9985 gfc_clear_attr (&attr);
9986 gfc_init_se (&argse, NULL);
9987 gfc_conv_expr (&argse, code->ext.actual->expr);
9988 gfc_add_block_to_block (&block, &argse.pre);
9989 gfc_add_block_to_block (&post_block, &argse.post);
9990 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
9991 array = gfc_build_addr_expr (NULL_TREE, array);
9992 }
9993 else
9994 {
9995 argse.want_pointer = 1;
9996 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
9997 array = argse.expr;
9998 }
9999 gfc_add_block_to_block (&block, &argse.pre);
10000 gfc_add_block_to_block (&post_block, &argse.post);
10001
10002 if (code->ext.actual->expr->ts.type == BT_CHARACTER)
10003 strlen = argse.string_length;
10004 else
10005 strlen = integer_zero_node;
10006
10007 /* image_index. */
10008 if (image_idx_expr)
10009 {
10010 gfc_init_se (&argse, NULL);
10011 gfc_conv_expr (&argse, image_idx_expr);
10012 gfc_add_block_to_block (&block, &argse.pre);
10013 gfc_add_block_to_block (&post_block, &argse.post);
10014 image_index = fold_convert (integer_type_node, argse.expr);
10015 }
10016 else
10017 image_index = integer_zero_node;
10018
10019 /* errmsg. */
10020 if (errmsg_expr)
10021 {
10022 gfc_init_se (&argse, NULL);
10023 gfc_conv_expr (&argse, errmsg_expr);
10024 gfc_add_block_to_block (&block, &argse.pre);
10025 gfc_add_block_to_block (&post_block, &argse.post);
10026 errmsg = argse.expr;
10027 errmsg_len = fold_convert (size_type_node, argse.string_length);
10028 }
10029 else
10030 {
10031 errmsg = null_pointer_node;
10032 errmsg_len = build_zero_cst (size_type_node);
10033 }
10034
10035 /* Generate the function call. */
10036 switch (code->resolved_isym->id)
10037 {
10038 case GFC_ISYM_CO_BROADCAST:
10039 fndecl = gfor_fndecl_co_broadcast;
10040 break;
10041 case GFC_ISYM_CO_MAX:
10042 fndecl = gfor_fndecl_co_max;
10043 break;
10044 case GFC_ISYM_CO_MIN:
10045 fndecl = gfor_fndecl_co_min;
10046 break;
10047 case GFC_ISYM_CO_REDUCE:
10048 fndecl = gfor_fndecl_co_reduce;
10049 break;
10050 case GFC_ISYM_CO_SUM:
10051 fndecl = gfor_fndecl_co_sum;
10052 break;
10053 default:
10054 gcc_unreachable ();
10055 }
10056
10057 if (code->resolved_isym->id == GFC_ISYM_CO_SUM
10058 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
10059 fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
10060 image_index, stat, errmsg, errmsg_len);
10061 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
10062 fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
10063 stat, errmsg, strlen, errmsg_len);
10064 else
10065 {
10066 tree opr, opr_flags;
10067
10068 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10069 int opr_flag_int;
10070 if (gfc_is_proc_ptr_comp (opr_expr))
10071 {
10072 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
10073 opr_flag_int = sym->attr.dimension
10074 || (sym->ts.type == BT_CHARACTER
10075 && !sym->attr.is_bind_c)
10076 ? GFC_CAF_BYREF : 0;
10077 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
10078 && !sym->attr.is_bind_c
10079 ? GFC_CAF_HIDDENLEN : 0;
10080 opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
10081 }
10082 else
10083 {
10084 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
10085 ? GFC_CAF_BYREF : 0;
10086 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
10087 && !opr_expr->symtree->n.sym->attr.is_bind_c
10088 ? GFC_CAF_HIDDENLEN : 0;
10089 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
10090 ? GFC_CAF_ARG_VALUE : 0;
10091 }
10092 opr_flags = build_int_cst (integer_type_node, opr_flag_int);
10093 gfc_conv_expr (&argse, opr_expr);
10094 opr = argse.expr;
10095 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
10096 image_index, stat, errmsg, strlen, errmsg_len);
10097 }
10098
10099 gfc_add_expr_to_block (&block, fndecl);
10100 gfc_add_block_to_block (&block, &post_block);
10101
10102 return gfc_finish_block (&block);
10103 }
10104
10105
10106 static tree
conv_intrinsic_atomic_op(gfc_code * code)10107 conv_intrinsic_atomic_op (gfc_code *code)
10108 {
10109 gfc_se argse;
10110 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
10111 stmtblock_t block, post_block;
10112 gfc_expr *atom_expr = code->ext.actual->expr;
10113 gfc_expr *stat_expr;
10114 built_in_function fn;
10115
10116 if (atom_expr->expr_type == EXPR_FUNCTION
10117 && atom_expr->value.function.isym
10118 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10119 atom_expr = atom_expr->value.function.actual->expr;
10120
10121 gfc_start_block (&block);
10122 gfc_init_block (&post_block);
10123
10124 gfc_init_se (&argse, NULL);
10125 argse.want_pointer = 1;
10126 gfc_conv_expr (&argse, atom_expr);
10127 gfc_add_block_to_block (&block, &argse.pre);
10128 gfc_add_block_to_block (&post_block, &argse.post);
10129 atom = argse.expr;
10130
10131 gfc_init_se (&argse, NULL);
10132 if (flag_coarray == GFC_FCOARRAY_LIB
10133 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
10134 argse.want_pointer = 1;
10135 gfc_conv_expr (&argse, code->ext.actual->next->expr);
10136 gfc_add_block_to_block (&block, &argse.pre);
10137 gfc_add_block_to_block (&post_block, &argse.post);
10138 value = argse.expr;
10139
10140 switch (code->resolved_isym->id)
10141 {
10142 case GFC_ISYM_ATOMIC_ADD:
10143 case GFC_ISYM_ATOMIC_AND:
10144 case GFC_ISYM_ATOMIC_DEF:
10145 case GFC_ISYM_ATOMIC_OR:
10146 case GFC_ISYM_ATOMIC_XOR:
10147 stat_expr = code->ext.actual->next->next->expr;
10148 if (flag_coarray == GFC_FCOARRAY_LIB)
10149 old = null_pointer_node;
10150 break;
10151 default:
10152 gfc_init_se (&argse, NULL);
10153 if (flag_coarray == GFC_FCOARRAY_LIB)
10154 argse.want_pointer = 1;
10155 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
10156 gfc_add_block_to_block (&block, &argse.pre);
10157 gfc_add_block_to_block (&post_block, &argse.post);
10158 old = argse.expr;
10159 stat_expr = code->ext.actual->next->next->next->expr;
10160 }
10161
10162 /* STAT= */
10163 if (stat_expr != NULL)
10164 {
10165 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
10166 gfc_init_se (&argse, NULL);
10167 if (flag_coarray == GFC_FCOARRAY_LIB)
10168 argse.want_pointer = 1;
10169 gfc_conv_expr_val (&argse, stat_expr);
10170 gfc_add_block_to_block (&block, &argse.pre);
10171 gfc_add_block_to_block (&post_block, &argse.post);
10172 stat = argse.expr;
10173 }
10174 else if (flag_coarray == GFC_FCOARRAY_LIB)
10175 stat = null_pointer_node;
10176
10177 if (flag_coarray == GFC_FCOARRAY_LIB)
10178 {
10179 tree image_index, caf_decl, offset, token;
10180 int op;
10181
10182 switch (code->resolved_isym->id)
10183 {
10184 case GFC_ISYM_ATOMIC_ADD:
10185 case GFC_ISYM_ATOMIC_FETCH_ADD:
10186 op = (int) GFC_CAF_ATOMIC_ADD;
10187 break;
10188 case GFC_ISYM_ATOMIC_AND:
10189 case GFC_ISYM_ATOMIC_FETCH_AND:
10190 op = (int) GFC_CAF_ATOMIC_AND;
10191 break;
10192 case GFC_ISYM_ATOMIC_OR:
10193 case GFC_ISYM_ATOMIC_FETCH_OR:
10194 op = (int) GFC_CAF_ATOMIC_OR;
10195 break;
10196 case GFC_ISYM_ATOMIC_XOR:
10197 case GFC_ISYM_ATOMIC_FETCH_XOR:
10198 op = (int) GFC_CAF_ATOMIC_XOR;
10199 break;
10200 case GFC_ISYM_ATOMIC_DEF:
10201 op = 0; /* Unused. */
10202 break;
10203 default:
10204 gcc_unreachable ();
10205 }
10206
10207 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10208 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10209 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10210
10211 if (gfc_is_coindexed (atom_expr))
10212 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10213 else
10214 image_index = integer_zero_node;
10215
10216 if (!POINTER_TYPE_P (TREE_TYPE (value)))
10217 {
10218 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
10219 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
10220 value = gfc_build_addr_expr (NULL_TREE, tmp);
10221 }
10222
10223 gfc_init_se (&argse, NULL);
10224 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10225 atom_expr);
10226
10227 gfc_add_block_to_block (&block, &argse.pre);
10228 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
10229 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
10230 token, offset, image_index, value, stat,
10231 build_int_cst (integer_type_node,
10232 (int) atom_expr->ts.type),
10233 build_int_cst (integer_type_node,
10234 (int) atom_expr->ts.kind));
10235 else
10236 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
10237 build_int_cst (integer_type_node, op),
10238 token, offset, image_index, value, old, stat,
10239 build_int_cst (integer_type_node,
10240 (int) atom_expr->ts.type),
10241 build_int_cst (integer_type_node,
10242 (int) atom_expr->ts.kind));
10243
10244 gfc_add_expr_to_block (&block, tmp);
10245 gfc_add_block_to_block (&block, &argse.post);
10246 gfc_add_block_to_block (&block, &post_block);
10247 return gfc_finish_block (&block);
10248 }
10249
10250
10251 switch (code->resolved_isym->id)
10252 {
10253 case GFC_ISYM_ATOMIC_ADD:
10254 case GFC_ISYM_ATOMIC_FETCH_ADD:
10255 fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
10256 break;
10257 case GFC_ISYM_ATOMIC_AND:
10258 case GFC_ISYM_ATOMIC_FETCH_AND:
10259 fn = BUILT_IN_ATOMIC_FETCH_AND_N;
10260 break;
10261 case GFC_ISYM_ATOMIC_DEF:
10262 fn = BUILT_IN_ATOMIC_STORE_N;
10263 break;
10264 case GFC_ISYM_ATOMIC_OR:
10265 case GFC_ISYM_ATOMIC_FETCH_OR:
10266 fn = BUILT_IN_ATOMIC_FETCH_OR_N;
10267 break;
10268 case GFC_ISYM_ATOMIC_XOR:
10269 case GFC_ISYM_ATOMIC_FETCH_XOR:
10270 fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
10271 break;
10272 default:
10273 gcc_unreachable ();
10274 }
10275
10276 tmp = TREE_TYPE (TREE_TYPE (atom));
10277 fn = (built_in_function) ((int) fn
10278 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10279 + 1);
10280 tmp = builtin_decl_explicit (fn);
10281 tree itype = TREE_TYPE (TREE_TYPE (atom));
10282 tmp = builtin_decl_explicit (fn);
10283
10284 switch (code->resolved_isym->id)
10285 {
10286 case GFC_ISYM_ATOMIC_ADD:
10287 case GFC_ISYM_ATOMIC_AND:
10288 case GFC_ISYM_ATOMIC_DEF:
10289 case GFC_ISYM_ATOMIC_OR:
10290 case GFC_ISYM_ATOMIC_XOR:
10291 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
10292 fold_convert (itype, value),
10293 build_int_cst (NULL, MEMMODEL_RELAXED));
10294 gfc_add_expr_to_block (&block, tmp);
10295 break;
10296 default:
10297 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
10298 fold_convert (itype, value),
10299 build_int_cst (NULL, MEMMODEL_RELAXED));
10300 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
10301 break;
10302 }
10303
10304 if (stat != NULL_TREE)
10305 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10306 gfc_add_block_to_block (&block, &post_block);
10307 return gfc_finish_block (&block);
10308 }
10309
10310
10311 static tree
conv_intrinsic_atomic_ref(gfc_code * code)10312 conv_intrinsic_atomic_ref (gfc_code *code)
10313 {
10314 gfc_se argse;
10315 tree tmp, atom, value, stat = NULL_TREE;
10316 stmtblock_t block, post_block;
10317 built_in_function fn;
10318 gfc_expr *atom_expr = code->ext.actual->next->expr;
10319
10320 if (atom_expr->expr_type == EXPR_FUNCTION
10321 && atom_expr->value.function.isym
10322 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10323 atom_expr = atom_expr->value.function.actual->expr;
10324
10325 gfc_start_block (&block);
10326 gfc_init_block (&post_block);
10327 gfc_init_se (&argse, NULL);
10328 argse.want_pointer = 1;
10329 gfc_conv_expr (&argse, atom_expr);
10330 gfc_add_block_to_block (&block, &argse.pre);
10331 gfc_add_block_to_block (&post_block, &argse.post);
10332 atom = argse.expr;
10333
10334 gfc_init_se (&argse, NULL);
10335 if (flag_coarray == GFC_FCOARRAY_LIB
10336 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
10337 argse.want_pointer = 1;
10338 gfc_conv_expr (&argse, code->ext.actual->expr);
10339 gfc_add_block_to_block (&block, &argse.pre);
10340 gfc_add_block_to_block (&post_block, &argse.post);
10341 value = argse.expr;
10342
10343 /* STAT= */
10344 if (code->ext.actual->next->next->expr != NULL)
10345 {
10346 gcc_assert (code->ext.actual->next->next->expr->expr_type
10347 == EXPR_VARIABLE);
10348 gfc_init_se (&argse, NULL);
10349 if (flag_coarray == GFC_FCOARRAY_LIB)
10350 argse.want_pointer = 1;
10351 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
10352 gfc_add_block_to_block (&block, &argse.pre);
10353 gfc_add_block_to_block (&post_block, &argse.post);
10354 stat = argse.expr;
10355 }
10356 else if (flag_coarray == GFC_FCOARRAY_LIB)
10357 stat = null_pointer_node;
10358
10359 if (flag_coarray == GFC_FCOARRAY_LIB)
10360 {
10361 tree image_index, caf_decl, offset, token;
10362 tree orig_value = NULL_TREE, vardecl = NULL_TREE;
10363
10364 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10365 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10366 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10367
10368 if (gfc_is_coindexed (atom_expr))
10369 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10370 else
10371 image_index = integer_zero_node;
10372
10373 gfc_init_se (&argse, NULL);
10374 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10375 atom_expr);
10376 gfc_add_block_to_block (&block, &argse.pre);
10377
10378 /* Different type, need type conversion. */
10379 if (!POINTER_TYPE_P (TREE_TYPE (value)))
10380 {
10381 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
10382 orig_value = value;
10383 value = gfc_build_addr_expr (NULL_TREE, vardecl);
10384 }
10385
10386 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
10387 token, offset, image_index, value, stat,
10388 build_int_cst (integer_type_node,
10389 (int) atom_expr->ts.type),
10390 build_int_cst (integer_type_node,
10391 (int) atom_expr->ts.kind));
10392 gfc_add_expr_to_block (&block, tmp);
10393 if (vardecl != NULL_TREE)
10394 gfc_add_modify (&block, orig_value,
10395 fold_convert (TREE_TYPE (orig_value), vardecl));
10396 gfc_add_block_to_block (&block, &argse.post);
10397 gfc_add_block_to_block (&block, &post_block);
10398 return gfc_finish_block (&block);
10399 }
10400
10401 tmp = TREE_TYPE (TREE_TYPE (atom));
10402 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
10403 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10404 + 1);
10405 tmp = builtin_decl_explicit (fn);
10406 tmp = build_call_expr_loc (input_location, tmp, 2, atom,
10407 build_int_cst (integer_type_node,
10408 MEMMODEL_RELAXED));
10409 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
10410
10411 if (stat != NULL_TREE)
10412 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10413 gfc_add_block_to_block (&block, &post_block);
10414 return gfc_finish_block (&block);
10415 }
10416
10417
10418 static tree
conv_intrinsic_atomic_cas(gfc_code * code)10419 conv_intrinsic_atomic_cas (gfc_code *code)
10420 {
10421 gfc_se argse;
10422 tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
10423 stmtblock_t block, post_block;
10424 built_in_function fn;
10425 gfc_expr *atom_expr = code->ext.actual->expr;
10426
10427 if (atom_expr->expr_type == EXPR_FUNCTION
10428 && atom_expr->value.function.isym
10429 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10430 atom_expr = atom_expr->value.function.actual->expr;
10431
10432 gfc_init_block (&block);
10433 gfc_init_block (&post_block);
10434 gfc_init_se (&argse, NULL);
10435 argse.want_pointer = 1;
10436 gfc_conv_expr (&argse, atom_expr);
10437 atom = argse.expr;
10438
10439 gfc_init_se (&argse, NULL);
10440 if (flag_coarray == GFC_FCOARRAY_LIB)
10441 argse.want_pointer = 1;
10442 gfc_conv_expr (&argse, code->ext.actual->next->expr);
10443 gfc_add_block_to_block (&block, &argse.pre);
10444 gfc_add_block_to_block (&post_block, &argse.post);
10445 old = argse.expr;
10446
10447 gfc_init_se (&argse, NULL);
10448 if (flag_coarray == GFC_FCOARRAY_LIB)
10449 argse.want_pointer = 1;
10450 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
10451 gfc_add_block_to_block (&block, &argse.pre);
10452 gfc_add_block_to_block (&post_block, &argse.post);
10453 comp = argse.expr;
10454
10455 gfc_init_se (&argse, NULL);
10456 if (flag_coarray == GFC_FCOARRAY_LIB
10457 && code->ext.actual->next->next->next->expr->ts.kind
10458 == atom_expr->ts.kind)
10459 argse.want_pointer = 1;
10460 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
10461 gfc_add_block_to_block (&block, &argse.pre);
10462 gfc_add_block_to_block (&post_block, &argse.post);
10463 new_val = argse.expr;
10464
10465 /* STAT= */
10466 if (code->ext.actual->next->next->next->next->expr != NULL)
10467 {
10468 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
10469 == EXPR_VARIABLE);
10470 gfc_init_se (&argse, NULL);
10471 if (flag_coarray == GFC_FCOARRAY_LIB)
10472 argse.want_pointer = 1;
10473 gfc_conv_expr_val (&argse,
10474 code->ext.actual->next->next->next->next->expr);
10475 gfc_add_block_to_block (&block, &argse.pre);
10476 gfc_add_block_to_block (&post_block, &argse.post);
10477 stat = argse.expr;
10478 }
10479 else if (flag_coarray == GFC_FCOARRAY_LIB)
10480 stat = null_pointer_node;
10481
10482 if (flag_coarray == GFC_FCOARRAY_LIB)
10483 {
10484 tree image_index, caf_decl, offset, token;
10485
10486 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10487 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10488 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10489
10490 if (gfc_is_coindexed (atom_expr))
10491 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10492 else
10493 image_index = integer_zero_node;
10494
10495 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
10496 {
10497 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
10498 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
10499 new_val = gfc_build_addr_expr (NULL_TREE, tmp);
10500 }
10501
10502 /* Convert a constant to a pointer. */
10503 if (!POINTER_TYPE_P (TREE_TYPE (comp)))
10504 {
10505 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
10506 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
10507 comp = gfc_build_addr_expr (NULL_TREE, tmp);
10508 }
10509
10510 gfc_init_se (&argse, NULL);
10511 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10512 atom_expr);
10513 gfc_add_block_to_block (&block, &argse.pre);
10514
10515 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
10516 token, offset, image_index, old, comp, new_val,
10517 stat, build_int_cst (integer_type_node,
10518 (int) atom_expr->ts.type),
10519 build_int_cst (integer_type_node,
10520 (int) atom_expr->ts.kind));
10521 gfc_add_expr_to_block (&block, tmp);
10522 gfc_add_block_to_block (&block, &argse.post);
10523 gfc_add_block_to_block (&block, &post_block);
10524 return gfc_finish_block (&block);
10525 }
10526
10527 tmp = TREE_TYPE (TREE_TYPE (atom));
10528 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10529 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10530 + 1);
10531 tmp = builtin_decl_explicit (fn);
10532
10533 gfc_add_modify (&block, old, comp);
10534 tmp = build_call_expr_loc (input_location, tmp, 6, atom,
10535 gfc_build_addr_expr (NULL, old),
10536 fold_convert (TREE_TYPE (old), new_val),
10537 boolean_false_node,
10538 build_int_cst (NULL, MEMMODEL_RELAXED),
10539 build_int_cst (NULL, MEMMODEL_RELAXED));
10540 gfc_add_expr_to_block (&block, tmp);
10541
10542 if (stat != NULL_TREE)
10543 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10544 gfc_add_block_to_block (&block, &post_block);
10545 return gfc_finish_block (&block);
10546 }
10547
10548 static tree
conv_intrinsic_event_query(gfc_code * code)10549 conv_intrinsic_event_query (gfc_code *code)
10550 {
10551 gfc_se se, argse;
10552 tree stat = NULL_TREE, stat2 = NULL_TREE;
10553 tree count = NULL_TREE, count2 = NULL_TREE;
10554
10555 gfc_expr *event_expr = code->ext.actual->expr;
10556
10557 if (code->ext.actual->next->next->expr)
10558 {
10559 gcc_assert (code->ext.actual->next->next->expr->expr_type
10560 == EXPR_VARIABLE);
10561 gfc_init_se (&argse, NULL);
10562 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
10563 stat = argse.expr;
10564 }
10565 else if (flag_coarray == GFC_FCOARRAY_LIB)
10566 stat = null_pointer_node;
10567
10568 if (code->ext.actual->next->expr)
10569 {
10570 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
10571 gfc_init_se (&argse, NULL);
10572 gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
10573 count = argse.expr;
10574 }
10575
10576 gfc_start_block (&se.pre);
10577 if (flag_coarray == GFC_FCOARRAY_LIB)
10578 {
10579 tree tmp, token, image_index;
10580 tree index = size_zero_node;
10581
10582 if (event_expr->expr_type == EXPR_FUNCTION
10583 && event_expr->value.function.isym
10584 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10585 event_expr = event_expr->value.function.actual->expr;
10586
10587 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
10588
10589 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
10590 || event_expr->symtree->n.sym->ts.u.derived->from_intmod
10591 != INTMOD_ISO_FORTRAN_ENV
10592 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
10593 != ISOFORTRAN_EVENT_TYPE)
10594 {
10595 gfc_error ("Sorry, the event component of derived type at %L is not "
10596 "yet supported", &event_expr->where);
10597 return NULL_TREE;
10598 }
10599
10600 if (gfc_is_coindexed (event_expr))
10601 {
10602 gfc_error ("The event variable at %L shall not be coindexed",
10603 &event_expr->where);
10604 return NULL_TREE;
10605 }
10606
10607 image_index = integer_zero_node;
10608
10609 gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
10610 event_expr);
10611
10612 /* For arrays, obtain the array index. */
10613 if (gfc_expr_attr (event_expr).dimension)
10614 {
10615 tree desc, tmp, extent, lbound, ubound;
10616 gfc_array_ref *ar, ar2;
10617 int i;
10618
10619 /* TODO: Extend this, once DT components are supported. */
10620 ar = &event_expr->ref->u.ar;
10621 ar2 = *ar;
10622 memset (ar, '\0', sizeof (*ar));
10623 ar->as = ar2.as;
10624 ar->type = AR_FULL;
10625
10626 gfc_init_se (&argse, NULL);
10627 argse.descriptor_only = 1;
10628 gfc_conv_expr_descriptor (&argse, event_expr);
10629 gfc_add_block_to_block (&se.pre, &argse.pre);
10630 desc = argse.expr;
10631 *ar = ar2;
10632
10633 extent = integer_one_node;
10634 for (i = 0; i < ar->dimen; i++)
10635 {
10636 gfc_init_se (&argse, NULL);
10637 gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
10638 gfc_add_block_to_block (&argse.pre, &argse.pre);
10639 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
10640 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10641 integer_type_node, argse.expr,
10642 fold_convert(integer_type_node, lbound));
10643 tmp = fold_build2_loc (input_location, MULT_EXPR,
10644 integer_type_node, extent, tmp);
10645 index = fold_build2_loc (input_location, PLUS_EXPR,
10646 integer_type_node, index, tmp);
10647 if (i < ar->dimen - 1)
10648 {
10649 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
10650 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10651 tmp = fold_convert (integer_type_node, tmp);
10652 extent = fold_build2_loc (input_location, MULT_EXPR,
10653 integer_type_node, extent, tmp);
10654 }
10655 }
10656 }
10657
10658 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
10659 {
10660 count2 = count;
10661 count = gfc_create_var (integer_type_node, "count");
10662 }
10663
10664 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
10665 {
10666 stat2 = stat;
10667 stat = gfc_create_var (integer_type_node, "stat");
10668 }
10669
10670 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
10671 token, index, image_index, count
10672 ? gfc_build_addr_expr (NULL, count) : count,
10673 stat != null_pointer_node
10674 ? gfc_build_addr_expr (NULL, stat) : stat);
10675 gfc_add_expr_to_block (&se.pre, tmp);
10676
10677 if (count2 != NULL_TREE)
10678 gfc_add_modify (&se.pre, count2,
10679 fold_convert (TREE_TYPE (count2), count));
10680
10681 if (stat2 != NULL_TREE)
10682 gfc_add_modify (&se.pre, stat2,
10683 fold_convert (TREE_TYPE (stat2), stat));
10684
10685 return gfc_finish_block (&se.pre);
10686 }
10687
10688 gfc_init_se (&argse, NULL);
10689 gfc_conv_expr_val (&argse, code->ext.actual->expr);
10690 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
10691
10692 if (stat != NULL_TREE)
10693 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
10694
10695 return gfc_finish_block (&se.pre);
10696 }
10697
10698 static tree
conv_intrinsic_move_alloc(gfc_code * code)10699 conv_intrinsic_move_alloc (gfc_code *code)
10700 {
10701 stmtblock_t block;
10702 gfc_expr *from_expr, *to_expr;
10703 gfc_expr *to_expr2, *from_expr2 = NULL;
10704 gfc_se from_se, to_se;
10705 tree tmp;
10706 bool coarray;
10707
10708 gfc_start_block (&block);
10709
10710 from_expr = code->ext.actual->expr;
10711 to_expr = code->ext.actual->next->expr;
10712
10713 gfc_init_se (&from_se, NULL);
10714 gfc_init_se (&to_se, NULL);
10715
10716 gcc_assert (from_expr->ts.type != BT_CLASS
10717 || to_expr->ts.type == BT_CLASS);
10718 coarray = gfc_get_corank (from_expr) != 0;
10719
10720 if (from_expr->rank == 0 && !coarray)
10721 {
10722 if (from_expr->ts.type != BT_CLASS)
10723 from_expr2 = from_expr;
10724 else
10725 {
10726 from_expr2 = gfc_copy_expr (from_expr);
10727 gfc_add_data_component (from_expr2);
10728 }
10729
10730 if (to_expr->ts.type != BT_CLASS)
10731 to_expr2 = to_expr;
10732 else
10733 {
10734 to_expr2 = gfc_copy_expr (to_expr);
10735 gfc_add_data_component (to_expr2);
10736 }
10737
10738 from_se.want_pointer = 1;
10739 to_se.want_pointer = 1;
10740 gfc_conv_expr (&from_se, from_expr2);
10741 gfc_conv_expr (&to_se, to_expr2);
10742 gfc_add_block_to_block (&block, &from_se.pre);
10743 gfc_add_block_to_block (&block, &to_se.pre);
10744
10745 /* Deallocate "to". */
10746 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10747 true, to_expr, to_expr->ts);
10748 gfc_add_expr_to_block (&block, tmp);
10749
10750 /* Assign (_data) pointers. */
10751 gfc_add_modify_loc (input_location, &block, to_se.expr,
10752 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
10753
10754 /* Set "from" to NULL. */
10755 gfc_add_modify_loc (input_location, &block, from_se.expr,
10756 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
10757
10758 gfc_add_block_to_block (&block, &from_se.post);
10759 gfc_add_block_to_block (&block, &to_se.post);
10760
10761 /* Set _vptr. */
10762 if (to_expr->ts.type == BT_CLASS)
10763 {
10764 gfc_symbol *vtab;
10765
10766 gfc_free_expr (to_expr2);
10767 gfc_init_se (&to_se, NULL);
10768 to_se.want_pointer = 1;
10769 gfc_add_vptr_component (to_expr);
10770 gfc_conv_expr (&to_se, to_expr);
10771
10772 if (from_expr->ts.type == BT_CLASS)
10773 {
10774 if (UNLIMITED_POLY (from_expr))
10775 vtab = NULL;
10776 else
10777 {
10778 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10779 gcc_assert (vtab);
10780 }
10781
10782 gfc_free_expr (from_expr2);
10783 gfc_init_se (&from_se, NULL);
10784 from_se.want_pointer = 1;
10785 gfc_add_vptr_component (from_expr);
10786 gfc_conv_expr (&from_se, from_expr);
10787 gfc_add_modify_loc (input_location, &block, to_se.expr,
10788 fold_convert (TREE_TYPE (to_se.expr),
10789 from_se.expr));
10790
10791 /* Reset _vptr component to declared type. */
10792 if (vtab == NULL)
10793 /* Unlimited polymorphic. */
10794 gfc_add_modify_loc (input_location, &block, from_se.expr,
10795 fold_convert (TREE_TYPE (from_se.expr),
10796 null_pointer_node));
10797 else
10798 {
10799 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10800 gfc_add_modify_loc (input_location, &block, from_se.expr,
10801 fold_convert (TREE_TYPE (from_se.expr), tmp));
10802 }
10803 }
10804 else
10805 {
10806 vtab = gfc_find_vtab (&from_expr->ts);
10807 gcc_assert (vtab);
10808 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10809 gfc_add_modify_loc (input_location, &block, to_se.expr,
10810 fold_convert (TREE_TYPE (to_se.expr), tmp));
10811 }
10812 }
10813
10814 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10815 {
10816 gfc_add_modify_loc (input_location, &block, to_se.string_length,
10817 fold_convert (TREE_TYPE (to_se.string_length),
10818 from_se.string_length));
10819 if (from_expr->ts.deferred)
10820 gfc_add_modify_loc (input_location, &block, from_se.string_length,
10821 build_int_cst (TREE_TYPE (from_se.string_length), 0));
10822 }
10823
10824 return gfc_finish_block (&block);
10825 }
10826
10827 /* Update _vptr component. */
10828 if (to_expr->ts.type == BT_CLASS)
10829 {
10830 gfc_symbol *vtab;
10831
10832 to_se.want_pointer = 1;
10833 to_expr2 = gfc_copy_expr (to_expr);
10834 gfc_add_vptr_component (to_expr2);
10835 gfc_conv_expr (&to_se, to_expr2);
10836
10837 if (from_expr->ts.type == BT_CLASS)
10838 {
10839 if (UNLIMITED_POLY (from_expr))
10840 vtab = NULL;
10841 else
10842 {
10843 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10844 gcc_assert (vtab);
10845 }
10846
10847 from_se.want_pointer = 1;
10848 from_expr2 = gfc_copy_expr (from_expr);
10849 gfc_add_vptr_component (from_expr2);
10850 gfc_conv_expr (&from_se, from_expr2);
10851 gfc_add_modify_loc (input_location, &block, to_se.expr,
10852 fold_convert (TREE_TYPE (to_se.expr),
10853 from_se.expr));
10854
10855 /* Reset _vptr component to declared type. */
10856 if (vtab == NULL)
10857 /* Unlimited polymorphic. */
10858 gfc_add_modify_loc (input_location, &block, from_se.expr,
10859 fold_convert (TREE_TYPE (from_se.expr),
10860 null_pointer_node));
10861 else
10862 {
10863 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10864 gfc_add_modify_loc (input_location, &block, from_se.expr,
10865 fold_convert (TREE_TYPE (from_se.expr), tmp));
10866 }
10867 }
10868 else
10869 {
10870 vtab = gfc_find_vtab (&from_expr->ts);
10871 gcc_assert (vtab);
10872 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10873 gfc_add_modify_loc (input_location, &block, to_se.expr,
10874 fold_convert (TREE_TYPE (to_se.expr), tmp));
10875 }
10876
10877 gfc_free_expr (to_expr2);
10878 gfc_init_se (&to_se, NULL);
10879
10880 if (from_expr->ts.type == BT_CLASS)
10881 {
10882 gfc_free_expr (from_expr2);
10883 gfc_init_se (&from_se, NULL);
10884 }
10885 }
10886
10887
10888 /* Deallocate "to". */
10889 if (from_expr->rank == 0)
10890 {
10891 to_se.want_coarray = 1;
10892 from_se.want_coarray = 1;
10893 }
10894 gfc_conv_expr_descriptor (&to_se, to_expr);
10895 gfc_conv_expr_descriptor (&from_se, from_expr);
10896
10897 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10898 is an image control "statement", cf. IR F08/0040 in 12-006A. */
10899 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
10900 {
10901 tree cond;
10902
10903 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10904 NULL_TREE, NULL_TREE, true, to_expr,
10905 GFC_CAF_COARRAY_DEALLOCATE_ONLY);
10906 gfc_add_expr_to_block (&block, tmp);
10907
10908 tmp = gfc_conv_descriptor_data_get (to_se.expr);
10909 cond = fold_build2_loc (input_location, EQ_EXPR,
10910 logical_type_node, tmp,
10911 fold_convert (TREE_TYPE (tmp),
10912 null_pointer_node));
10913 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
10914 3, null_pointer_node, null_pointer_node,
10915 build_int_cst (integer_type_node, 0));
10916
10917 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
10918 tmp, build_empty_stmt (input_location));
10919 gfc_add_expr_to_block (&block, tmp);
10920 }
10921 else
10922 {
10923 if (to_expr->ts.type == BT_DERIVED
10924 && to_expr->ts.u.derived->attr.alloc_comp)
10925 {
10926 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
10927 to_se.expr, to_expr->rank);
10928 gfc_add_expr_to_block (&block, tmp);
10929 }
10930
10931 tmp = gfc_conv_descriptor_data_get (to_se.expr);
10932 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
10933 NULL_TREE, true, to_expr,
10934 GFC_CAF_COARRAY_NOCOARRAY);
10935 gfc_add_expr_to_block (&block, tmp);
10936 }
10937
10938 /* Move the pointer and update the array descriptor data. */
10939 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
10940
10941 /* Set "from" to NULL. */
10942 tmp = gfc_conv_descriptor_data_get (from_se.expr);
10943 gfc_add_modify_loc (input_location, &block, tmp,
10944 fold_convert (TREE_TYPE (tmp), null_pointer_node));
10945
10946
10947 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10948 {
10949 gfc_add_modify_loc (input_location, &block, to_se.string_length,
10950 fold_convert (TREE_TYPE (to_se.string_length),
10951 from_se.string_length));
10952 if (from_expr->ts.deferred)
10953 gfc_add_modify_loc (input_location, &block, from_se.string_length,
10954 build_int_cst (TREE_TYPE (from_se.string_length), 0));
10955 }
10956
10957 return gfc_finish_block (&block);
10958 }
10959
10960
10961 tree
gfc_conv_intrinsic_subroutine(gfc_code * code)10962 gfc_conv_intrinsic_subroutine (gfc_code *code)
10963 {
10964 tree res;
10965
10966 gcc_assert (code->resolved_isym);
10967
10968 switch (code->resolved_isym->id)
10969 {
10970 case GFC_ISYM_MOVE_ALLOC:
10971 res = conv_intrinsic_move_alloc (code);
10972 break;
10973
10974 case GFC_ISYM_ATOMIC_CAS:
10975 res = conv_intrinsic_atomic_cas (code);
10976 break;
10977
10978 case GFC_ISYM_ATOMIC_ADD:
10979 case GFC_ISYM_ATOMIC_AND:
10980 case GFC_ISYM_ATOMIC_DEF:
10981 case GFC_ISYM_ATOMIC_OR:
10982 case GFC_ISYM_ATOMIC_XOR:
10983 case GFC_ISYM_ATOMIC_FETCH_ADD:
10984 case GFC_ISYM_ATOMIC_FETCH_AND:
10985 case GFC_ISYM_ATOMIC_FETCH_OR:
10986 case GFC_ISYM_ATOMIC_FETCH_XOR:
10987 res = conv_intrinsic_atomic_op (code);
10988 break;
10989
10990 case GFC_ISYM_ATOMIC_REF:
10991 res = conv_intrinsic_atomic_ref (code);
10992 break;
10993
10994 case GFC_ISYM_EVENT_QUERY:
10995 res = conv_intrinsic_event_query (code);
10996 break;
10997
10998 case GFC_ISYM_C_F_POINTER:
10999 case GFC_ISYM_C_F_PROCPOINTER:
11000 res = conv_isocbinding_subroutine (code);
11001 break;
11002
11003 case GFC_ISYM_CAF_SEND:
11004 res = conv_caf_send (code);
11005 break;
11006
11007 case GFC_ISYM_CO_BROADCAST:
11008 case GFC_ISYM_CO_MIN:
11009 case GFC_ISYM_CO_MAX:
11010 case GFC_ISYM_CO_REDUCE:
11011 case GFC_ISYM_CO_SUM:
11012 res = conv_co_collective (code);
11013 break;
11014
11015 case GFC_ISYM_FREE:
11016 res = conv_intrinsic_free (code);
11017 break;
11018
11019 case GFC_ISYM_KILL:
11020 res = conv_intrinsic_kill_sub (code);
11021 break;
11022
11023 case GFC_ISYM_SYSTEM_CLOCK:
11024 res = conv_intrinsic_system_clock (code);
11025 break;
11026
11027 default:
11028 res = NULL_TREE;
11029 break;
11030 }
11031
11032 return res;
11033 }
11034
11035 #include "gt-fortran-trans-intrinsic.h"
11036