Line data Source code
1 : /* Intrinsic function resolution.
2 : Copyright (C) 2000-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught & Katherine Holcomb
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 :
22 : /* Assign name and types to intrinsic procedures. For functions, the
23 : first argument to a resolution function is an expression pointer to
24 : the original function node and the rest are pointers to the
25 : arguments of the function call. For subroutines, a pointer to the
26 : code node is passed. The result type and library subroutine name
27 : are generally set according to the function arguments. */
28 :
29 : #include "config.h"
30 : #include "system.h"
31 : #include "coretypes.h"
32 : #include "tree.h"
33 : #include "gfortran.h"
34 : #include "stringpool.h"
35 : #include "intrinsic.h"
36 : #include "constructor.h"
37 : #include "arith.h"
38 : #include "trans.h"
39 :
40 : /* Given printf-like arguments, return a stable version of the result string.
41 :
42 : We already have a working, optimized string hashing table in the form of
43 : the identifier table. Reusing this table is likely not to be wasted,
44 : since if the function name makes it to the gimple output of the frontend,
45 : we'll have to create the identifier anyway. */
46 :
47 : const char *
48 68014477 : gfc_get_string (const char *format, ...)
49 : {
50 : /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 68014477 : char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 68014477 : const char *str;
53 68014477 : va_list ap;
54 68014477 : tree ident;
55 :
56 : /* Handle common case without vsnprintf and temporary buffer. */
57 68014477 : if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 : {
59 58167543 : va_start (ap, format);
60 58167543 : str = va_arg (ap, const char *);
61 58167543 : va_end (ap);
62 : }
63 : else
64 : {
65 9846934 : int ret;
66 9846934 : va_start (ap, format);
67 9846934 : ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 9846934 : va_end (ap);
69 9846934 : if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 0 : gfc_internal_error ("identifier overflow: %d", ret);
71 9846934 : temp_name[sizeof (temp_name) - 1] = 0;
72 9846934 : str = temp_name;
73 : }
74 :
75 68014477 : ident = get_identifier (str);
76 68014477 : return IDENTIFIER_POINTER (ident);
77 : }
78 :
79 : /* MERGE and SPREAD need to have source charlen's present for passing
80 : to the result expression. */
81 : static void
82 1369 : check_charlen_present (gfc_expr *source)
83 : {
84 1369 : if (source->ts.u.cl == NULL)
85 0 : source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
86 :
87 1369 : if (source->expr_type == EXPR_CONSTANT)
88 : {
89 82 : source->ts.u.cl->length
90 164 : = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
91 82 : source->value.character.length);
92 82 : source->rank = 0;
93 : }
94 1287 : else if (source->expr_type == EXPR_ARRAY)
95 : {
96 640 : gfc_constructor *c = gfc_constructor_first (source->value.constructor);
97 640 : if (c)
98 636 : source->ts.u.cl->length
99 636 : = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
100 636 : c->expr->value.character.length);
101 640 : if (source->ts.u.cl->length == NULL)
102 0 : gfc_internal_error ("check_charlen_present(): length not set");
103 : }
104 1369 : }
105 :
106 : /* Helper function for resolving the "mask" argument. */
107 :
108 : static void
109 20920 : resolve_mask_arg (gfc_expr *mask)
110 : {
111 :
112 20920 : gfc_typespec ts;
113 20920 : gfc_clear_ts (&ts);
114 :
115 20920 : if (mask->rank == 0)
116 : {
117 : /* For the scalar case, coerce the mask to kind=4 unconditionally
118 : (because this is the only kind we have a library function
119 : for). */
120 :
121 7593 : if (mask->ts.kind != 4)
122 : {
123 432 : ts.type = BT_LOGICAL;
124 432 : ts.kind = 4;
125 432 : gfc_convert_type (mask, &ts, 2);
126 : }
127 : }
128 : else
129 : {
130 : /* In the library, we access the mask with a GFC_LOGICAL_1
131 : argument. No need to waste memory if we are about to create
132 : a temporary array. */
133 13327 : if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
134 : {
135 906 : ts.type = BT_LOGICAL;
136 906 : ts.kind = 1;
137 906 : gfc_convert_type_warn (mask, &ts, 2, 0);
138 : }
139 : }
140 20920 : }
141 :
142 :
143 : static void
144 30240 : resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145 : const char *name, bool coarray)
146 : {
147 30240 : f->ts.type = BT_INTEGER;
148 30240 : if (kind)
149 3623 : f->ts.kind = mpz_get_si (kind->value.integer);
150 : else
151 26617 : f->ts.kind = gfc_default_integer_kind;
152 :
153 30240 : if (dim == NULL)
154 : {
155 6325 : if (array->rank != -1)
156 : {
157 : /* Assume f->rank gives the size of the shape, because there is no
158 : other way to determine the size. */
159 4793 : if (!f->shape || f->rank != 1)
160 : {
161 2503 : if (f->shape)
162 0 : gfc_free_shape (&f->shape, f->rank);
163 2503 : f->shape = gfc_get_shape (1);
164 : }
165 4793 : mpz_init_set_ui (f->shape[0], coarray ? array->corank : array->rank);
166 : }
167 : /* Applying bound to a coarray always results in a regular array. */
168 6325 : f->rank = 1;
169 6325 : f->corank = 0;
170 : }
171 :
172 30240 : f->value.function.name = gfc_get_string ("%s", name);
173 30240 : }
174 :
175 :
176 : static void
177 6134 : resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
178 : gfc_expr *dim, gfc_expr *mask,
179 : bool use_integer = false)
180 : {
181 6134 : const char *prefix;
182 6134 : bt type;
183 :
184 6134 : f->ts = array->ts;
185 :
186 6134 : if (mask)
187 : {
188 912 : if (mask->rank == 0)
189 : prefix = "s";
190 : else
191 611 : prefix = "m";
192 :
193 912 : resolve_mask_arg (mask);
194 : }
195 : else
196 : prefix = "";
197 :
198 6134 : if (dim != NULL)
199 : {
200 2361 : f->rank = array->rank - 1;
201 2361 : f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
202 2361 : gfc_resolve_dim_arg (dim);
203 : }
204 :
205 : /* For those intrinsic like SUM where we use the integer version
206 : actually uses unsigned, but we call it as the integer
207 : version. */
208 :
209 6134 : if (use_integer && array->ts.type == BT_UNSIGNED)
210 : type = BT_INTEGER;
211 : else
212 6026 : type = array->ts.type;
213 :
214 6134 : f->value.function.name
215 12268 : = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
216 6134 : gfc_type_letter (type),
217 : gfc_type_abi_kind (&array->ts));
218 6134 : }
219 :
220 :
221 : /********************** Resolution functions **********************/
222 :
223 :
224 : void
225 24379 : gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
226 : {
227 24379 : f->ts = a->ts;
228 24379 : if (f->ts.type == BT_COMPLEX)
229 3148 : f->ts.type = BT_REAL;
230 :
231 24379 : f->value.function.name
232 24379 : = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
233 : gfc_type_abi_kind (&a->ts));
234 24379 : }
235 :
236 :
237 : void
238 1369 : gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
239 : gfc_expr *mode ATTRIBUTE_UNUSED)
240 : {
241 1369 : f->ts.type = BT_INTEGER;
242 1369 : f->ts.kind = gfc_c_int_kind;
243 1369 : f->value.function.name = PREFIX ("access_func");
244 1369 : }
245 :
246 :
247 : void
248 1154 : gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
249 : {
250 1154 : f->ts.type = BT_CHARACTER;
251 1154 : f->ts.kind = string->ts.kind;
252 1154 : if (string->ts.deferred)
253 60 : f->ts = string->ts;
254 1094 : else if (string->ts.u.cl)
255 1094 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
256 :
257 1154 : f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
258 1154 : }
259 :
260 :
261 : void
262 348 : gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
263 : {
264 348 : f->ts.type = BT_CHARACTER;
265 348 : f->ts.kind = string->ts.kind;
266 348 : if (string->ts.deferred)
267 24 : f->ts = string->ts;
268 324 : else if (string->ts.u.cl)
269 324 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
270 :
271 348 : f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
272 348 : }
273 :
274 :
275 : static void
276 7609 : gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
277 : bool is_achar)
278 : {
279 7609 : f->ts.type = BT_CHARACTER;
280 7609 : f->ts.kind = (kind == NULL)
281 758 : ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
282 7609 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
283 7609 : f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
284 :
285 7609 : f->value.function.name
286 17343 : = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
287 7609 : gfc_type_letter (x->ts.type),
288 : gfc_type_abi_kind (&x->ts));
289 7609 : }
290 :
291 :
292 : void
293 5484 : gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
294 : {
295 5484 : gfc_resolve_char_achar (f, x, kind, true);
296 5484 : }
297 :
298 :
299 : void
300 496 : gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
301 : {
302 496 : f->ts = x->ts;
303 496 : f->value.function.name
304 496 : = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type),
305 : gfc_type_abi_kind (&x->ts));
306 496 : }
307 :
308 :
309 : void
310 264 : gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
311 : {
312 264 : f->ts = x->ts;
313 264 : f->value.function.name
314 264 : = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
315 : gfc_type_abi_kind (&x->ts));
316 264 : }
317 :
318 :
319 : void
320 1587 : gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
321 : {
322 1587 : f->ts.type = BT_REAL;
323 1587 : f->ts.kind = x->ts.kind;
324 1587 : f->value.function.name
325 1587 : = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
326 : gfc_type_abi_kind (&x->ts));
327 1587 : }
328 :
329 :
330 : void
331 327 : gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
332 : {
333 327 : f->ts.type = i->ts.type;
334 327 : f->ts.kind = gfc_kind_max (i, j);
335 :
336 327 : if (i->ts.kind != j->ts.kind)
337 : {
338 0 : if (i->ts.kind == gfc_kind_max (i, j))
339 0 : gfc_convert_type (j, &i->ts, 2);
340 : else
341 0 : gfc_convert_type (i, &j->ts, 2);
342 : }
343 :
344 327 : f->value.function.name
345 327 : = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type),
346 : gfc_type_abi_kind (&f->ts));
347 327 : }
348 :
349 :
350 : void
351 642 : gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
352 : {
353 642 : gfc_typespec ts;
354 642 : gfc_clear_ts (&ts);
355 :
356 642 : f->ts.type = a->ts.type;
357 642 : f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
358 :
359 642 : if (a->ts.kind != f->ts.kind)
360 : {
361 12 : ts.type = f->ts.type;
362 12 : ts.kind = f->ts.kind;
363 12 : gfc_convert_type (a, &ts, 2);
364 : }
365 : /* The resolved name is only used for specific intrinsics where
366 : the return kind is the same as the arg kind. */
367 642 : f->value.function.name
368 642 : = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type),
369 : gfc_type_abi_kind (&a->ts));
370 642 : }
371 :
372 :
373 : void
374 63 : gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
375 : {
376 63 : gfc_resolve_aint (f, a, NULL);
377 63 : }
378 :
379 :
380 : void
381 1161 : gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
382 : {
383 1161 : f->ts = mask->ts;
384 :
385 1161 : if (dim != NULL)
386 : {
387 87 : gfc_resolve_dim_arg (dim);
388 87 : f->rank = mask->rank - 1;
389 87 : f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
390 : }
391 :
392 1161 : f->value.function.name
393 1161 : = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
394 : gfc_type_abi_kind (&mask->ts));
395 1161 : }
396 :
397 :
398 : void
399 198 : gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
400 : {
401 198 : gfc_typespec ts;
402 198 : gfc_clear_ts (&ts);
403 :
404 198 : f->ts.type = a->ts.type;
405 198 : f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
406 :
407 198 : if (a->ts.kind != f->ts.kind)
408 : {
409 12 : ts.type = f->ts.type;
410 12 : ts.kind = f->ts.kind;
411 12 : gfc_convert_type (a, &ts, 2);
412 : }
413 :
414 : /* The resolved name is only used for specific intrinsics where
415 : the return kind is the same as the arg kind. */
416 198 : f->value.function.name
417 198 : = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
418 : gfc_type_abi_kind (&a->ts));
419 198 : }
420 :
421 :
422 : void
423 75 : gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
424 : {
425 75 : gfc_resolve_anint (f, a, NULL);
426 75 : }
427 :
428 :
429 : void
430 41003 : gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
431 : {
432 41003 : f->ts = mask->ts;
433 :
434 41003 : if (dim != NULL)
435 : {
436 163 : gfc_resolve_dim_arg (dim);
437 163 : f->rank = mask->rank - 1;
438 163 : f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
439 : }
440 :
441 41003 : f->value.function.name
442 41003 : = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
443 : gfc_type_abi_kind (&mask->ts));
444 41003 : }
445 :
446 :
447 : void
448 529 : gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
449 : {
450 529 : f->ts = x->ts;
451 529 : f->value.function.name
452 529 : = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type),
453 : gfc_type_abi_kind (&x->ts));
454 529 : }
455 :
456 : void
457 264 : gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
458 : {
459 264 : f->ts = x->ts;
460 264 : f->value.function.name
461 264 : = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
462 : gfc_type_abi_kind (&x->ts));
463 264 : }
464 :
465 : void
466 534 : gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
467 : {
468 534 : f->ts = x->ts;
469 534 : f->value.function.name
470 534 : = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type),
471 : gfc_type_abi_kind (&x->ts));
472 534 : }
473 :
474 : void
475 264 : gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
476 : {
477 264 : f->ts = x->ts;
478 264 : f->value.function.name
479 264 : = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
480 : gfc_type_abi_kind (&x->ts));
481 264 : }
482 :
483 : void
484 565 : gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
485 : {
486 565 : f->ts = x->ts;
487 565 : f->value.function.name
488 565 : = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
489 : gfc_type_abi_kind (&x->ts));
490 565 : }
491 :
492 :
493 : /* Resolve the BESYN and BESJN intrinsics. */
494 :
495 : void
496 1106 : gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
497 : {
498 1106 : gfc_typespec ts;
499 1106 : gfc_clear_ts (&ts);
500 :
501 1106 : f->ts = x->ts;
502 1106 : if (n->ts.kind != gfc_c_int_kind)
503 : {
504 72 : ts.type = BT_INTEGER;
505 72 : ts.kind = gfc_c_int_kind;
506 72 : gfc_convert_type (n, &ts, 2);
507 : }
508 1106 : f->value.function.name = gfc_get_string ("<intrinsic>");
509 1106 : }
510 :
511 :
512 : void
513 24 : gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
514 : {
515 24 : gfc_typespec ts;
516 24 : gfc_clear_ts (&ts);
517 :
518 24 : f->ts = x->ts;
519 24 : f->rank = 1;
520 24 : if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
521 : {
522 12 : f->shape = gfc_get_shape (1);
523 12 : mpz_init (f->shape[0]);
524 12 : mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
525 12 : mpz_add_ui (f->shape[0], f->shape[0], 1);
526 : }
527 :
528 24 : if (n1->ts.kind != gfc_c_int_kind)
529 : {
530 0 : ts.type = BT_INTEGER;
531 0 : ts.kind = gfc_c_int_kind;
532 0 : gfc_convert_type (n1, &ts, 2);
533 : }
534 :
535 24 : if (n2->ts.kind != gfc_c_int_kind)
536 : {
537 0 : ts.type = BT_INTEGER;
538 0 : ts.kind = gfc_c_int_kind;
539 0 : gfc_convert_type (n2, &ts, 2);
540 : }
541 :
542 24 : if (f->value.function.isym->id == GFC_ISYM_JN2)
543 12 : f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
544 : gfc_type_abi_kind (&f->ts));
545 : else
546 12 : f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
547 : gfc_type_abi_kind (&f->ts));
548 24 : }
549 :
550 :
551 : void
552 311 : gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
553 : {
554 311 : f->ts.type = BT_LOGICAL;
555 311 : f->ts.kind = gfc_default_logical_kind;
556 311 : f->value.function.name
557 311 : = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
558 311 : }
559 :
560 :
561 : void
562 6046 : gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
563 : {
564 6046 : f->ts = f->value.function.isym->ts;
565 6046 : }
566 :
567 :
568 : void
569 660 : gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
570 : {
571 660 : f->ts = f->value.function.isym->ts;
572 660 : }
573 :
574 :
575 : void
576 77 : gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
577 : {
578 77 : f->ts.type = BT_INTEGER;
579 77 : f->ts.kind = (kind == NULL)
580 2 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
581 77 : f->value.function.name
582 154 : = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
583 77 : gfc_type_letter (a->ts.type),
584 : gfc_type_abi_kind (&a->ts));
585 77 : }
586 :
587 :
588 : void
589 2125 : gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
590 : {
591 2125 : gfc_resolve_char_achar (f, a, kind, false);
592 2125 : }
593 :
594 :
595 : void
596 4 : gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
597 : {
598 4 : f->ts.type = BT_INTEGER;
599 4 : f->ts.kind = gfc_default_integer_kind;
600 4 : f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
601 4 : }
602 :
603 :
604 : void
605 9 : gfc_resolve_chdir_sub (gfc_code *c)
606 : {
607 9 : const char *name;
608 9 : int kind;
609 :
610 9 : if (c->ext.actual->next->expr != NULL)
611 7 : kind = c->ext.actual->next->expr->ts.kind;
612 : else
613 2 : kind = gfc_default_integer_kind;
614 :
615 9 : name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
616 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
617 9 : }
618 :
619 :
620 : void
621 37 : gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
622 : gfc_expr *mode ATTRIBUTE_UNUSED)
623 : {
624 37 : f->ts.type = BT_INTEGER;
625 37 : f->ts.kind = gfc_c_int_kind;
626 37 : f->value.function.name = PREFIX ("chmod_func");
627 37 : }
628 :
629 :
630 : void
631 14 : gfc_resolve_chmod_sub (gfc_code *c)
632 : {
633 14 : const char *name;
634 14 : int kind;
635 :
636 14 : if (c->ext.actual->next->next->expr != NULL)
637 13 : kind = c->ext.actual->next->next->expr->ts.kind;
638 : else
639 1 : kind = gfc_default_integer_kind;
640 :
641 14 : name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
642 14 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
643 14 : }
644 :
645 :
646 : void
647 1778 : gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
648 : {
649 1778 : f->ts.type = BT_COMPLEX;
650 1778 : f->ts.kind = (kind == NULL)
651 1320 : ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
652 :
653 1778 : if (y == NULL)
654 178 : f->value.function.name
655 356 : = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
656 178 : gfc_type_letter (x->ts.type),
657 : gfc_type_abi_kind (&x->ts));
658 : else
659 1600 : f->value.function.name
660 4800 : = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
661 1600 : gfc_type_letter (x->ts.type),
662 : gfc_type_abi_kind (&x->ts),
663 1600 : gfc_type_letter (y->ts.type),
664 : gfc_type_abi_kind (&y->ts));
665 1778 : }
666 :
667 :
668 : void
669 256 : gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
670 : {
671 256 : gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
672 : gfc_default_double_kind));
673 256 : }
674 :
675 :
676 : void
677 12 : gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
678 : {
679 12 : int kind;
680 :
681 12 : if (x->ts.type == BT_INTEGER)
682 : {
683 0 : if (y->ts.type == BT_INTEGER)
684 0 : kind = gfc_default_real_kind;
685 : else
686 0 : kind = y->ts.kind;
687 : }
688 : else
689 : {
690 12 : if (y->ts.type == BT_REAL)
691 12 : kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
692 : else
693 0 : kind = x->ts.kind;
694 : }
695 :
696 12 : f->ts.type = BT_COMPLEX;
697 12 : f->ts.kind = kind;
698 12 : f->value.function.name
699 36 : = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
700 12 : gfc_type_letter (x->ts.type),
701 : gfc_type_abi_kind (&x->ts),
702 12 : gfc_type_letter (y->ts.type),
703 : gfc_type_abi_kind (&y->ts));
704 12 : }
705 :
706 :
707 : void
708 711 : gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
709 : {
710 711 : f->ts = x->ts;
711 711 : f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
712 711 : }
713 :
714 :
715 : void
716 856 : gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
717 : {
718 856 : f->ts = x->ts;
719 856 : f->value.function.name
720 856 : = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type),
721 : gfc_type_abi_kind (&x->ts));
722 856 : }
723 :
724 :
725 : void
726 303 : gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
727 : {
728 303 : f->ts = x->ts;
729 303 : f->value.function.name
730 303 : = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type),
731 : gfc_type_abi_kind (&x->ts));
732 303 : }
733 :
734 :
735 : void
736 6 : gfc_resolve_coshape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
737 : {
738 6 : f->ts.type = BT_INTEGER;
739 6 : if (kind)
740 4 : f->ts.kind = mpz_get_si (kind->value.integer);
741 : else
742 2 : f->ts.kind = gfc_default_integer_kind;
743 :
744 6 : f->value.function.name
745 6 : = gfc_get_string ("__coshape_%c%d", gfc_type_letter (array->ts.type),
746 : gfc_type_abi_kind (&array->ts));
747 6 : f->rank = 1;
748 6 : f->corank = 0;
749 6 : f->shape = gfc_get_shape (1);
750 6 : mpz_init_set_si (f->shape[0], array->corank);
751 6 : }
752 :
753 :
754 : void
755 386 : gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
756 : {
757 386 : f->ts.type = BT_INTEGER;
758 386 : if (kind)
759 5 : f->ts.kind = mpz_get_si (kind->value.integer);
760 : else
761 381 : f->ts.kind = gfc_default_integer_kind;
762 :
763 386 : if (dim != NULL)
764 : {
765 154 : f->rank = mask->rank - 1;
766 154 : gfc_resolve_dim_arg (dim);
767 154 : f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
768 : }
769 :
770 386 : resolve_mask_arg (mask);
771 :
772 386 : f->value.function.name
773 386 : = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts),
774 386 : gfc_type_letter (mask->ts.type));
775 386 : }
776 :
777 :
778 : void
779 879 : gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
780 : gfc_expr *dim)
781 : {
782 879 : int n, m;
783 :
784 879 : if (array->ts.type == BT_CHARACTER && array->ref)
785 416 : gfc_resolve_substring_charlen (array);
786 :
787 879 : f->ts = array->ts;
788 879 : f->rank = array->rank;
789 879 : f->corank = array->corank;
790 879 : f->shape = gfc_copy_shape (array->shape, array->rank);
791 :
792 879 : if (shift->rank > 0)
793 : n = 1;
794 : else
795 634 : n = 0;
796 :
797 : /* If dim kind is greater than default integer we need to use the larger. */
798 879 : m = gfc_default_integer_kind;
799 879 : if (dim != NULL)
800 310 : m = m < dim->ts.kind ? dim->ts.kind : m;
801 :
802 : /* Convert shift to at least m, so we don't need
803 : kind=1 and kind=2 versions of the library functions. */
804 879 : if (shift->ts.kind < m)
805 : {
806 63 : gfc_typespec ts;
807 63 : gfc_clear_ts (&ts);
808 63 : ts.type = BT_INTEGER;
809 63 : ts.kind = m;
810 63 : gfc_convert_type_warn (shift, &ts, 2, 0);
811 : }
812 :
813 879 : if (dim != NULL)
814 : {
815 310 : if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
816 68 : && dim->symtree->n.sym->attr.optional)
817 : {
818 : /* Mark this for later setting the type in gfc_conv_missing_dummy. */
819 18 : dim->representation.length = shift->ts.kind;
820 : }
821 : else
822 : {
823 292 : gfc_resolve_dim_arg (dim);
824 : /* Convert dim to shift's kind to reduce variations. */
825 292 : if (dim->ts.kind != shift->ts.kind)
826 268 : gfc_convert_type_warn (dim, &shift->ts, 2, 0);
827 : }
828 : }
829 :
830 879 : if (array->ts.type == BT_CHARACTER)
831 : {
832 416 : if (array->ts.kind == gfc_default_character_kind)
833 254 : f->value.function.name
834 254 : = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
835 : else
836 162 : f->value.function.name
837 162 : = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
838 : array->ts.kind);
839 : }
840 : else
841 463 : f->value.function.name
842 463 : = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
843 879 : }
844 :
845 :
846 : void
847 0 : gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
848 : {
849 0 : gfc_typespec ts;
850 0 : gfc_clear_ts (&ts);
851 :
852 0 : f->ts.type = BT_CHARACTER;
853 0 : f->ts.kind = gfc_default_character_kind;
854 :
855 : /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
856 0 : if (time->ts.kind != 8)
857 : {
858 0 : ts.type = BT_INTEGER;
859 0 : ts.kind = 8;
860 0 : ts.u.derived = NULL;
861 0 : ts.u.cl = NULL;
862 0 : gfc_convert_type (time, &ts, 2);
863 : }
864 :
865 0 : f->value.function.name = gfc_get_string (PREFIX ("ctime"));
866 0 : }
867 :
868 :
869 : void
870 507 : gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
871 : {
872 507 : f->ts.type = BT_REAL;
873 507 : f->ts.kind = gfc_default_double_kind;
874 507 : f->value.function.name
875 507 : = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type),
876 : gfc_type_abi_kind (&a->ts));
877 507 : }
878 :
879 :
880 : void
881 293 : gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
882 : {
883 293 : f->ts.type = a->ts.type;
884 293 : if (p != NULL)
885 246 : f->ts.kind = gfc_kind_max (a,p);
886 : else
887 47 : f->ts.kind = a->ts.kind;
888 :
889 293 : if (p != NULL && a->ts.kind != p->ts.kind)
890 : {
891 0 : if (a->ts.kind == gfc_kind_max (a,p))
892 0 : gfc_convert_type (p, &a->ts, 2);
893 : else
894 0 : gfc_convert_type (a, &p->ts, 2);
895 : }
896 :
897 293 : f->value.function.name
898 293 : = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type),
899 : gfc_type_abi_kind (&f->ts));
900 293 : }
901 :
902 :
903 : void
904 166 : gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
905 : {
906 166 : gfc_expr temp;
907 :
908 166 : temp.expr_type = EXPR_OP;
909 166 : gfc_clear_ts (&temp.ts);
910 166 : temp.value.op.op = INTRINSIC_NONE;
911 166 : temp.value.op.op1 = a;
912 166 : temp.value.op.op2 = b;
913 166 : gfc_type_convert_binary (&temp, 1);
914 166 : f->ts = temp.ts;
915 166 : f->value.function.name
916 332 : = gfc_get_string (PREFIX ("dot_product_%c%d"),
917 166 : gfc_type_letter (f->ts.type),
918 : gfc_type_abi_kind (&f->ts));
919 166 : }
920 :
921 :
922 : void
923 44 : gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
924 : gfc_expr *b ATTRIBUTE_UNUSED)
925 : {
926 44 : f->ts.kind = gfc_default_double_kind;
927 44 : f->ts.type = BT_REAL;
928 44 : f->value.function.name = gfc_get_string ("__dprod_r%d",
929 : gfc_type_abi_kind (&f->ts));
930 44 : }
931 :
932 :
933 : void
934 388 : gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
935 : gfc_expr *shift ATTRIBUTE_UNUSED)
936 : {
937 388 : char c = i->ts.type == BT_INTEGER ? 'i' : 'u';
938 :
939 388 : f->ts = i->ts;
940 388 : if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
941 194 : f->value.function.name = gfc_get_string ("dshiftl_%c%d", c, f->ts.kind);
942 194 : else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
943 194 : f->value.function.name = gfc_get_string ("dshiftr_%c%d", c, f->ts.kind);
944 : else
945 0 : gcc_unreachable ();
946 388 : }
947 :
948 :
949 : void
950 1526 : gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
951 : gfc_expr *boundary, gfc_expr *dim)
952 : {
953 1526 : int n, m;
954 :
955 1526 : if (array->ts.type == BT_CHARACTER && array->ref)
956 759 : gfc_resolve_substring_charlen (array);
957 :
958 1526 : f->ts = array->ts;
959 1526 : f->rank = array->rank;
960 1526 : f->corank = array->corank;
961 1526 : f->shape = gfc_copy_shape (array->shape, array->rank);
962 :
963 1526 : n = 0;
964 1526 : if (shift->rank > 0)
965 489 : n = n | 1;
966 1526 : if (boundary && boundary->rank > 0)
967 279 : n = n | 2;
968 :
969 : /* If dim kind is greater than default integer we need to use the larger. */
970 1526 : m = gfc_default_integer_kind;
971 1526 : if (dim != NULL)
972 831 : m = m < dim->ts.kind ? dim->ts.kind : m;
973 :
974 : /* Convert shift to at least m, so we don't need
975 : kind=1 and kind=2 versions of the library functions. */
976 1526 : if (shift->ts.kind < m)
977 : {
978 148 : gfc_typespec ts;
979 148 : gfc_clear_ts (&ts);
980 148 : ts.type = BT_INTEGER;
981 148 : ts.kind = m;
982 148 : gfc_convert_type_warn (shift, &ts, 2, 0);
983 : }
984 :
985 1526 : if (dim != NULL)
986 : {
987 831 : if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
988 101 : && dim->symtree->n.sym->attr.optional)
989 : {
990 : /* Mark this for later setting the type in gfc_conv_missing_dummy. */
991 36 : dim->representation.length = shift->ts.kind;
992 : }
993 : else
994 : {
995 795 : gfc_resolve_dim_arg (dim);
996 : /* Convert dim to shift's kind to reduce variations. */
997 795 : if (dim->ts.kind != shift->ts.kind)
998 735 : gfc_convert_type_warn (dim, &shift->ts, 2, 0);
999 : }
1000 : }
1001 :
1002 1526 : if (array->ts.type == BT_CHARACTER)
1003 : {
1004 759 : if (array->ts.kind == gfc_default_character_kind)
1005 495 : f->value.function.name
1006 495 : = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
1007 : else
1008 264 : f->value.function.name
1009 264 : = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
1010 : array->ts.kind);
1011 : }
1012 : else
1013 767 : f->value.function.name
1014 767 : = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
1015 1526 : }
1016 :
1017 :
1018 : void
1019 1151 : gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
1020 : {
1021 1151 : f->ts = x->ts;
1022 1151 : f->value.function.name
1023 1151 : = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type),
1024 : gfc_type_abi_kind (&x->ts));
1025 1151 : }
1026 :
1027 :
1028 : void
1029 870 : gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
1030 : {
1031 870 : f->ts.type = BT_INTEGER;
1032 870 : f->ts.kind = gfc_default_integer_kind;
1033 870 : f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
1034 870 : }
1035 :
1036 :
1037 : /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1038 :
1039 : void
1040 457 : gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
1041 : {
1042 457 : gfc_symbol *vtab;
1043 457 : gfc_symtree *st;
1044 :
1045 : /* Prevent double resolution. */
1046 457 : if (f->ts.type == BT_LOGICAL)
1047 : return;
1048 :
1049 : /* Replace the first argument with the corresponding vtab. */
1050 239 : if (a->ts.type == BT_CLASS)
1051 166 : gfc_add_vptr_component (a);
1052 73 : else if (a->ts.type == BT_DERIVED)
1053 : {
1054 73 : locus where;
1055 :
1056 73 : vtab = gfc_find_derived_vtab (a->ts.u.derived);
1057 : /* Clear the old expr. */
1058 73 : gfc_free_ref_list (a->ref);
1059 73 : where = a->where;
1060 73 : memset (a, '\0', sizeof (gfc_expr));
1061 : /* Construct a new one. */
1062 73 : a->expr_type = EXPR_VARIABLE;
1063 73 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1064 73 : a->symtree = st;
1065 73 : a->ts = vtab->ts;
1066 73 : a->where = where;
1067 : }
1068 :
1069 : /* Replace the second argument with the corresponding vtab. */
1070 239 : if (mo->ts.type == BT_CLASS)
1071 163 : gfc_add_vptr_component (mo);
1072 76 : else if (mo->ts.type == BT_DERIVED)
1073 : {
1074 76 : locus where;
1075 :
1076 76 : vtab = gfc_find_derived_vtab (mo->ts.u.derived);
1077 : /* Clear the old expr. */
1078 76 : where = mo->where;
1079 76 : gfc_free_ref_list (mo->ref);
1080 76 : memset (mo, '\0', sizeof (gfc_expr));
1081 : /* Construct a new one. */
1082 76 : mo->expr_type = EXPR_VARIABLE;
1083 76 : st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1084 76 : mo->symtree = st;
1085 76 : mo->ts = vtab->ts;
1086 76 : mo->where = where;
1087 : }
1088 :
1089 239 : f->ts.type = BT_LOGICAL;
1090 239 : f->ts.kind = 4;
1091 :
1092 239 : f->value.function.isym->formal->ts = a->ts;
1093 239 : f->value.function.isym->formal->next->ts = mo->ts;
1094 :
1095 : /* Call library function. */
1096 239 : f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
1097 : }
1098 :
1099 :
1100 : void
1101 0 : gfc_resolve_fdate (gfc_expr *f)
1102 : {
1103 0 : f->ts.type = BT_CHARACTER;
1104 0 : f->ts.kind = gfc_default_character_kind;
1105 0 : f->value.function.name = gfc_get_string (PREFIX ("fdate"));
1106 0 : }
1107 :
1108 :
1109 : void
1110 386 : gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1111 : {
1112 386 : f->ts.type = BT_INTEGER;
1113 386 : f->ts.kind = (kind == NULL)
1114 2 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1115 386 : f->value.function.name
1116 772 : = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
1117 386 : gfc_type_letter (a->ts.type),
1118 : gfc_type_abi_kind (&a->ts));
1119 386 : }
1120 :
1121 :
1122 : void
1123 0 : gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1124 : {
1125 0 : f->ts.type = BT_INTEGER;
1126 0 : f->ts.kind = gfc_default_integer_kind;
1127 0 : if (n->ts.kind != f->ts.kind)
1128 0 : gfc_convert_type (n, &f->ts, 2);
1129 0 : f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1130 0 : }
1131 :
1132 :
1133 : void
1134 180 : gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1135 : {
1136 180 : f->ts = x->ts;
1137 180 : f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
1138 180 : }
1139 :
1140 :
1141 : /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1142 :
1143 : void
1144 706 : gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1145 : {
1146 706 : f->ts = x->ts;
1147 706 : f->value.function.name = gfc_get_string ("<intrinsic>");
1148 706 : }
1149 :
1150 :
1151 : void
1152 150 : gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1153 : {
1154 150 : f->ts = x->ts;
1155 150 : f->value.function.name
1156 150 : = gfc_get_string ("__tgamma_%d", x->ts.kind);
1157 150 : }
1158 :
1159 :
1160 : void
1161 1 : gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1162 : {
1163 1 : f->ts.type = BT_INTEGER;
1164 1 : f->ts.kind = 4;
1165 1 : f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1166 1 : }
1167 :
1168 :
1169 : void
1170 84 : gfc_resolve_getgid (gfc_expr *f)
1171 : {
1172 84 : f->ts.type = BT_INTEGER;
1173 84 : f->ts.kind = 4;
1174 84 : f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1175 84 : }
1176 :
1177 :
1178 : void
1179 2 : gfc_resolve_getpid (gfc_expr *f)
1180 : {
1181 2 : f->ts.type = BT_INTEGER;
1182 2 : f->ts.kind = 4;
1183 2 : f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1184 2 : }
1185 :
1186 :
1187 : void
1188 96 : gfc_resolve_getuid (gfc_expr *f)
1189 : {
1190 96 : f->ts.type = BT_INTEGER;
1191 96 : f->ts.kind = 4;
1192 96 : f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1193 96 : }
1194 :
1195 :
1196 : void
1197 4 : gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1198 : {
1199 4 : f->ts.type = BT_INTEGER;
1200 4 : f->ts.kind = 4;
1201 4 : f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1202 4 : }
1203 :
1204 :
1205 : void
1206 24 : gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1207 : {
1208 24 : f->ts = x->ts;
1209 24 : f->value.function.name = gfc_get_string ("__hypot_r%d",
1210 : gfc_type_abi_kind (&x->ts));
1211 24 : }
1212 :
1213 :
1214 : void
1215 175 : gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1216 : {
1217 175 : resolve_transformational ("iall", f, array, dim, mask, true);
1218 175 : }
1219 :
1220 :
1221 : void
1222 1606 : gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1223 : {
1224 : /* If the kind of i and j are different, then g77 cross-promoted the
1225 : kinds to the largest value. The Fortran 95 standard requires the
1226 : kinds to match. */
1227 :
1228 1606 : if (i->ts.kind != j->ts.kind)
1229 : {
1230 0 : if (i->ts.kind == gfc_kind_max (i, j))
1231 0 : gfc_convert_type (j, &i->ts, 2);
1232 : else
1233 0 : gfc_convert_type (i, &j->ts, 2);
1234 : }
1235 :
1236 1606 : f->ts = i->ts;
1237 1606 : const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_m_%d" : "__iand_%d";
1238 1606 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1239 1606 : }
1240 :
1241 :
1242 : void
1243 126 : gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1244 : {
1245 126 : resolve_transformational ("iany", f, array, dim, mask, true);
1246 126 : }
1247 :
1248 :
1249 : void
1250 382 : gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1251 : {
1252 382 : f->ts = i->ts;
1253 382 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ibclr_m_%d" : "__ibclr_%d";
1254 382 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1255 382 : }
1256 :
1257 :
1258 : void
1259 78 : gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1260 : gfc_expr *len ATTRIBUTE_UNUSED)
1261 : {
1262 78 : f->ts = i->ts;
1263 78 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ibits_m_%d" : "__ibits_%d";
1264 78 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1265 78 : }
1266 :
1267 :
1268 : void
1269 322 : gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1270 : {
1271 322 : f->ts = i->ts;
1272 322 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ibset_m_%d" : "__ibset_%d";
1273 322 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1274 322 : }
1275 :
1276 :
1277 : void
1278 4913 : gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1279 : {
1280 4913 : f->ts.type = BT_INTEGER;
1281 4913 : if (kind)
1282 4 : f->ts.kind = mpz_get_si (kind->value.integer);
1283 : else
1284 4909 : f->ts.kind = gfc_default_integer_kind;
1285 4913 : f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1286 4913 : }
1287 :
1288 :
1289 : void
1290 1710 : gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1291 : {
1292 1710 : f->ts.type = BT_INTEGER;
1293 1710 : if (kind)
1294 8 : f->ts.kind = mpz_get_si (kind->value.integer);
1295 : else
1296 1702 : f->ts.kind = gfc_default_integer_kind;
1297 1710 : f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1298 1710 : }
1299 :
1300 :
1301 : void
1302 80 : gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1303 : {
1304 80 : gfc_resolve_nint (f, a, NULL);
1305 80 : }
1306 :
1307 :
1308 : void
1309 3 : gfc_resolve_ierrno (gfc_expr *f)
1310 : {
1311 3 : f->ts.type = BT_INTEGER;
1312 3 : f->ts.kind = gfc_default_integer_kind;
1313 3 : f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1314 3 : }
1315 :
1316 :
1317 : void
1318 1783 : gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1319 : {
1320 : /* If the kind of i and j are different, then g77 cross-promoted the
1321 : kinds to the largest value. The Fortran 95 standard requires the
1322 : kinds to match. */
1323 :
1324 1783 : if (i->ts.kind != j->ts.kind)
1325 : {
1326 0 : if (i->ts.kind == gfc_kind_max (i, j))
1327 0 : gfc_convert_type (j, &i->ts, 2);
1328 : else
1329 0 : gfc_convert_type (i, &j->ts, 2);
1330 : }
1331 :
1332 1783 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_m_%d" : "__ieor_%d";
1333 1783 : f->ts = i->ts;
1334 1783 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1335 1783 : }
1336 :
1337 :
1338 : void
1339 1327 : gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1340 : {
1341 : /* If the kind of i and j are different, then g77 cross-promoted the
1342 : kinds to the largest value. The Fortran 95 standard requires the
1343 : kinds to match. */
1344 :
1345 1327 : if (i->ts.kind != j->ts.kind)
1346 : {
1347 0 : if (i->ts.kind == gfc_kind_max (i, j))
1348 0 : gfc_convert_type (j, &i->ts, 2);
1349 : else
1350 0 : gfc_convert_type (i, &j->ts, 2);
1351 : }
1352 :
1353 1327 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_m_%d" : "__ior_%d";
1354 1327 : f->ts = i->ts;
1355 1327 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1356 1327 : }
1357 :
1358 :
1359 : void
1360 1082 : gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1361 : gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1362 : gfc_expr *kind)
1363 : {
1364 1082 : gfc_typespec ts;
1365 1082 : gfc_clear_ts (&ts);
1366 :
1367 1082 : f->ts.type = BT_INTEGER;
1368 1082 : if (kind)
1369 268 : f->ts.kind = mpz_get_si (kind->value.integer);
1370 : else
1371 814 : f->ts.kind = gfc_default_integer_kind;
1372 :
1373 1082 : if (back && back->ts.kind != gfc_default_integer_kind)
1374 : {
1375 0 : ts.type = BT_LOGICAL;
1376 0 : ts.kind = gfc_default_integer_kind;
1377 0 : ts.u.derived = NULL;
1378 0 : ts.u.cl = NULL;
1379 0 : gfc_convert_type (back, &ts, 2);
1380 : }
1381 :
1382 1082 : f->value.function.name
1383 1082 : = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1384 1082 : }
1385 :
1386 :
1387 : void
1388 4388 : gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1389 : {
1390 4388 : f->ts.type = BT_INTEGER;
1391 4388 : f->ts.kind = (kind == NULL)
1392 3534 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1393 4388 : f->value.function.name
1394 8776 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1395 4388 : gfc_type_letter (a->ts.type),
1396 : gfc_type_abi_kind (&a->ts));
1397 4388 : }
1398 :
1399 : void
1400 288 : gfc_resolve_uint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1401 : {
1402 288 : f->ts.type = BT_UNSIGNED;
1403 288 : f->ts.kind = (kind == NULL)
1404 60 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1405 288 : f->value.function.name
1406 576 : = gfc_get_string ("__uint_%d_%c%d", f->ts.kind,
1407 288 : gfc_type_letter (a->ts.type),
1408 : gfc_type_abi_kind (&a->ts));
1409 288 : }
1410 :
1411 :
1412 : void
1413 48 : gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1414 : {
1415 48 : f->ts.type = BT_INTEGER;
1416 48 : f->ts.kind = 2;
1417 48 : f->value.function.name
1418 96 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1419 48 : gfc_type_letter (a->ts.type),
1420 : gfc_type_abi_kind (&a->ts));
1421 48 : }
1422 :
1423 :
1424 : void
1425 36 : gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1426 : {
1427 36 : f->ts.type = BT_INTEGER;
1428 36 : f->ts.kind = 8;
1429 36 : f->value.function.name
1430 72 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1431 36 : gfc_type_letter (a->ts.type),
1432 : gfc_type_abi_kind (&a->ts));
1433 36 : }
1434 :
1435 :
1436 : void
1437 0 : gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1438 : {
1439 0 : f->ts.type = BT_INTEGER;
1440 0 : f->ts.kind = 4;
1441 0 : f->value.function.name
1442 0 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1443 0 : gfc_type_letter (a->ts.type),
1444 : gfc_type_abi_kind (&a->ts));
1445 0 : }
1446 :
1447 :
1448 : void
1449 216 : gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1450 : {
1451 216 : resolve_transformational ("iparity", f, array, dim, mask, true);
1452 216 : }
1453 :
1454 :
1455 : void
1456 0 : gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1457 : {
1458 0 : gfc_typespec ts;
1459 0 : gfc_clear_ts (&ts);
1460 :
1461 0 : f->ts.type = BT_LOGICAL;
1462 0 : f->ts.kind = gfc_default_integer_kind;
1463 0 : if (u->ts.kind != gfc_c_int_kind)
1464 : {
1465 0 : ts.type = BT_INTEGER;
1466 0 : ts.kind = gfc_c_int_kind;
1467 0 : ts.u.derived = NULL;
1468 0 : ts.u.cl = NULL;
1469 0 : gfc_convert_type (u, &ts, 2);
1470 : }
1471 :
1472 0 : f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1473 0 : }
1474 :
1475 :
1476 : void
1477 1067 : gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
1478 : {
1479 1067 : f->ts.type = BT_LOGICAL;
1480 1067 : f->ts.kind = gfc_default_logical_kind;
1481 1067 : f->value.function.name = gfc_get_string ("__is_contiguous");
1482 1067 : }
1483 :
1484 :
1485 : void
1486 929 : gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1487 : {
1488 929 : f->ts = i->ts;
1489 929 : f->value.function.name
1490 929 : = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1491 929 : }
1492 :
1493 :
1494 : void
1495 60 : gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1496 : {
1497 60 : f->ts = i->ts;
1498 60 : f->value.function.name
1499 60 : = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1500 60 : }
1501 :
1502 :
1503 : void
1504 186 : gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1505 : {
1506 186 : f->ts = i->ts;
1507 186 : f->value.function.name
1508 186 : = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1509 186 : }
1510 :
1511 :
1512 : void
1513 1518 : gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1514 : {
1515 1518 : int s_kind;
1516 :
1517 1518 : s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1518 :
1519 1518 : f->ts = i->ts;
1520 1518 : f->value.function.name
1521 1518 : = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1522 1518 : }
1523 :
1524 :
1525 : void
1526 14936 : gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1527 : {
1528 14936 : resolve_bound (f, array, dim, kind, "__lbound", false);
1529 14936 : }
1530 :
1531 :
1532 : void
1533 458 : gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1534 : {
1535 458 : resolve_bound (f, array, dim, kind, "__lcobound", true);
1536 458 : }
1537 :
1538 :
1539 : void
1540 13422 : gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1541 : {
1542 13422 : f->ts.type = BT_INTEGER;
1543 13422 : if (kind)
1544 224 : f->ts.kind = mpz_get_si (kind->value.integer);
1545 : else
1546 13198 : f->ts.kind = gfc_default_integer_kind;
1547 13422 : f->value.function.name
1548 13422 : = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1549 : gfc_default_integer_kind);
1550 13422 : }
1551 :
1552 :
1553 : void
1554 3711 : gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1555 : {
1556 3711 : f->ts.type = BT_INTEGER;
1557 3711 : if (kind)
1558 411 : f->ts.kind = mpz_get_si (kind->value.integer);
1559 : else
1560 3300 : f->ts.kind = gfc_default_integer_kind;
1561 3711 : f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1562 3711 : }
1563 :
1564 :
1565 : void
1566 8 : gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1567 : {
1568 8 : f->ts = x->ts;
1569 8 : f->value.function.name
1570 8 : = gfc_get_string ("__lgamma_%d", x->ts.kind);
1571 8 : }
1572 :
1573 :
1574 : void
1575 4 : gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1576 : gfc_expr *p2 ATTRIBUTE_UNUSED)
1577 : {
1578 4 : f->ts.type = BT_INTEGER;
1579 4 : f->ts.kind = gfc_default_integer_kind;
1580 4 : f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1581 4 : }
1582 :
1583 :
1584 : void
1585 7156 : gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1586 : {
1587 7156 : f->ts.type= BT_INTEGER;
1588 7156 : f->ts.kind = gfc_index_integer_kind;
1589 7156 : f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1590 7156 : }
1591 :
1592 :
1593 : void
1594 345 : gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1595 : {
1596 345 : f->ts = x->ts;
1597 345 : f->value.function.name
1598 345 : = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type),
1599 : gfc_type_abi_kind (&x->ts));
1600 345 : }
1601 :
1602 :
1603 : void
1604 279 : gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1605 : {
1606 279 : f->ts = x->ts;
1607 279 : f->value.function.name
1608 279 : = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1609 : gfc_type_abi_kind (&x->ts));
1610 279 : }
1611 :
1612 :
1613 : void
1614 48 : gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1615 : {
1616 48 : f->ts.type = BT_LOGICAL;
1617 48 : f->ts.kind = (kind == NULL)
1618 24 : ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1619 48 : f->rank = a->rank;
1620 48 : f->corank = a->corank;
1621 :
1622 48 : f->value.function.name
1623 96 : = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1624 48 : gfc_type_letter (a->ts.type),
1625 : gfc_type_abi_kind (&a->ts));
1626 48 : }
1627 :
1628 :
1629 : void
1630 1088 : gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1631 : {
1632 1088 : gfc_expr temp;
1633 1088 : bt type;
1634 :
1635 1088 : if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1636 : {
1637 37 : f->ts.type = BT_LOGICAL;
1638 37 : f->ts.kind = gfc_default_logical_kind;
1639 : }
1640 : else
1641 : {
1642 1051 : temp.expr_type = EXPR_OP;
1643 1051 : gfc_clear_ts (&temp.ts);
1644 1051 : temp.value.op.op = INTRINSIC_NONE;
1645 1051 : temp.value.op.op1 = a;
1646 1051 : temp.value.op.op2 = b;
1647 1051 : gfc_type_convert_binary (&temp, 1);
1648 1051 : f->ts = temp.ts;
1649 : }
1650 :
1651 1088 : f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1652 1088 : f->corank = a->corank;
1653 :
1654 1088 : if (a->rank == 2 && b->rank == 2)
1655 : {
1656 706 : if (a->shape && b->shape)
1657 : {
1658 509 : f->shape = gfc_get_shape (f->rank);
1659 509 : mpz_init_set (f->shape[0], a->shape[0]);
1660 509 : mpz_init_set (f->shape[1], b->shape[1]);
1661 : }
1662 : }
1663 382 : else if (a->rank == 1)
1664 : {
1665 182 : if (b->shape)
1666 : {
1667 102 : f->shape = gfc_get_shape (f->rank);
1668 102 : mpz_init_set (f->shape[0], b->shape[1]);
1669 : }
1670 : }
1671 : else
1672 : {
1673 : /* b->rank == 1 and a->rank == 2 here, all other cases have
1674 : been caught in check.cc. */
1675 200 : if (a->shape)
1676 : {
1677 162 : f->shape = gfc_get_shape (f->rank);
1678 162 : mpz_init_set (f->shape[0], a->shape[0]);
1679 : }
1680 : }
1681 :
1682 : /* We use the same library version of matmul for INTEGER and UNSIGNED,
1683 : which we call as the INTEGER version. */
1684 :
1685 1088 : if (f->ts.type == BT_UNSIGNED)
1686 : type = BT_INTEGER;
1687 : else
1688 1082 : type = f->ts.type;
1689 :
1690 1088 : f->value.function.name
1691 1088 : = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (type),
1692 : gfc_type_abi_kind (&f->ts));
1693 1088 : }
1694 :
1695 :
1696 : static void
1697 4344 : gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1698 : {
1699 4344 : gfc_actual_arglist *a;
1700 :
1701 4344 : f->ts.type = args->expr->ts.type;
1702 4344 : f->ts.kind = args->expr->ts.kind;
1703 : /* Find the largest type kind. */
1704 9581 : for (a = args->next; a; a = a->next)
1705 : {
1706 5237 : if (a->expr->ts.kind > f->ts.kind)
1707 19 : f->ts.kind = a->expr->ts.kind;
1708 : }
1709 :
1710 : /* Convert all parameters to the required kind. */
1711 13925 : for (a = args; a; a = a->next)
1712 : {
1713 9581 : if (a->expr->ts.kind != f->ts.kind)
1714 42 : gfc_convert_type (a->expr, &f->ts, 2);
1715 : }
1716 :
1717 4344 : f->value.function.name
1718 4344 : = gfc_get_string (name, gfc_type_letter (f->ts.type),
1719 : gfc_type_abi_kind (&f->ts));
1720 4344 : }
1721 :
1722 :
1723 : void
1724 2749 : gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1725 : {
1726 2749 : gfc_resolve_minmax ("__max_%c%d", f, args);
1727 2749 : }
1728 :
1729 : /* The smallest kind for which a minloc and maxloc implementation exists. */
1730 :
1731 : #define MINMAXLOC_MIN_KIND 4
1732 :
1733 : void
1734 9576 : gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1735 : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1736 : {
1737 9576 : const char *name;
1738 9576 : int i, j, idim;
1739 9576 : int fkind;
1740 9576 : int d_num;
1741 :
1742 9576 : f->ts.type = BT_INTEGER;
1743 :
1744 : /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1745 : we do a type conversion further down. */
1746 9576 : if (kind)
1747 2236 : fkind = mpz_get_si (kind->value.integer);
1748 : else
1749 7340 : fkind = gfc_default_integer_kind;
1750 :
1751 9576 : if (fkind < MINMAXLOC_MIN_KIND)
1752 728 : f->ts.kind = MINMAXLOC_MIN_KIND;
1753 : else
1754 8848 : f->ts.kind = fkind;
1755 :
1756 9576 : if (dim == NULL)
1757 : {
1758 2925 : f->rank = 1;
1759 2925 : f->shape = gfc_get_shape (1);
1760 2925 : mpz_init_set_si (f->shape[0], array->rank);
1761 : }
1762 : else
1763 : {
1764 6651 : f->rank = array->rank - 1;
1765 6651 : gfc_resolve_dim_arg (dim);
1766 6651 : if (array->shape && dim->expr_type == EXPR_CONSTANT)
1767 : {
1768 5147 : idim = (int) mpz_get_si (dim->value.integer);
1769 5147 : f->shape = gfc_get_shape (f->rank);
1770 9752 : for (i = 0, j = 0; i < f->rank; i++, j++)
1771 : {
1772 4605 : if (i == (idim - 1))
1773 2143 : j++;
1774 4605 : mpz_init_set (f->shape[i], array->shape[j]);
1775 : }
1776 : }
1777 : }
1778 :
1779 9576 : if (mask)
1780 : {
1781 6036 : if (mask->rank == 0)
1782 : name = "smaxloc";
1783 : else
1784 3338 : name = "mmaxloc";
1785 :
1786 6036 : resolve_mask_arg (mask);
1787 : }
1788 : else
1789 : name = "maxloc";
1790 :
1791 9576 : if (dim)
1792 : {
1793 6651 : if (array->ts.type != BT_CHARACTER || f->rank != 0)
1794 : d_num = 1;
1795 : else
1796 9576 : d_num = 2;
1797 : }
1798 : else
1799 : d_num = 0;
1800 :
1801 9576 : f->value.function.name
1802 19152 : = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1803 9576 : gfc_type_letter (array->ts.type),
1804 : gfc_type_abi_kind (&array->ts));
1805 :
1806 9576 : if (kind)
1807 2236 : fkind = mpz_get_si (kind->value.integer);
1808 : else
1809 7340 : fkind = gfc_default_integer_kind;
1810 :
1811 9576 : if (fkind != f->ts.kind)
1812 : {
1813 728 : gfc_typespec ts;
1814 728 : gfc_clear_ts (&ts);
1815 :
1816 728 : ts.type = BT_INTEGER;
1817 728 : ts.kind = fkind;
1818 728 : gfc_convert_type_warn (f, &ts, 2, 0);
1819 : }
1820 :
1821 9576 : if (back->ts.kind != gfc_logical_4_kind)
1822 : {
1823 0 : gfc_typespec ts;
1824 0 : gfc_clear_ts (&ts);
1825 0 : ts.type = BT_LOGICAL;
1826 0 : ts.kind = gfc_logical_4_kind;
1827 0 : gfc_convert_type_warn (back, &ts, 2, 0);
1828 : }
1829 9576 : }
1830 :
1831 :
1832 : void
1833 1269 : gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
1834 : gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
1835 : gfc_expr *back)
1836 : {
1837 1269 : const char *name;
1838 1269 : int i, j, idim;
1839 1269 : int fkind;
1840 1269 : int d_num;
1841 1269 : bt type;
1842 :
1843 : /* See at the end of the function for why this is necessary. */
1844 :
1845 1269 : if (f->do_not_resolve_again)
1846 : return;
1847 :
1848 776 : f->ts.type = BT_INTEGER;
1849 :
1850 : /* We have a single library version, which uses index_type. */
1851 :
1852 776 : if (kind)
1853 0 : fkind = mpz_get_si (kind->value.integer);
1854 : else
1855 776 : fkind = gfc_default_integer_kind;
1856 :
1857 776 : f->ts.kind = gfc_index_integer_kind;
1858 :
1859 : /* Convert value. If array is not LOGICAL and value is, we already
1860 : issued an error earlier. */
1861 :
1862 776 : if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
1863 764 : || array->ts.kind != value->ts.kind)
1864 12 : gfc_convert_type_warn (value, &array->ts, 2, 0);
1865 :
1866 776 : if (dim == NULL)
1867 : {
1868 176 : f->rank = 1;
1869 176 : f->shape = gfc_get_shape (1);
1870 176 : mpz_init_set_si (f->shape[0], array->rank);
1871 : }
1872 : else
1873 : {
1874 600 : f->rank = array->rank - 1;
1875 600 : gfc_resolve_dim_arg (dim);
1876 600 : if (array->shape && dim->expr_type == EXPR_CONSTANT)
1877 : {
1878 390 : idim = (int) mpz_get_si (dim->value.integer);
1879 390 : f->shape = gfc_get_shape (f->rank);
1880 618 : for (i = 0, j = 0; i < f->rank; i++, j++)
1881 : {
1882 228 : if (i == (idim - 1))
1883 150 : j++;
1884 228 : mpz_init_set (f->shape[i], array->shape[j]);
1885 : }
1886 : }
1887 : }
1888 :
1889 776 : if (mask)
1890 : {
1891 396 : if (mask->rank == 0)
1892 : name = "sfindloc";
1893 : else
1894 246 : name = "mfindloc";
1895 :
1896 396 : resolve_mask_arg (mask);
1897 : }
1898 : else
1899 : name = "findloc";
1900 :
1901 776 : if (dim)
1902 : {
1903 600 : if (f->rank > 0)
1904 : d_num = 1;
1905 : else
1906 216 : d_num = 2;
1907 : }
1908 : else
1909 : d_num = 0;
1910 :
1911 776 : if (back->ts.kind != gfc_logical_4_kind)
1912 : {
1913 0 : gfc_typespec ts;
1914 0 : gfc_clear_ts (&ts);
1915 0 : ts.type = BT_LOGICAL;
1916 0 : ts.kind = gfc_logical_4_kind;
1917 0 : gfc_convert_type_warn (back, &ts, 2, 0);
1918 : }
1919 :
1920 : /* Use the INTEGER library function for UNSIGNED. */
1921 776 : if (array->ts.type != BT_UNSIGNED)
1922 728 : type = array->ts.type;
1923 : else
1924 : type = BT_INTEGER;
1925 :
1926 776 : f->value.function.name
1927 1552 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1928 776 : gfc_type_letter (type, true),
1929 : gfc_type_abi_kind (&array->ts));
1930 :
1931 : /* We only have a single library function, so we need to convert
1932 : here. If the function is resolved from within a convert
1933 : function generated on a previous round of resolution, endless
1934 : recursion could occur. Guard against that here. */
1935 :
1936 776 : if (f->ts.kind != fkind)
1937 : {
1938 776 : f->do_not_resolve_again = 1;
1939 776 : gfc_typespec ts;
1940 776 : gfc_clear_ts (&ts);
1941 :
1942 776 : ts.type = BT_INTEGER;
1943 776 : ts.kind = fkind;
1944 776 : gfc_convert_type_warn (f, &ts, 2, 0);
1945 : }
1946 :
1947 : }
1948 :
1949 : void
1950 2914 : gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1951 : gfc_expr *mask)
1952 : {
1953 2914 : const char *name;
1954 2914 : int i, j, idim;
1955 :
1956 2914 : f->ts = array->ts;
1957 :
1958 2914 : if (dim != NULL)
1959 : {
1960 1997 : f->rank = array->rank - 1;
1961 1997 : gfc_resolve_dim_arg (dim);
1962 :
1963 1997 : if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1964 : {
1965 603 : idim = (int) mpz_get_si (dim->value.integer);
1966 603 : f->shape = gfc_get_shape (f->rank);
1967 1212 : for (i = 0, j = 0; i < f->rank; i++, j++)
1968 : {
1969 609 : if (i == (idim - 1))
1970 363 : j++;
1971 609 : mpz_init_set (f->shape[i], array->shape[j]);
1972 : }
1973 : }
1974 : }
1975 :
1976 2914 : if (mask)
1977 : {
1978 1917 : if (mask->rank == 0)
1979 : name = "smaxval";
1980 : else
1981 1179 : name = "mmaxval";
1982 :
1983 1917 : resolve_mask_arg (mask);
1984 : }
1985 : else
1986 : name = "maxval";
1987 :
1988 2914 : if (array->ts.type != BT_CHARACTER)
1989 2494 : f->value.function.name
1990 4988 : = gfc_get_string (PREFIX ("%s_%c%d"), name,
1991 2494 : gfc_type_letter (array->ts.type),
1992 : gfc_type_abi_kind (&array->ts));
1993 : else
1994 420 : f->value.function.name
1995 840 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1996 420 : gfc_type_letter (array->ts.type),
1997 : gfc_type_abi_kind (&array->ts));
1998 2914 : }
1999 :
2000 :
2001 : void
2002 12 : gfc_resolve_mclock (gfc_expr *f)
2003 : {
2004 12 : f->ts.type = BT_INTEGER;
2005 12 : f->ts.kind = 4;
2006 12 : f->value.function.name = PREFIX ("mclock");
2007 12 : }
2008 :
2009 :
2010 : void
2011 12 : gfc_resolve_mclock8 (gfc_expr *f)
2012 : {
2013 12 : f->ts.type = BT_INTEGER;
2014 12 : f->ts.kind = 8;
2015 12 : f->value.function.name = PREFIX ("mclock8");
2016 12 : }
2017 :
2018 :
2019 : void
2020 152 : gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
2021 : gfc_expr *kind)
2022 : {
2023 152 : f->ts.type = BT_INTEGER;
2024 152 : f->ts.kind = kind ? mpz_get_si (kind->value.integer)
2025 : : gfc_default_integer_kind;
2026 :
2027 152 : if (f->value.function.isym->id == GFC_ISYM_MASKL)
2028 80 : f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
2029 : else
2030 72 : f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
2031 152 : }
2032 :
2033 : void
2034 0 : gfc_resolve_umasklr (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
2035 : gfc_expr *kind)
2036 : {
2037 0 : f->ts.type = BT_UNSIGNED;
2038 0 : f->ts.kind = kind ? mpz_get_si (kind->value.integer)
2039 : : gfc_default_unsigned_kind;
2040 :
2041 0 : if (f->value.function.isym->id == GFC_ISYM_UMASKL)
2042 0 : f->value.function.name = gfc_get_string ("__maskl_m%d", f->ts.kind);
2043 : else
2044 0 : f->value.function.name = gfc_get_string ("__maskr_m%d", f->ts.kind);
2045 0 : }
2046 :
2047 :
2048 : void
2049 3809 : gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
2050 : gfc_expr *fsource ATTRIBUTE_UNUSED,
2051 : gfc_expr *mask ATTRIBUTE_UNUSED)
2052 : {
2053 3809 : if (tsource->ts.type == BT_CHARACTER && tsource->ref)
2054 12 : gfc_resolve_substring_charlen (tsource);
2055 :
2056 3809 : if (fsource->ts.type == BT_CHARACTER && fsource->ref)
2057 24 : gfc_resolve_substring_charlen (fsource);
2058 :
2059 3809 : if (tsource->ts.type == BT_CHARACTER)
2060 1256 : check_charlen_present (tsource);
2061 :
2062 3809 : f->ts = tsource->ts;
2063 3809 : f->value.function.name
2064 3809 : = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
2065 : gfc_type_abi_kind (&tsource->ts));
2066 3809 : }
2067 :
2068 :
2069 : void
2070 96 : gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
2071 : gfc_expr *j ATTRIBUTE_UNUSED,
2072 : gfc_expr *mask ATTRIBUTE_UNUSED)
2073 : {
2074 96 : f->ts = i->ts;
2075 :
2076 96 : f->value.function.name
2077 96 : = gfc_get_string ("__merge_bits_%c%d", gfc_type_letter (i->ts.type),
2078 : i->ts.kind);
2079 96 : }
2080 :
2081 :
2082 : void
2083 1595 : gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
2084 : {
2085 1595 : gfc_resolve_minmax ("__min_%c%d", f, args);
2086 1595 : }
2087 :
2088 :
2089 : void
2090 11142 : gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2091 : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
2092 : {
2093 11142 : const char *name;
2094 11142 : int i, j, idim;
2095 11142 : int fkind;
2096 11142 : int d_num;
2097 :
2098 11142 : f->ts.type = BT_INTEGER;
2099 :
2100 : /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
2101 : we do a type conversion further down. */
2102 11142 : if (kind)
2103 2116 : fkind = mpz_get_si (kind->value.integer);
2104 : else
2105 9026 : fkind = gfc_default_integer_kind;
2106 :
2107 11142 : if (fkind < MINMAXLOC_MIN_KIND)
2108 722 : f->ts.kind = MINMAXLOC_MIN_KIND;
2109 : else
2110 10420 : f->ts.kind = fkind;
2111 :
2112 11142 : if (dim == NULL)
2113 : {
2114 3891 : f->rank = 1;
2115 3891 : f->shape = gfc_get_shape (1);
2116 3891 : mpz_init_set_si (f->shape[0], array->rank);
2117 : }
2118 : else
2119 : {
2120 7251 : f->rank = array->rank - 1;
2121 7251 : gfc_resolve_dim_arg (dim);
2122 7251 : if (array->shape && dim->expr_type == EXPR_CONSTANT)
2123 : {
2124 5325 : idim = (int) mpz_get_si (dim->value.integer);
2125 5325 : f->shape = gfc_get_shape (f->rank);
2126 9949 : for (i = 0, j = 0; i < f->rank; i++, j++)
2127 : {
2128 4624 : if (i == (idim - 1))
2129 2136 : j++;
2130 4624 : mpz_init_set (f->shape[i], array->shape[j]);
2131 : }
2132 : }
2133 : }
2134 :
2135 11142 : if (mask)
2136 : {
2137 7149 : if (mask->rank == 0)
2138 : name = "sminloc";
2139 : else
2140 4487 : name = "mminloc";
2141 :
2142 7149 : resolve_mask_arg (mask);
2143 : }
2144 : else
2145 : name = "minloc";
2146 :
2147 11142 : if (dim)
2148 : {
2149 7251 : if (array->ts.type != BT_CHARACTER || f->rank != 0)
2150 : d_num = 1;
2151 : else
2152 11142 : d_num = 2;
2153 : }
2154 : else
2155 : d_num = 0;
2156 :
2157 11142 : f->value.function.name
2158 22284 : = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2159 11142 : gfc_type_letter (array->ts.type),
2160 : gfc_type_abi_kind (&array->ts));
2161 :
2162 11142 : if (fkind != f->ts.kind)
2163 : {
2164 722 : gfc_typespec ts;
2165 722 : gfc_clear_ts (&ts);
2166 :
2167 722 : ts.type = BT_INTEGER;
2168 722 : ts.kind = fkind;
2169 722 : gfc_convert_type_warn (f, &ts, 2, 0);
2170 : }
2171 :
2172 11142 : if (back->ts.kind != gfc_logical_4_kind)
2173 : {
2174 0 : gfc_typespec ts;
2175 0 : gfc_clear_ts (&ts);
2176 0 : ts.type = BT_LOGICAL;
2177 0 : ts.kind = gfc_logical_4_kind;
2178 0 : gfc_convert_type_warn (back, &ts, 2, 0);
2179 : }
2180 11142 : }
2181 :
2182 :
2183 : void
2184 3867 : gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2185 : gfc_expr *mask)
2186 : {
2187 3867 : const char *name;
2188 3867 : int i, j, idim;
2189 :
2190 3867 : f->ts = array->ts;
2191 :
2192 3867 : if (dim != NULL)
2193 : {
2194 2757 : f->rank = array->rank - 1;
2195 2757 : gfc_resolve_dim_arg (dim);
2196 :
2197 2757 : if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2198 : {
2199 825 : idim = (int) mpz_get_si (dim->value.integer);
2200 825 : f->shape = gfc_get_shape (f->rank);
2201 1650 : for (i = 0, j = 0; i < f->rank; i++, j++)
2202 : {
2203 825 : if (i == (idim - 1))
2204 465 : j++;
2205 825 : mpz_init_set (f->shape[i], array->shape[j]);
2206 : }
2207 : }
2208 : }
2209 :
2210 3867 : if (mask)
2211 : {
2212 2739 : if (mask->rank == 0)
2213 : name = "sminval";
2214 : else
2215 2043 : name = "mminval";
2216 :
2217 2739 : resolve_mask_arg (mask);
2218 : }
2219 : else
2220 : name = "minval";
2221 :
2222 3867 : if (array->ts.type != BT_CHARACTER)
2223 3453 : f->value.function.name
2224 6906 : = gfc_get_string (PREFIX ("%s_%c%d"), name,
2225 3453 : gfc_type_letter (array->ts.type),
2226 : gfc_type_abi_kind (&array->ts));
2227 : else
2228 414 : f->value.function.name
2229 828 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2230 414 : gfc_type_letter (array->ts.type),
2231 : gfc_type_abi_kind (&array->ts));
2232 3867 : }
2233 :
2234 :
2235 : void
2236 4324 : gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2237 : {
2238 4324 : f->ts.type = a->ts.type;
2239 4324 : if (p != NULL)
2240 4276 : f->ts.kind = gfc_kind_max (a,p);
2241 : else
2242 48 : f->ts.kind = a->ts.kind;
2243 :
2244 4324 : if (p != NULL && a->ts.kind != p->ts.kind)
2245 : {
2246 134 : if (a->ts.kind == gfc_kind_max (a,p))
2247 134 : gfc_convert_type (p, &a->ts, 2);
2248 : else
2249 0 : gfc_convert_type (a, &p->ts, 2);
2250 : }
2251 :
2252 4324 : f->value.function.name
2253 4324 : = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2254 : gfc_type_abi_kind (&f->ts));
2255 4324 : }
2256 :
2257 :
2258 : void
2259 1678 : gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2260 : {
2261 1678 : f->ts.type = a->ts.type;
2262 1678 : if (p != NULL)
2263 1678 : f->ts.kind = gfc_kind_max (a,p);
2264 : else
2265 0 : f->ts.kind = a->ts.kind;
2266 :
2267 1678 : if (p != NULL && a->ts.kind != p->ts.kind)
2268 : {
2269 2 : if (a->ts.kind == gfc_kind_max (a,p))
2270 1 : gfc_convert_type (p, &a->ts, 2);
2271 : else
2272 1 : gfc_convert_type (a, &p->ts, 2);
2273 : }
2274 :
2275 1678 : f->value.function.name
2276 1678 : = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2277 : gfc_type_abi_kind (&f->ts));
2278 1678 : }
2279 :
2280 : void
2281 5434 : gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2282 : {
2283 5434 : if (p->ts.kind != a->ts.kind)
2284 600 : gfc_convert_type (p, &a->ts, 2);
2285 :
2286 5434 : f->ts = a->ts;
2287 5434 : f->value.function.name
2288 5434 : = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2289 : gfc_type_abi_kind (&a->ts));
2290 5434 : }
2291 :
2292 : void
2293 394 : gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2294 : {
2295 394 : f->ts.type = BT_INTEGER;
2296 394 : f->ts.kind = (kind == NULL)
2297 48 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2298 394 : f->value.function.name
2299 394 : = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2300 394 : }
2301 :
2302 :
2303 : void
2304 386 : gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2305 : {
2306 386 : resolve_transformational ("norm2", f, array, dim, NULL);
2307 386 : }
2308 :
2309 :
2310 : void
2311 391 : gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2312 : {
2313 391 : f->ts = i->ts;
2314 391 : const char *name = i->ts.kind == BT_UNSIGNED ? "__not_u_%d" : "__not_%d";
2315 391 : f->value.function.name = gfc_get_string (name, i->ts.kind);
2316 391 : }
2317 :
2318 :
2319 : void
2320 14 : gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2321 : {
2322 14 : f->ts.type = i->ts.type;
2323 14 : f->ts.kind = gfc_kind_max (i, j);
2324 :
2325 14 : if (i->ts.kind != j->ts.kind)
2326 : {
2327 0 : if (i->ts.kind == gfc_kind_max (i, j))
2328 0 : gfc_convert_type (j, &i->ts, 2);
2329 : else
2330 0 : gfc_convert_type (i, &j->ts, 2);
2331 : }
2332 :
2333 14 : f->value.function.name
2334 14 : = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type),
2335 : gfc_type_abi_kind (&f->ts));
2336 14 : }
2337 :
2338 :
2339 : void
2340 925 : gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2341 : gfc_expr *vector ATTRIBUTE_UNUSED)
2342 : {
2343 925 : if (array->ts.type == BT_CHARACTER && array->ref)
2344 135 : gfc_resolve_substring_charlen (array);
2345 :
2346 925 : f->ts = array->ts;
2347 925 : f->rank = 1;
2348 :
2349 925 : resolve_mask_arg (mask);
2350 :
2351 925 : if (mask->rank != 0)
2352 : {
2353 577 : if (array->ts.type == BT_CHARACTER)
2354 88 : f->value.function.name
2355 148 : = array->ts.kind == 1 ? PREFIX ("pack_char")
2356 : : gfc_get_string
2357 60 : (PREFIX ("pack_char%d"),
2358 : array->ts.kind);
2359 : else
2360 489 : f->value.function.name = PREFIX ("pack");
2361 : }
2362 : else
2363 : {
2364 348 : if (array->ts.type == BT_CHARACTER)
2365 48 : f->value.function.name
2366 48 : = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2367 : : gfc_get_string
2368 0 : (PREFIX ("pack_s_char%d"),
2369 : array->ts.kind);
2370 : else
2371 300 : f->value.function.name = PREFIX ("pack_s");
2372 : }
2373 925 : }
2374 :
2375 :
2376 : void
2377 96 : gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2378 : {
2379 96 : resolve_transformational ("parity", f, array, dim, NULL);
2380 96 : }
2381 :
2382 :
2383 : void
2384 667 : gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2385 : gfc_expr *mask)
2386 : {
2387 667 : resolve_transformational ("product", f, array, dim, mask, true);
2388 667 : }
2389 :
2390 :
2391 : void
2392 1511 : gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2393 : {
2394 1511 : f->ts.type = BT_INTEGER;
2395 1511 : f->ts.kind = gfc_default_integer_kind;
2396 1511 : f->value.function.name = gfc_get_string ("__rank");
2397 1511 : }
2398 :
2399 :
2400 : void
2401 5761 : gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2402 : {
2403 5761 : f->ts.type = BT_REAL;
2404 :
2405 5761 : if (kind != NULL)
2406 1612 : f->ts.kind = mpz_get_si (kind->value.integer);
2407 : else
2408 4149 : f->ts.kind = (a->ts.type == BT_COMPLEX)
2409 4149 : ? a->ts.kind : gfc_default_real_kind;
2410 :
2411 5761 : f->value.function.name
2412 11522 : = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2413 5761 : gfc_type_letter (a->ts.type),
2414 : gfc_type_abi_kind (&a->ts));
2415 5761 : }
2416 :
2417 :
2418 : void
2419 6 : gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2420 : {
2421 6 : f->ts.type = BT_REAL;
2422 6 : f->ts.kind = a->ts.kind;
2423 6 : f->value.function.name
2424 12 : = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2425 6 : gfc_type_letter (a->ts.type),
2426 : gfc_type_abi_kind (&a->ts));
2427 6 : }
2428 :
2429 :
2430 : /* Generate a wrapper subroutine for the operation so that the library REDUCE
2431 : function can use pointer arithmetic for OPERATION and not be dependent on
2432 : knowledge of its type. */
2433 : static gfc_symtree *
2434 229 : generate_reduce_op_wrapper (gfc_expr *op)
2435 : {
2436 229 : gfc_symbol *operation = op->symtree->n.sym;
2437 229 : gfc_symbol *wrapper, *a, *b, *c;
2438 229 : gfc_symtree *st;
2439 229 : char tname[2 * GFC_MAX_SYMBOL_LEN + 2];
2440 229 : char *name;
2441 229 : gfc_namespace *ns;
2442 229 : gfc_expr *e;
2443 :
2444 : /* Find the top-level namespace. */
2445 229 : for (ns = gfc_current_ns; ns; ns = ns->parent)
2446 229 : if (!ns->parent)
2447 : break;
2448 :
2449 229 : sprintf (tname, "%s_%s", operation->name,
2450 229 : ns->proc_name ? ns->proc_name->name : "noname");
2451 229 : name = xasprintf ("__reduce_wrapper_%s", tname);
2452 :
2453 229 : gfc_find_sym_tree (name, ns, 0, &st);
2454 :
2455 229 : if (st && !strcmp (name, st->name))
2456 : {
2457 162 : free (name);
2458 162 : return st;
2459 : }
2460 :
2461 : /* Create the wrapper namespace and contain it in 'ns'. */
2462 67 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
2463 67 : sub_ns->sibling = ns->contained;
2464 67 : ns->contained = sub_ns;
2465 67 : sub_ns->resolved = 1;
2466 :
2467 : /* Set up procedure symbol. */
2468 67 : gfc_get_symbol (name, ns, &wrapper);
2469 67 : sub_ns->proc_name = wrapper;
2470 67 : wrapper->attr.flavor = FL_PROCEDURE;
2471 67 : wrapper->attr.subroutine = 1;
2472 67 : wrapper->attr.artificial = 1;
2473 67 : wrapper->attr.if_source = IFSRC_DECL;
2474 67 : if (ns->proc_name->attr.flavor == FL_MODULE)
2475 0 : wrapper->module = ns->proc_name->name;
2476 67 : gfc_set_sym_referenced (wrapper);
2477 :
2478 : /* Set up formal argument for the argument 'a'. */
2479 67 : gfc_get_symbol ("a", sub_ns, &a);
2480 67 : a->ts = operation->ts;
2481 67 : a->attr.flavor = FL_VARIABLE;
2482 67 : a->attr.dummy = 1;
2483 67 : a->attr.artificial = 1;
2484 67 : a->attr.intent = INTENT_IN;
2485 67 : wrapper->formal = gfc_get_formal_arglist ();
2486 67 : wrapper->formal->sym = a;
2487 67 : gfc_set_sym_referenced (a);
2488 :
2489 : /* Set up formal argument for the argument 'b'. This is optional. When
2490 : present, the wrapped function is called, otherwise 'a' is assigned
2491 : to 'c'. This way, deep copies are effected in the library. */
2492 67 : gfc_get_symbol ("b", sub_ns, &b);
2493 67 : b->ts = operation->ts;
2494 67 : b->attr.flavor = FL_VARIABLE;
2495 67 : b->attr.dummy = 1;
2496 67 : b->attr.optional= 1;
2497 67 : b->attr.artificial = 1;
2498 67 : b->attr.intent = INTENT_IN;
2499 67 : wrapper->formal->next = gfc_get_formal_arglist ();
2500 67 : wrapper->formal->next->sym = b;
2501 67 : gfc_set_sym_referenced (b);
2502 :
2503 : /* Set up formal argument for the argument 'c'. */
2504 67 : gfc_get_symbol ("c", sub_ns, &c);
2505 67 : c->ts = operation->ts;
2506 67 : c->attr.flavor = FL_VARIABLE;
2507 67 : c->attr.dummy = 1;
2508 67 : c->attr.artificial = 1;
2509 67 : c->attr.intent = INTENT_INOUT;
2510 67 : wrapper->formal->next->next = gfc_get_formal_arglist ();
2511 67 : wrapper->formal->next->next->sym = c;
2512 67 : gfc_set_sym_referenced (c);
2513 :
2514 : /* The only code is:
2515 : if (present (b))
2516 : c = operation (a, b)
2517 : else
2518 : c = a
2519 : endif
2520 : A call with 'b' missing provides a convenient way for the library to do
2521 : an intrinsic assignment instead of a call to memcpy and, where allocatable
2522 : components are present, a deep copy.
2523 :
2524 : Code for if (present (b)) */
2525 67 : sub_ns->code = gfc_get_code (EXEC_IF);
2526 67 : gfc_code *if_block = sub_ns->code;
2527 67 : if_block->block = gfc_get_code (EXEC_IF);
2528 67 : if_block->block->expr1 = gfc_get_expr ();
2529 67 : e = if_block->block->expr1;
2530 67 : e->expr_type = EXPR_FUNCTION;
2531 67 : e->where = gfc_current_locus;
2532 67 : gfc_get_sym_tree ("present", sub_ns, &e->symtree, false);
2533 67 : e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
2534 67 : e->symtree->n.sym->attr.intrinsic = 1;
2535 67 : e->ts.type = BT_LOGICAL;
2536 67 : e->ts.kind = gfc_default_logical_kind;
2537 67 : e->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_PRESENT);
2538 67 : e->value.function.actual = gfc_get_actual_arglist ();
2539 67 : e->value.function.actual->expr = gfc_lval_expr_from_sym (b);
2540 :
2541 : /* Code for c = operation (a, b) */
2542 67 : if_block->block->next = gfc_get_code (EXEC_ASSIGN);
2543 67 : if_block->block->next->expr1 = gfc_lval_expr_from_sym (c);
2544 67 : if_block->block->next->expr2 = gfc_get_expr ();
2545 67 : e = if_block->block->next->expr2;
2546 67 : e->expr_type = EXPR_FUNCTION;
2547 67 : e->where = gfc_current_locus;
2548 67 : if_block->block->next->expr2->ts = operation->ts;
2549 67 : gfc_get_sym_tree (operation->name, ns, &e->symtree, false);
2550 67 : e->value.function.esym = if_block->block->next->expr2->symtree->n.sym;
2551 67 : e->value.function.actual = gfc_get_actual_arglist ();
2552 67 : e->value.function.actual->expr = gfc_lval_expr_from_sym (a);
2553 67 : e->value.function.actual->next = gfc_get_actual_arglist ();
2554 67 : e->value.function.actual->next->expr = gfc_lval_expr_from_sym (b);
2555 :
2556 67 : if_block->block->block = gfc_get_code (EXEC_IF);
2557 67 : if_block->block->block->next = gfc_get_code (EXEC_ASSIGN);
2558 67 : if_block->block->block->next->expr1 = gfc_lval_expr_from_sym (c);
2559 67 : if_block->block->block->next->expr2 = gfc_lval_expr_from_sym (a);
2560 :
2561 : /* It is unexpected to have some symbols added at resolution. Commit the
2562 : changes in order to keep a clean state. */
2563 67 : gfc_commit_symbol (if_block->block->expr1->symtree->n.sym);
2564 67 : gfc_commit_symbol (wrapper);
2565 67 : gfc_commit_symbol (a);
2566 67 : gfc_commit_symbol (b);
2567 67 : gfc_commit_symbol (c);
2568 :
2569 67 : gfc_find_sym_tree (name, ns, 0, &st);
2570 67 : free (name);
2571 :
2572 67 : return st;
2573 : }
2574 :
2575 : void
2576 229 : gfc_resolve_reduce (gfc_expr *f, gfc_expr *array,
2577 : gfc_expr *operation,
2578 : gfc_expr *dim,
2579 : gfc_expr *mask,
2580 : gfc_expr *identity ATTRIBUTE_UNUSED,
2581 : gfc_expr *ordered ATTRIBUTE_UNUSED)
2582 : {
2583 229 : gfc_symtree *wrapper_symtree;
2584 229 : gfc_typespec ts;
2585 :
2586 229 : gfc_resolve_expr (array);
2587 229 : if (array->ts.type == BT_CHARACTER && array->ref)
2588 6 : gfc_resolve_substring_charlen (array);
2589 :
2590 229 : f->ts = array->ts;
2591 :
2592 : /* Replace 'operation' with its subroutine wrapper so that pointers may be
2593 : used throughout the library function. */
2594 229 : wrapper_symtree = generate_reduce_op_wrapper (operation);
2595 229 : gcc_assert (wrapper_symtree && wrapper_symtree->n.sym);
2596 229 : operation->symtree = wrapper_symtree;
2597 229 : operation->ts = operation->symtree->n.sym->ts;
2598 :
2599 : /* The scalar library function converts the scalar result to a dimension
2600 : zero descriptor and then returns the data after the call. */
2601 229 : if (f->ts.type == BT_CHARACTER)
2602 : {
2603 12 : if (dim && array->rank > 1)
2604 : {
2605 6 : f->value.function.name = gfc_get_string (PREFIX ("reduce_c"));
2606 6 : f->rank = array->rank - 1;
2607 : }
2608 : else
2609 : {
2610 6 : f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar_c"));
2611 6 : f->rank = 0;
2612 : }
2613 : }
2614 : else
2615 : {
2616 217 : if (dim && array->rank > 1)
2617 : {
2618 120 : f->value.function.name = gfc_get_string (PREFIX ("reduce"));
2619 120 : f->rank = array->rank - 1;
2620 : }
2621 : else
2622 : {
2623 97 : f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar"));
2624 97 : f->rank = 0;
2625 : }
2626 : }
2627 :
2628 229 : if (dim)
2629 : {
2630 138 : ts = dim->ts;
2631 138 : ts.kind = 4;
2632 138 : gfc_convert_type_warn (dim, &ts, 1, 0);
2633 : }
2634 :
2635 229 : if (mask)
2636 : {
2637 73 : ts = mask->ts;
2638 73 : ts.kind = 4;
2639 73 : gfc_convert_type_warn (mask, &ts, 1, 0);
2640 : }
2641 229 : }
2642 :
2643 :
2644 : void
2645 4 : gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2646 : gfc_expr *p2 ATTRIBUTE_UNUSED)
2647 : {
2648 4 : f->ts.type = BT_INTEGER;
2649 4 : f->ts.kind = gfc_default_integer_kind;
2650 4 : f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2651 4 : }
2652 :
2653 :
2654 : void
2655 920 : gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2656 : gfc_expr *ncopies)
2657 : {
2658 920 : gfc_expr *tmp;
2659 920 : f->ts.type = BT_CHARACTER;
2660 920 : f->ts.kind = string->ts.kind;
2661 920 : f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2662 :
2663 : /* If possible, generate a character length. */
2664 920 : if (f->ts.u.cl == NULL)
2665 546 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2666 :
2667 920 : tmp = NULL;
2668 920 : if (string->expr_type == EXPR_CONSTANT)
2669 : {
2670 331 : tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2671 331 : string->value.character.length);
2672 : }
2673 589 : else if (string->ts.u.cl && string->ts.u.cl->length)
2674 : {
2675 511 : tmp = gfc_copy_expr (string->ts.u.cl->length);
2676 : }
2677 :
2678 842 : if (tmp)
2679 : {
2680 : /* Force-convert to gfc_charlen_int_kind before gfc_multiply. */
2681 842 : gfc_expr *e = gfc_copy_expr (ncopies);
2682 842 : gfc_typespec ts = tmp->ts;
2683 842 : ts.kind = gfc_charlen_int_kind;
2684 842 : gfc_convert_type_warn (e, &ts, 2, 0);
2685 842 : gfc_convert_type_warn (tmp, &ts, 2, 0);
2686 842 : f->ts.u.cl->length = gfc_multiply (tmp, e);
2687 : }
2688 920 : }
2689 :
2690 :
2691 : void
2692 3172 : gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2693 : gfc_expr *pad ATTRIBUTE_UNUSED,
2694 : gfc_expr *order ATTRIBUTE_UNUSED)
2695 : {
2696 3172 : mpz_t rank;
2697 3172 : int kind;
2698 3172 : int i;
2699 :
2700 3172 : if (source->ts.type == BT_CHARACTER && source->ref)
2701 302 : gfc_resolve_substring_charlen (source);
2702 :
2703 3172 : f->ts = source->ts;
2704 :
2705 3172 : gfc_array_size (shape, &rank);
2706 3172 : f->rank = mpz_get_si (rank);
2707 3172 : mpz_clear (rank);
2708 3172 : switch (source->ts.type)
2709 : {
2710 3052 : case BT_COMPLEX:
2711 3052 : case BT_REAL:
2712 3052 : case BT_INTEGER:
2713 3052 : case BT_LOGICAL:
2714 3052 : case BT_CHARACTER:
2715 3052 : kind = source->ts.kind;
2716 3052 : break;
2717 :
2718 : default:
2719 : kind = 0;
2720 : break;
2721 : }
2722 :
2723 3052 : switch (kind)
2724 : {
2725 2728 : case 4:
2726 2728 : case 8:
2727 2728 : case 10:
2728 2728 : case 16:
2729 2728 : if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2730 613 : f->value.function.name
2731 1226 : = gfc_get_string (PREFIX ("reshape_%c%d"),
2732 613 : gfc_type_letter (source->ts.type),
2733 : gfc_type_abi_kind (&source->ts));
2734 2115 : else if (source->ts.type == BT_CHARACTER)
2735 14 : f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2736 : kind);
2737 : else
2738 2101 : f->value.function.name
2739 2101 : = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2740 : break;
2741 :
2742 444 : default:
2743 888 : f->value.function.name = (source->ts.type == BT_CHARACTER
2744 444 : ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2745 444 : break;
2746 : }
2747 :
2748 3172 : if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2749 : {
2750 1512 : gfc_constructor *c;
2751 1512 : f->shape = gfc_get_shape (f->rank);
2752 1512 : c = gfc_constructor_first (shape->value.constructor);
2753 6436 : for (i = 0; i < f->rank; i++)
2754 : {
2755 3412 : mpz_init_set (f->shape[i], c->expr->value.integer);
2756 3412 : c = gfc_constructor_next (c);
2757 : }
2758 : }
2759 :
2760 : /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2761 : so many runtime variations. */
2762 3172 : if (shape->ts.kind != gfc_index_integer_kind)
2763 : {
2764 2601 : gfc_typespec ts = shape->ts;
2765 2601 : ts.kind = gfc_index_integer_kind;
2766 2601 : gfc_convert_type_warn (shape, &ts, 2, 0);
2767 : }
2768 3172 : if (order && order->ts.kind != gfc_index_integer_kind)
2769 110 : gfc_convert_type_warn (order, &shape->ts, 2, 0);
2770 3172 : }
2771 :
2772 :
2773 : void
2774 132 : gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2775 : {
2776 132 : f->ts = x->ts;
2777 132 : f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2778 132 : }
2779 :
2780 : void
2781 391 : gfc_resolve_fe_runtime_error (gfc_code *c)
2782 : {
2783 391 : const char *name;
2784 391 : gfc_actual_arglist *a;
2785 :
2786 391 : name = gfc_get_string (PREFIX ("runtime_error"));
2787 :
2788 1173 : for (a = c->ext.actual->next; a; a = a->next)
2789 782 : a->name = "%VAL";
2790 :
2791 391 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2792 : /* We set the backend_decl here because runtime_error is a
2793 : variadic function and we would use the wrong calling
2794 : convention otherwise. */
2795 391 : c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2796 391 : }
2797 :
2798 : void
2799 156 : gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2800 : {
2801 156 : f->ts = x->ts;
2802 156 : f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2803 156 : }
2804 :
2805 :
2806 : void
2807 814 : gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2808 : gfc_expr *set ATTRIBUTE_UNUSED,
2809 : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2810 : {
2811 814 : f->ts.type = BT_INTEGER;
2812 814 : if (kind)
2813 232 : f->ts.kind = mpz_get_si (kind->value.integer);
2814 : else
2815 582 : f->ts.kind = gfc_default_integer_kind;
2816 814 : f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2817 814 : }
2818 :
2819 :
2820 : void
2821 32 : gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2822 : {
2823 32 : t1->ts = t0->ts;
2824 32 : t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2825 32 : }
2826 :
2827 :
2828 : void
2829 620 : gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2830 : gfc_expr *i ATTRIBUTE_UNUSED)
2831 : {
2832 620 : f->ts = x->ts;
2833 620 : f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2834 620 : }
2835 :
2836 :
2837 : void
2838 9545 : gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2839 : {
2840 9545 : f->ts.type = BT_INTEGER;
2841 :
2842 9545 : if (kind)
2843 69 : f->ts.kind = mpz_get_si (kind->value.integer);
2844 : else
2845 9476 : f->ts.kind = gfc_default_integer_kind;
2846 :
2847 9545 : f->rank = 1;
2848 9545 : if (array->rank != -1)
2849 : {
2850 8657 : f->shape = gfc_get_shape (1);
2851 8657 : mpz_init_set_ui (f->shape[0], array->rank);
2852 : }
2853 :
2854 9545 : f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2855 9545 : }
2856 :
2857 :
2858 : void
2859 924 : gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2860 : {
2861 924 : f->ts = i->ts;
2862 924 : if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2863 192 : f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2864 732 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2865 576 : f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2866 156 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2867 156 : f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2868 : else
2869 0 : gcc_unreachable ();
2870 924 : }
2871 :
2872 :
2873 : void
2874 1318 : gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2875 : {
2876 1318 : f->ts = a->ts;
2877 1318 : f->value.function.name
2878 1318 : = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
2879 : gfc_type_abi_kind (&a->ts));
2880 1318 : }
2881 :
2882 :
2883 : void
2884 1 : gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2885 : {
2886 1 : f->ts.type = BT_INTEGER;
2887 1 : f->ts.kind = gfc_c_int_kind;
2888 :
2889 : /* handler can be either BT_INTEGER or BT_PROCEDURE */
2890 1 : if (handler->ts.type == BT_INTEGER)
2891 : {
2892 0 : if (handler->ts.kind != gfc_c_int_kind)
2893 0 : gfc_convert_type (handler, &f->ts, 2);
2894 0 : f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2895 : }
2896 : else
2897 1 : f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2898 :
2899 1 : if (number->ts.kind != gfc_c_int_kind)
2900 0 : gfc_convert_type (number, &f->ts, 2);
2901 1 : }
2902 :
2903 :
2904 : void
2905 733 : gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2906 : {
2907 733 : f->ts = x->ts;
2908 733 : f->value.function.name
2909 733 : = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2910 : gfc_type_abi_kind (&x->ts));
2911 733 : }
2912 :
2913 :
2914 : void
2915 302 : gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2916 : {
2917 302 : f->ts = x->ts;
2918 302 : f->value.function.name
2919 302 : = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
2920 : gfc_type_abi_kind (&x->ts));
2921 302 : }
2922 :
2923 :
2924 : void
2925 27446 : gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2926 : gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2927 : {
2928 27446 : f->ts.type = BT_INTEGER;
2929 27446 : if (kind)
2930 4829 : f->ts.kind = mpz_get_si (kind->value.integer);
2931 : else
2932 22617 : f->ts.kind = gfc_default_integer_kind;
2933 27446 : }
2934 :
2935 :
2936 : void
2937 0 : gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2938 : gfc_expr *dim ATTRIBUTE_UNUSED)
2939 : {
2940 0 : f->ts.type = BT_INTEGER;
2941 0 : f->ts.kind = gfc_index_integer_kind;
2942 0 : }
2943 :
2944 :
2945 : void
2946 213 : gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2947 : {
2948 213 : f->ts = x->ts;
2949 213 : f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2950 213 : }
2951 :
2952 :
2953 : void
2954 709 : gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2955 : gfc_expr *ncopies)
2956 : {
2957 709 : if (source->ts.type == BT_CHARACTER && source->ref)
2958 84 : gfc_resolve_substring_charlen (source);
2959 :
2960 709 : if (source->ts.type == BT_CHARACTER)
2961 113 : check_charlen_present (source);
2962 :
2963 709 : f->ts = source->ts;
2964 709 : f->rank = source->rank + 1;
2965 709 : if (source->rank == 0)
2966 : {
2967 38 : if (source->ts.type == BT_CHARACTER)
2968 29 : f->value.function.name
2969 29 : = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2970 : : gfc_get_string
2971 0 : (PREFIX ("spread_char%d_scalar"),
2972 : source->ts.kind);
2973 : else
2974 9 : f->value.function.name = PREFIX ("spread_scalar");
2975 : }
2976 : else
2977 : {
2978 671 : if (source->ts.type == BT_CHARACTER)
2979 84 : f->value.function.name
2980 132 : = source->ts.kind == 1 ? PREFIX ("spread_char")
2981 : : gfc_get_string
2982 48 : (PREFIX ("spread_char%d"),
2983 : source->ts.kind);
2984 : else
2985 587 : f->value.function.name = PREFIX ("spread");
2986 : }
2987 :
2988 709 : if (dim && gfc_is_constant_expr (dim)
2989 1418 : && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2990 : {
2991 454 : int i, idim;
2992 454 : idim = mpz_get_ui (dim->value.integer);
2993 454 : f->shape = gfc_get_shape (f->rank);
2994 482 : for (i = 0; i < (idim - 1); i++)
2995 28 : mpz_init_set (f->shape[i], source->shape[i]);
2996 :
2997 454 : mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2998 :
2999 1730 : for (i = idim; i < f->rank ; i++)
3000 822 : mpz_init_set (f->shape[i], source->shape[i-1]);
3001 : }
3002 :
3003 :
3004 709 : gfc_resolve_dim_arg (dim);
3005 709 : gfc_resolve_index (ncopies, 1);
3006 709 : }
3007 :
3008 :
3009 : void
3010 1216 : gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
3011 : {
3012 1216 : f->ts = x->ts;
3013 1216 : f->value.function.name
3014 1216 : = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
3015 : gfc_type_abi_kind (&x->ts));
3016 1216 : }
3017 :
3018 :
3019 : /* Resolve the g77 compatibility function STAT AND FSTAT. */
3020 :
3021 : void
3022 16 : gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a)
3023 : {
3024 16 : f->ts.type = BT_INTEGER;
3025 16 : f->ts.kind = a->ts.kind;
3026 16 : f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
3027 16 : }
3028 :
3029 :
3030 : void
3031 10 : gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a)
3032 : {
3033 10 : f->ts.type = BT_INTEGER;
3034 10 : f->ts.kind = a->ts.kind;
3035 10 : f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
3036 10 : }
3037 :
3038 :
3039 : void
3040 13 : gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a)
3041 : {
3042 13 : f->ts.type = BT_INTEGER;
3043 13 : f->ts.kind = a->ts.kind;
3044 13 : if (n->ts.kind != f->ts.kind)
3045 4 : gfc_convert_type (n, &f->ts, 2);
3046 :
3047 13 : f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
3048 13 : }
3049 :
3050 :
3051 : void
3052 43 : gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
3053 : {
3054 43 : gfc_typespec ts;
3055 43 : gfc_clear_ts (&ts);
3056 :
3057 43 : f->ts.type = BT_INTEGER;
3058 43 : f->ts.kind = gfc_c_int_kind;
3059 43 : if (u->ts.kind != gfc_c_int_kind)
3060 : {
3061 0 : ts.type = BT_INTEGER;
3062 0 : ts.kind = gfc_c_int_kind;
3063 0 : ts.u.derived = NULL;
3064 0 : ts.u.cl = NULL;
3065 0 : gfc_convert_type (u, &ts, 2);
3066 : }
3067 :
3068 43 : f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
3069 43 : }
3070 :
3071 :
3072 : void
3073 3 : gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
3074 : {
3075 3 : f->ts.type = BT_INTEGER;
3076 3 : f->ts.kind = gfc_c_int_kind;
3077 3 : f->value.function.name = gfc_get_string (PREFIX ("fget"));
3078 3 : }
3079 :
3080 :
3081 : void
3082 25 : gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
3083 : {
3084 25 : gfc_typespec ts;
3085 25 : gfc_clear_ts (&ts);
3086 :
3087 25 : f->ts.type = BT_INTEGER;
3088 25 : f->ts.kind = gfc_c_int_kind;
3089 25 : if (u->ts.kind != gfc_c_int_kind)
3090 : {
3091 0 : ts.type = BT_INTEGER;
3092 0 : ts.kind = gfc_c_int_kind;
3093 0 : ts.u.derived = NULL;
3094 0 : ts.u.cl = NULL;
3095 0 : gfc_convert_type (u, &ts, 2);
3096 : }
3097 :
3098 25 : f->value.function.name = gfc_get_string (PREFIX ("fputc"));
3099 25 : }
3100 :
3101 :
3102 : void
3103 1 : gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
3104 : {
3105 1 : f->ts.type = BT_INTEGER;
3106 1 : f->ts.kind = gfc_c_int_kind;
3107 1 : f->value.function.name = gfc_get_string (PREFIX ("fput"));
3108 1 : }
3109 :
3110 :
3111 : void
3112 258 : gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
3113 : {
3114 258 : gfc_typespec ts;
3115 258 : gfc_clear_ts (&ts);
3116 :
3117 258 : f->ts.type = BT_INTEGER;
3118 258 : f->ts.kind = gfc_intio_kind;
3119 258 : if (u->ts.kind != gfc_c_int_kind)
3120 : {
3121 0 : ts.type = BT_INTEGER;
3122 0 : ts.kind = gfc_c_int_kind;
3123 0 : ts.u.derived = NULL;
3124 0 : ts.u.cl = NULL;
3125 0 : gfc_convert_type (u, &ts, 2);
3126 : }
3127 :
3128 258 : f->value.function.name = gfc_get_string (PREFIX ("ftell"));
3129 258 : }
3130 :
3131 :
3132 : void
3133 748 : gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
3134 : gfc_expr *kind)
3135 : {
3136 748 : f->ts.type = BT_INTEGER;
3137 748 : if (kind)
3138 390 : f->ts.kind = mpz_get_si (kind->value.integer);
3139 : else
3140 358 : f->ts.kind = gfc_default_integer_kind;
3141 748 : }
3142 :
3143 :
3144 : void
3145 4468 : gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3146 : {
3147 4468 : resolve_transformational ("sum", f, array, dim, mask, true);
3148 4468 : }
3149 :
3150 :
3151 : void
3152 4 : gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
3153 : gfc_expr *p2 ATTRIBUTE_UNUSED)
3154 : {
3155 4 : f->ts.type = BT_INTEGER;
3156 4 : f->ts.kind = gfc_default_integer_kind;
3157 4 : f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
3158 4 : }
3159 :
3160 :
3161 : /* Resolve the g77 compatibility function SYSTEM. */
3162 :
3163 : void
3164 0 : gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3165 : {
3166 0 : f->ts.type = BT_INTEGER;
3167 0 : f->ts.kind = 4;
3168 0 : f->value.function.name = gfc_get_string (PREFIX ("system"));
3169 0 : }
3170 :
3171 :
3172 : void
3173 572 : gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
3174 : {
3175 572 : f->ts = x->ts;
3176 572 : f->value.function.name
3177 572 : = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
3178 : gfc_type_abi_kind (&x->ts));
3179 572 : }
3180 :
3181 :
3182 : void
3183 302 : gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
3184 : {
3185 302 : f->ts = x->ts;
3186 302 : f->value.function.name
3187 302 : = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
3188 : gfc_type_abi_kind (&x->ts));
3189 302 : }
3190 :
3191 :
3192 : /* Resolve failed_images (team, kind). */
3193 :
3194 : void
3195 50 : gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
3196 : gfc_expr *kind)
3197 : {
3198 50 : static char failed_images[] = "_gfortran_caf_failed_images";
3199 50 : f->rank = 1;
3200 50 : f->ts.type = BT_INTEGER;
3201 50 : if (kind == NULL)
3202 26 : f->ts.kind = gfc_default_integer_kind;
3203 : else
3204 24 : gfc_extract_int (kind, &f->ts.kind);
3205 50 : f->value.function.name = failed_images;
3206 50 : }
3207 :
3208 :
3209 : /* Resolve image_status (image, team). */
3210 :
3211 : void
3212 103 : gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
3213 : gfc_expr *team ATTRIBUTE_UNUSED)
3214 : {
3215 103 : static char image_status[] = "_gfortran_caf_image_status";
3216 103 : f->ts.type = BT_INTEGER;
3217 103 : f->ts.kind = gfc_default_integer_kind;
3218 103 : f->value.function.name = image_status;
3219 103 : }
3220 :
3221 :
3222 : /* Resolve get_team (). */
3223 :
3224 : void
3225 25 : gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
3226 : {
3227 25 : static char get_team[] = "_gfortran_caf_get_team";
3228 25 : f->rank = 0;
3229 25 : f->ts.type = BT_DERIVED;
3230 25 : gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived);
3231 25 : if (!f->ts.u.derived
3232 23 : || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV)
3233 : {
3234 2 : gfc_error (
3235 : "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV "
3236 : "to define its result type TEAM_TYPE",
3237 : &f->where);
3238 2 : f->ts.type = BT_UNKNOWN;
3239 : }
3240 25 : f->value.function.name = get_team;
3241 :
3242 : /* No requirements to resolve for level argument now. */
3243 25 : }
3244 :
3245 : /* Resolve image_index (...). */
3246 :
3247 : void
3248 195 : gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
3249 : gfc_expr *sub ATTRIBUTE_UNUSED,
3250 : gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
3251 : {
3252 195 : static char image_index[] = "__image_index";
3253 195 : f->ts.type = BT_INTEGER;
3254 195 : f->ts.kind = gfc_default_integer_kind;
3255 195 : f->value.function.name = image_index;
3256 195 : }
3257 :
3258 :
3259 : /* Resolve stopped_images (team, kind). */
3260 :
3261 : void
3262 50 : gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
3263 : gfc_expr *kind)
3264 : {
3265 50 : static char stopped_images[] = "_gfortran_caf_stopped_images";
3266 50 : f->rank = 1;
3267 50 : f->ts.type = BT_INTEGER;
3268 50 : if (kind == NULL)
3269 26 : f->ts.kind = gfc_default_integer_kind;
3270 : else
3271 24 : gfc_extract_int (kind, &f->ts.kind);
3272 50 : f->value.function.name = stopped_images;
3273 50 : }
3274 :
3275 :
3276 : /* Resolve team_number (team). */
3277 :
3278 : void
3279 71 : gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
3280 : {
3281 71 : static char team_number[] = "_gfortran_caf_team_number";
3282 71 : f->rank = 0;
3283 71 : f->ts.type = BT_INTEGER;
3284 71 : f->ts.kind = gfc_default_integer_kind;
3285 71 : f->value.function.name = team_number;
3286 :
3287 71 : if (team)
3288 0 : gfc_resolve_expr (team);
3289 71 : }
3290 :
3291 : void
3292 2879 : gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim,
3293 : gfc_expr *team)
3294 : {
3295 2879 : static char this_image[] = "__this_image";
3296 2879 : if (coarray && dim)
3297 819 : resolve_bound (f, coarray, dim, NULL, this_image, true);
3298 2060 : else if (coarray)
3299 : {
3300 226 : f->ts.type = BT_INTEGER;
3301 226 : f->ts.kind = gfc_default_integer_kind;
3302 226 : f->value.function.name = this_image;
3303 226 : if (f->shape && f->rank != 1)
3304 0 : gfc_free_shape (&f->shape, f->rank);
3305 226 : f->rank = 1;
3306 226 : f->shape = gfc_get_shape (1);
3307 226 : mpz_init_set_ui (f->shape[0], coarray->corank);
3308 : }
3309 : else
3310 : {
3311 1834 : f->ts.type = BT_INTEGER;
3312 1834 : f->ts.kind = gfc_default_integer_kind;
3313 1834 : f->value.function.name = this_image;
3314 : }
3315 :
3316 2879 : if (team)
3317 22 : gfc_resolve_expr (team);
3318 2879 : }
3319 :
3320 : void
3321 14 : gfc_resolve_time (gfc_expr *f)
3322 : {
3323 14 : f->ts.type = BT_INTEGER;
3324 14 : f->ts.kind = 4;
3325 14 : f->value.function.name = gfc_get_string (PREFIX ("time_func"));
3326 14 : }
3327 :
3328 :
3329 : void
3330 2 : gfc_resolve_time8 (gfc_expr *f)
3331 : {
3332 2 : f->ts.type = BT_INTEGER;
3333 2 : f->ts.kind = 8;
3334 2 : f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
3335 2 : }
3336 :
3337 :
3338 : void
3339 2011 : gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
3340 : gfc_expr *mold, gfc_expr *size)
3341 : {
3342 : /* TODO: Make this do something meaningful. */
3343 2011 : static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3344 :
3345 2011 : if (mold->ts.type == BT_CHARACTER
3346 640 : && !mold->ts.u.cl->length
3347 2206 : && gfc_is_constant_expr (mold))
3348 : {
3349 102 : int len;
3350 102 : if (mold->expr_type == EXPR_CONSTANT)
3351 : {
3352 102 : len = mold->value.character.length;
3353 102 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3354 : NULL, len);
3355 : }
3356 : else
3357 : {
3358 0 : gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3359 0 : len = c->expr->value.character.length;
3360 0 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3361 : NULL, len);
3362 : }
3363 : }
3364 :
3365 2011 : if (UNLIMITED_POLY (mold))
3366 0 : gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3367 : &mold->where);
3368 :
3369 2011 : f->ts = mold->ts;
3370 :
3371 2011 : if (size == NULL && mold->rank == 0)
3372 : {
3373 1246 : f->rank = 0;
3374 1246 : f->value.function.name = transfer0;
3375 : }
3376 : else
3377 : {
3378 765 : f->rank = 1;
3379 765 : f->value.function.name = transfer1;
3380 765 : if (size && gfc_is_constant_expr (size))
3381 : {
3382 114 : f->shape = gfc_get_shape (1);
3383 114 : mpz_init_set (f->shape[0], size->value.integer);
3384 : }
3385 : }
3386 2011 : }
3387 :
3388 :
3389 : void
3390 1580 : gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3391 : {
3392 :
3393 1580 : if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3394 156 : gfc_resolve_substring_charlen (matrix);
3395 :
3396 1580 : f->ts = matrix->ts;
3397 1580 : f->rank = 2;
3398 1580 : if (matrix->shape)
3399 : {
3400 1252 : f->shape = gfc_get_shape (2);
3401 1252 : mpz_init_set (f->shape[0], matrix->shape[1]);
3402 1252 : mpz_init_set (f->shape[1], matrix->shape[0]);
3403 : }
3404 :
3405 1580 : switch (matrix->ts.kind)
3406 : {
3407 1466 : case 4:
3408 1466 : case 8:
3409 1466 : case 10:
3410 1466 : case 16:
3411 1466 : switch (matrix->ts.type)
3412 : {
3413 451 : case BT_REAL:
3414 451 : case BT_COMPLEX:
3415 451 : f->value.function.name
3416 902 : = gfc_get_string (PREFIX ("transpose_%c%d"),
3417 451 : gfc_type_letter (matrix->ts.type),
3418 : gfc_type_abi_kind (&matrix->ts));
3419 451 : break;
3420 :
3421 937 : case BT_INTEGER:
3422 937 : case BT_LOGICAL:
3423 : /* Use the integer routines for real and logical cases. This
3424 : assumes they all have the same alignment requirements. */
3425 937 : f->value.function.name
3426 937 : = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3427 937 : break;
3428 :
3429 78 : default:
3430 78 : if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3431 78 : f->value.function.name = PREFIX ("transpose_char4");
3432 : else
3433 0 : f->value.function.name = PREFIX ("transpose");
3434 : break;
3435 : }
3436 : break;
3437 :
3438 114 : default:
3439 228 : f->value.function.name = (matrix->ts.type == BT_CHARACTER
3440 114 : ? PREFIX ("transpose_char")
3441 : : PREFIX ("transpose"));
3442 114 : break;
3443 : }
3444 1580 : }
3445 :
3446 :
3447 : void
3448 4554 : gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3449 : {
3450 4554 : f->ts.type = BT_CHARACTER;
3451 4554 : f->ts.kind = string->ts.kind;
3452 4554 : f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3453 4554 : }
3454 :
3455 : /* Resolve the trigonometric functions. This amounts to setting
3456 : the function return type-spec from its argument and building a
3457 : library function names of the form _gfortran_sind_r4. */
3458 :
3459 : void
3460 1404 : gfc_resolve_trig (gfc_expr *f, gfc_expr *x)
3461 : {
3462 1404 : f->ts = x->ts;
3463 1404 : f->value.function.name
3464 2808 : = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3465 1404 : gfc_type_letter (x->ts.type),
3466 : gfc_type_abi_kind (&x->ts));
3467 1404 : }
3468 :
3469 : void
3470 240 : gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3471 : {
3472 240 : f->ts = y->ts;
3473 240 : f->value.function.name
3474 240 : = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3475 : x->ts.kind);
3476 240 : }
3477 :
3478 :
3479 : void
3480 13529 : gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3481 : {
3482 13529 : resolve_bound (f, array, dim, kind, "__ubound", false);
3483 13529 : }
3484 :
3485 :
3486 : void
3487 498 : gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3488 : {
3489 498 : resolve_bound (f, array, dim, kind, "__ucobound", true);
3490 498 : }
3491 :
3492 :
3493 : /* Resolve the g77 compatibility function UMASK. */
3494 :
3495 : void
3496 0 : gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3497 : {
3498 0 : f->ts.type = BT_INTEGER;
3499 0 : f->ts.kind = n->ts.kind;
3500 0 : f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3501 0 : }
3502 :
3503 :
3504 : /* Resolve the g77 compatibility function UNLINK. */
3505 :
3506 : void
3507 1 : gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3508 : {
3509 1 : f->ts.type = BT_INTEGER;
3510 1 : f->ts.kind = 4;
3511 1 : f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3512 1 : }
3513 :
3514 :
3515 : void
3516 0 : gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3517 : {
3518 0 : gfc_typespec ts;
3519 0 : gfc_clear_ts (&ts);
3520 :
3521 0 : f->ts.type = BT_CHARACTER;
3522 0 : f->ts.kind = gfc_default_character_kind;
3523 :
3524 0 : if (unit->ts.kind != gfc_c_int_kind)
3525 : {
3526 0 : ts.type = BT_INTEGER;
3527 0 : ts.kind = gfc_c_int_kind;
3528 0 : ts.u.derived = NULL;
3529 0 : ts.u.cl = NULL;
3530 0 : gfc_convert_type (unit, &ts, 2);
3531 : }
3532 :
3533 0 : f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3534 0 : }
3535 :
3536 :
3537 : void
3538 460 : gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3539 : gfc_expr *field ATTRIBUTE_UNUSED)
3540 : {
3541 460 : if (vector->ts.type == BT_CHARACTER && vector->ref)
3542 54 : gfc_resolve_substring_charlen (vector);
3543 :
3544 460 : f->ts = vector->ts;
3545 460 : f->rank = mask->rank;
3546 460 : resolve_mask_arg (mask);
3547 :
3548 460 : if (vector->ts.type == BT_CHARACTER)
3549 : {
3550 54 : if (vector->ts.kind == 1)
3551 30 : f->value.function.name
3552 54 : = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3553 : else
3554 24 : f->value.function.name
3555 24 : = gfc_get_string (PREFIX ("unpack%d_char%d"),
3556 24 : field->rank > 0 ? 1 : 0, vector->ts.kind);
3557 : }
3558 : else
3559 406 : f->value.function.name
3560 499 : = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3561 460 : }
3562 :
3563 :
3564 : void
3565 254 : gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3566 : gfc_expr *set ATTRIBUTE_UNUSED,
3567 : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3568 : {
3569 254 : f->ts.type = BT_INTEGER;
3570 254 : if (kind)
3571 16 : f->ts.kind = mpz_get_si (kind->value.integer);
3572 : else
3573 238 : f->ts.kind = gfc_default_integer_kind;
3574 254 : f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3575 254 : }
3576 :
3577 :
3578 : void
3579 20 : gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3580 : {
3581 20 : f->ts.type = i->ts.type;
3582 20 : f->ts.kind = gfc_kind_max (i, j);
3583 :
3584 20 : if (i->ts.kind != j->ts.kind)
3585 : {
3586 0 : if (i->ts.kind == gfc_kind_max (i, j))
3587 0 : gfc_convert_type (j, &i->ts, 2);
3588 : else
3589 0 : gfc_convert_type (i, &j->ts, 2);
3590 : }
3591 :
3592 20 : f->value.function.name
3593 20 : = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3594 : gfc_type_abi_kind (&f->ts));
3595 20 : }
3596 :
3597 :
3598 : /* Intrinsic subroutine resolution. */
3599 :
3600 : void
3601 0 : gfc_resolve_alarm_sub (gfc_code *c)
3602 : {
3603 0 : const char *name;
3604 0 : gfc_expr *seconds, *handler;
3605 0 : gfc_typespec ts;
3606 0 : gfc_clear_ts (&ts);
3607 :
3608 0 : seconds = c->ext.actual->expr;
3609 0 : handler = c->ext.actual->next->expr;
3610 0 : ts.type = BT_INTEGER;
3611 0 : ts.kind = gfc_c_int_kind;
3612 :
3613 : /* handler can be either BT_INTEGER or BT_PROCEDURE.
3614 : In all cases, the status argument is of default integer kind
3615 : (enforced in check.cc) so that the function suffix is fixed. */
3616 0 : if (handler->ts.type == BT_INTEGER)
3617 : {
3618 0 : if (handler->ts.kind != gfc_c_int_kind)
3619 0 : gfc_convert_type (handler, &ts, 2);
3620 0 : name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3621 : gfc_default_integer_kind);
3622 : }
3623 : else
3624 0 : name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3625 : gfc_default_integer_kind);
3626 :
3627 0 : if (seconds->ts.kind != gfc_c_int_kind)
3628 0 : gfc_convert_type (seconds, &ts, 2);
3629 :
3630 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3631 0 : }
3632 :
3633 : void
3634 21 : gfc_resolve_cpu_time (gfc_code *c)
3635 : {
3636 21 : const char *name;
3637 21 : name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3638 21 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3639 21 : }
3640 :
3641 :
3642 : /* Create a formal arglist based on an actual one and set the INTENTs given. */
3643 :
3644 : static gfc_formal_arglist*
3645 198 : create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3646 : {
3647 198 : gfc_formal_arglist* head;
3648 198 : gfc_formal_arglist* tail;
3649 198 : int i;
3650 :
3651 198 : if (!actual)
3652 : return NULL;
3653 :
3654 198 : head = tail = gfc_get_formal_arglist ();
3655 1188 : for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3656 : {
3657 990 : gfc_symbol* sym;
3658 :
3659 990 : sym = gfc_new_symbol ("dummyarg", NULL);
3660 990 : sym->ts = actual->expr->ts;
3661 :
3662 990 : sym->attr.intent = ints[i];
3663 990 : tail->sym = sym;
3664 :
3665 990 : if (actual->next)
3666 792 : tail->next = gfc_get_formal_arglist ();
3667 : }
3668 :
3669 : return head;
3670 : }
3671 :
3672 :
3673 : void
3674 22 : gfc_resolve_atomic_def (gfc_code *c)
3675 : {
3676 22 : const char *name = "atomic_define";
3677 22 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3678 22 : }
3679 :
3680 :
3681 : void
3682 178 : gfc_resolve_atomic_ref (gfc_code *c)
3683 : {
3684 178 : const char *name = "atomic_ref";
3685 178 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3686 178 : }
3687 :
3688 : void
3689 105 : gfc_resolve_event_query (gfc_code *c)
3690 : {
3691 105 : const char *name = "event_query";
3692 105 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3693 105 : }
3694 :
3695 : void
3696 198 : gfc_resolve_mvbits (gfc_code *c)
3697 : {
3698 198 : static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3699 : INTENT_INOUT, INTENT_IN};
3700 198 : const char *name;
3701 :
3702 : /* TO and FROM are guaranteed to have the same kind parameter. */
3703 396 : name = gfc_get_string (PREFIX ("mvbits_i%d"),
3704 198 : c->ext.actual->expr->ts.kind);
3705 198 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3706 : /* Mark as elemental subroutine as this does not happen automatically. */
3707 198 : c->resolved_sym->attr.elemental = 1;
3708 :
3709 : /* Create a dummy formal arglist so the INTENTs are known later for purpose
3710 : of creating temporaries. */
3711 198 : c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3712 198 : }
3713 :
3714 :
3715 : /* Set up the call to RANDOM_INIT. */
3716 :
3717 : void
3718 90 : gfc_resolve_random_init (gfc_code *c)
3719 : {
3720 90 : const char *name;
3721 90 : name = gfc_get_string (PREFIX ("random_init"));
3722 90 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3723 90 : }
3724 :
3725 :
3726 : void
3727 530 : gfc_resolve_random_number (gfc_code *c)
3728 : {
3729 530 : const char *name;
3730 530 : int kind;
3731 530 : char type;
3732 :
3733 530 : kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3734 530 : type = gfc_type_letter (c->ext.actual->expr->ts.type);
3735 530 : if (c->ext.actual->expr->rank == 0)
3736 105 : name = gfc_get_string (PREFIX ("random_%c%d"), type, kind);
3737 : else
3738 425 : name = gfc_get_string (PREFIX ("arandom_%c%d"), type, kind);
3739 :
3740 530 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3741 530 : }
3742 :
3743 :
3744 : void
3745 303 : gfc_resolve_random_seed (gfc_code *c)
3746 : {
3747 303 : const char *name;
3748 :
3749 303 : name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3750 303 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3751 303 : }
3752 :
3753 :
3754 : void
3755 9 : gfc_resolve_rename_sub (gfc_code *c)
3756 : {
3757 9 : const char *name;
3758 9 : int kind;
3759 :
3760 : /* Find the type of status. If not present use default integer kind. */
3761 9 : if (c->ext.actual->next->next->expr != NULL)
3762 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3763 : else
3764 2 : kind = gfc_default_integer_kind;
3765 :
3766 9 : name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3767 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3768 9 : }
3769 :
3770 :
3771 : void
3772 9 : gfc_resolve_link_sub (gfc_code *c)
3773 : {
3774 9 : const char *name;
3775 9 : int kind;
3776 :
3777 9 : if (c->ext.actual->next->next->expr != NULL)
3778 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3779 : else
3780 2 : kind = gfc_default_integer_kind;
3781 :
3782 9 : name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3783 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3784 9 : }
3785 :
3786 :
3787 : void
3788 9 : gfc_resolve_symlnk_sub (gfc_code *c)
3789 : {
3790 9 : const char *name;
3791 9 : int kind;
3792 :
3793 9 : if (c->ext.actual->next->next->expr != NULL)
3794 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3795 : else
3796 2 : kind = gfc_default_integer_kind;
3797 :
3798 9 : name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3799 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3800 9 : }
3801 :
3802 :
3803 : /* G77 compatibility subroutines dtime() and etime(). */
3804 :
3805 : void
3806 0 : gfc_resolve_dtime_sub (gfc_code *c)
3807 : {
3808 0 : const char *name;
3809 0 : name = gfc_get_string (PREFIX ("dtime_sub"));
3810 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3811 0 : }
3812 :
3813 : void
3814 1 : gfc_resolve_etime_sub (gfc_code *c)
3815 : {
3816 1 : const char *name;
3817 1 : name = gfc_get_string (PREFIX ("etime_sub"));
3818 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3819 1 : }
3820 :
3821 :
3822 : /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3823 :
3824 : void
3825 12 : gfc_resolve_itime (gfc_code *c)
3826 : {
3827 12 : c->resolved_sym
3828 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3829 : gfc_default_integer_kind));
3830 12 : }
3831 :
3832 : void
3833 12 : gfc_resolve_idate (gfc_code *c)
3834 : {
3835 12 : c->resolved_sym
3836 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3837 : gfc_default_integer_kind));
3838 12 : }
3839 :
3840 : void
3841 12 : gfc_resolve_ltime (gfc_code *c)
3842 : {
3843 12 : c->resolved_sym
3844 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3845 : gfc_default_integer_kind));
3846 12 : }
3847 :
3848 : void
3849 12 : gfc_resolve_gmtime (gfc_code *c)
3850 : {
3851 12 : c->resolved_sym
3852 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3853 : gfc_default_integer_kind));
3854 12 : }
3855 :
3856 :
3857 : /* G77 compatibility subroutine second(). */
3858 :
3859 : void
3860 0 : gfc_resolve_second_sub (gfc_code *c)
3861 : {
3862 0 : const char *name;
3863 0 : name = gfc_get_string (PREFIX ("second_sub"));
3864 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3865 0 : }
3866 :
3867 :
3868 : void
3869 28 : gfc_resolve_sleep_sub (gfc_code *c)
3870 : {
3871 28 : const char *name;
3872 28 : int kind;
3873 :
3874 28 : if (c->ext.actual->expr != NULL)
3875 28 : kind = c->ext.actual->expr->ts.kind;
3876 : else
3877 0 : kind = gfc_default_integer_kind;
3878 :
3879 28 : name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3880 28 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3881 28 : }
3882 :
3883 : void
3884 102 : gfc_resolve_split (gfc_code *c)
3885 : {
3886 102 : const char *name;
3887 102 : gfc_expr *string;
3888 :
3889 102 : string = c->ext.actual->expr;
3890 102 : if (string->ts.type == BT_CHARACTER && string->ts.kind == 4)
3891 : name = "__split_char4";
3892 : else
3893 66 : name = "__split";
3894 102 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3895 102 : }
3896 :
3897 : /* G77 compatibility function srand(). */
3898 :
3899 : void
3900 0 : gfc_resolve_srand (gfc_code *c)
3901 : {
3902 0 : const char *name;
3903 0 : name = gfc_get_string (PREFIX ("srand"));
3904 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3905 0 : }
3906 :
3907 :
3908 : /* Resolve the getarg intrinsic subroutine. */
3909 :
3910 : void
3911 55 : gfc_resolve_getarg (gfc_code *c)
3912 : {
3913 55 : const char *name;
3914 :
3915 55 : if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3916 : {
3917 9 : gfc_typespec ts;
3918 9 : gfc_clear_ts (&ts);
3919 :
3920 9 : ts.type = BT_INTEGER;
3921 9 : ts.kind = gfc_default_integer_kind;
3922 :
3923 9 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3924 : }
3925 :
3926 55 : name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3927 55 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3928 55 : }
3929 :
3930 :
3931 : /* Resolve the getcwd intrinsic subroutine. */
3932 :
3933 : void
3934 8 : gfc_resolve_getcwd_sub (gfc_code *c)
3935 : {
3936 8 : const char *name;
3937 8 : int kind;
3938 :
3939 8 : if (c->ext.actual->next->expr != NULL)
3940 1 : kind = c->ext.actual->next->expr->ts.kind;
3941 : else
3942 7 : kind = gfc_default_integer_kind;
3943 :
3944 8 : name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3945 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3946 8 : }
3947 :
3948 :
3949 : /* Resolve the get_command intrinsic subroutine. */
3950 :
3951 : void
3952 3 : gfc_resolve_get_command (gfc_code *c)
3953 : {
3954 3 : const char *name;
3955 3 : int kind;
3956 3 : kind = gfc_default_integer_kind;
3957 3 : name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3958 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3959 3 : }
3960 :
3961 :
3962 : /* Resolve the get_command_argument intrinsic subroutine. */
3963 :
3964 : void
3965 4 : gfc_resolve_get_command_argument (gfc_code *c)
3966 : {
3967 4 : const char *name;
3968 4 : int kind;
3969 4 : kind = gfc_default_integer_kind;
3970 4 : name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3971 4 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3972 4 : }
3973 :
3974 :
3975 : /* Resolve the get_environment_variable intrinsic subroutine. */
3976 :
3977 : void
3978 26 : gfc_resolve_get_environment_variable (gfc_code *code)
3979 : {
3980 26 : const char *name;
3981 26 : int kind;
3982 26 : kind = gfc_default_integer_kind;
3983 26 : name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3984 26 : code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3985 26 : }
3986 :
3987 :
3988 : void
3989 0 : gfc_resolve_signal_sub (gfc_code *c)
3990 : {
3991 0 : const char *name;
3992 0 : gfc_expr *number, *handler, *status;
3993 0 : gfc_typespec ts;
3994 0 : gfc_clear_ts (&ts);
3995 :
3996 0 : number = c->ext.actual->expr;
3997 0 : handler = c->ext.actual->next->expr;
3998 0 : status = c->ext.actual->next->next->expr;
3999 0 : ts.type = BT_INTEGER;
4000 0 : ts.kind = gfc_c_int_kind;
4001 :
4002 : /* handler can be either BT_INTEGER or BT_PROCEDURE */
4003 0 : if (handler->ts.type == BT_INTEGER)
4004 : {
4005 0 : if (handler->ts.kind != gfc_c_int_kind)
4006 0 : gfc_convert_type (handler, &ts, 2);
4007 0 : name = gfc_get_string (PREFIX ("signal_sub_int"));
4008 : }
4009 : else
4010 0 : name = gfc_get_string (PREFIX ("signal_sub"));
4011 :
4012 0 : if (number->ts.kind != gfc_c_int_kind)
4013 0 : gfc_convert_type (number, &ts, 2);
4014 0 : if (status != NULL && status->ts.kind != gfc_c_int_kind)
4015 0 : gfc_convert_type (status, &ts, 2);
4016 :
4017 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4018 0 : }
4019 :
4020 :
4021 : /* Resolve the SYSTEM intrinsic subroutine. */
4022 :
4023 : void
4024 2 : gfc_resolve_system_sub (gfc_code *c)
4025 : {
4026 2 : const char *name;
4027 2 : name = gfc_get_string (PREFIX ("system_sub"));
4028 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4029 2 : }
4030 :
4031 :
4032 : /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
4033 :
4034 : void
4035 197 : gfc_resolve_system_clock (gfc_code *c)
4036 : {
4037 197 : const char *name;
4038 197 : int kind;
4039 197 : gfc_expr *count = c->ext.actual->expr;
4040 197 : gfc_expr *count_max = c->ext.actual->next->next->expr;
4041 :
4042 : /* The INTEGER(8) version has higher precision, it is used if both COUNT
4043 : and COUNT_MAX can hold 64-bit values, or are absent. */
4044 197 : if ((!count || count->ts.kind >= 8)
4045 74 : && (!count_max || count_max->ts.kind >= 8))
4046 : kind = 8;
4047 : else
4048 159 : kind = gfc_default_integer_kind;
4049 :
4050 197 : name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
4051 197 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4052 197 : }
4053 :
4054 :
4055 : /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
4056 : void
4057 20 : gfc_resolve_execute_command_line (gfc_code *c)
4058 : {
4059 20 : const char *name;
4060 20 : name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
4061 : gfc_default_integer_kind);
4062 20 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4063 20 : }
4064 :
4065 :
4066 : /* Resolve the EXIT intrinsic subroutine. */
4067 :
4068 : void
4069 3 : gfc_resolve_exit (gfc_code *c)
4070 : {
4071 3 : const char *name;
4072 3 : gfc_typespec ts;
4073 3 : gfc_expr *n;
4074 3 : gfc_clear_ts (&ts);
4075 :
4076 : /* The STATUS argument has to be of default kind. If it is not,
4077 : we convert it. */
4078 3 : ts.type = BT_INTEGER;
4079 3 : ts.kind = gfc_default_integer_kind;
4080 3 : n = c->ext.actual->expr;
4081 3 : if (n != NULL && n->ts.kind != ts.kind)
4082 0 : gfc_convert_type (n, &ts, 2);
4083 :
4084 3 : name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
4085 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4086 3 : }
4087 :
4088 :
4089 : /* Resolve the FLUSH intrinsic subroutine. */
4090 :
4091 : void
4092 25 : gfc_resolve_flush (gfc_code *c)
4093 : {
4094 25 : const char *name;
4095 25 : gfc_typespec ts;
4096 25 : gfc_expr *n;
4097 25 : gfc_clear_ts (&ts);
4098 :
4099 25 : ts.type = BT_INTEGER;
4100 25 : ts.kind = gfc_default_integer_kind;
4101 25 : n = c->ext.actual->expr;
4102 25 : if (n != NULL && n->ts.kind != ts.kind)
4103 0 : gfc_convert_type (n, &ts, 2);
4104 :
4105 25 : name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
4106 25 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4107 25 : }
4108 :
4109 :
4110 : void
4111 1 : gfc_resolve_ctime_sub (gfc_code *c)
4112 : {
4113 1 : gfc_typespec ts;
4114 1 : gfc_clear_ts (&ts);
4115 :
4116 : /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
4117 1 : if (c->ext.actual->expr->ts.kind != 8)
4118 : {
4119 0 : ts.type = BT_INTEGER;
4120 0 : ts.kind = 8;
4121 0 : ts.u.derived = NULL;
4122 0 : ts.u.cl = NULL;
4123 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4124 : }
4125 :
4126 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
4127 1 : }
4128 :
4129 :
4130 : void
4131 1 : gfc_resolve_fdate_sub (gfc_code *c)
4132 : {
4133 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
4134 1 : }
4135 :
4136 :
4137 : void
4138 2 : gfc_resolve_gerror (gfc_code *c)
4139 : {
4140 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
4141 2 : }
4142 :
4143 :
4144 : void
4145 2 : gfc_resolve_getlog (gfc_code *c)
4146 : {
4147 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
4148 2 : }
4149 :
4150 :
4151 : void
4152 9 : gfc_resolve_hostnm_sub (gfc_code *c)
4153 : {
4154 9 : const char *name;
4155 9 : int kind;
4156 :
4157 9 : if (c->ext.actual->next->expr != NULL)
4158 7 : kind = c->ext.actual->next->expr->ts.kind;
4159 : else
4160 2 : kind = gfc_default_integer_kind;
4161 :
4162 9 : name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
4163 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4164 9 : }
4165 :
4166 :
4167 : void
4168 2 : gfc_resolve_perror (gfc_code *c)
4169 : {
4170 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
4171 2 : }
4172 :
4173 : /* Resolve the STAT and FSTAT intrinsic subroutines. */
4174 :
4175 : void
4176 24 : gfc_resolve_stat_sub (gfc_code *c)
4177 : {
4178 24 : const char *name;
4179 24 : gfc_typespec *ts;
4180 24 : ts = &c->ext.actual->next->expr->ts;
4181 24 : name = gfc_get_string (PREFIX ("stat_i%d_sub"), ts->kind);
4182 24 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4183 24 : }
4184 :
4185 :
4186 : void
4187 18 : gfc_resolve_lstat_sub (gfc_code *c)
4188 : {
4189 18 : const char *name;
4190 18 : gfc_typespec *ts;
4191 18 : ts = &c->ext.actual->next->expr->ts;
4192 18 : name = gfc_get_string (PREFIX ("lstat_i%d_sub"), ts->kind);
4193 18 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4194 18 : }
4195 :
4196 :
4197 : void
4198 23 : gfc_resolve_fstat_sub (gfc_code *c)
4199 : {
4200 23 : const char *name;
4201 23 : gfc_expr *u;
4202 23 : gfc_typespec *ts;
4203 :
4204 23 : u = c->ext.actual->expr;
4205 23 : ts = &c->ext.actual->next->expr->ts;
4206 23 : if (u->ts.kind != ts->kind)
4207 10 : gfc_convert_type (u, ts, 2);
4208 23 : name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
4209 23 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4210 23 : }
4211 :
4212 :
4213 : void
4214 44 : gfc_resolve_fgetc_sub (gfc_code *c)
4215 : {
4216 44 : const char *name;
4217 44 : gfc_typespec ts;
4218 44 : gfc_expr *u, *st;
4219 44 : gfc_clear_ts (&ts);
4220 :
4221 44 : u = c->ext.actual->expr;
4222 44 : st = c->ext.actual->next->next->expr;
4223 :
4224 44 : if (u->ts.kind != gfc_c_int_kind)
4225 : {
4226 0 : ts.type = BT_INTEGER;
4227 0 : ts.kind = gfc_c_int_kind;
4228 0 : ts.u.derived = NULL;
4229 0 : ts.u.cl = NULL;
4230 0 : gfc_convert_type (u, &ts, 2);
4231 : }
4232 :
4233 44 : if (st != NULL)
4234 31 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
4235 : else
4236 13 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
4237 :
4238 44 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4239 44 : }
4240 :
4241 :
4242 : void
4243 2 : gfc_resolve_fget_sub (gfc_code *c)
4244 : {
4245 2 : const char *name;
4246 2 : gfc_expr *st;
4247 :
4248 2 : st = c->ext.actual->next->expr;
4249 2 : if (st != NULL)
4250 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
4251 : else
4252 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
4253 :
4254 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4255 2 : }
4256 :
4257 :
4258 : void
4259 33 : gfc_resolve_fputc_sub (gfc_code *c)
4260 : {
4261 33 : const char *name;
4262 33 : gfc_typespec ts;
4263 33 : gfc_expr *u, *st;
4264 33 : gfc_clear_ts (&ts);
4265 :
4266 33 : u = c->ext.actual->expr;
4267 33 : st = c->ext.actual->next->next->expr;
4268 :
4269 33 : if (u->ts.kind != gfc_c_int_kind)
4270 : {
4271 0 : ts.type = BT_INTEGER;
4272 0 : ts.kind = gfc_c_int_kind;
4273 0 : ts.u.derived = NULL;
4274 0 : ts.u.cl = NULL;
4275 0 : gfc_convert_type (u, &ts, 2);
4276 : }
4277 :
4278 33 : if (st != NULL)
4279 25 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
4280 : else
4281 8 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
4282 :
4283 33 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4284 33 : }
4285 :
4286 :
4287 : void
4288 2 : gfc_resolve_fput_sub (gfc_code *c)
4289 : {
4290 2 : const char *name;
4291 2 : gfc_expr *st;
4292 :
4293 2 : st = c->ext.actual->next->expr;
4294 2 : if (st != NULL)
4295 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
4296 : else
4297 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
4298 :
4299 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4300 2 : }
4301 :
4302 :
4303 : void
4304 60 : gfc_resolve_fseek_sub (gfc_code *c)
4305 : {
4306 60 : gfc_expr *unit;
4307 60 : gfc_expr *offset;
4308 60 : gfc_expr *whence;
4309 60 : gfc_typespec ts;
4310 60 : gfc_clear_ts (&ts);
4311 :
4312 60 : unit = c->ext.actual->expr;
4313 60 : offset = c->ext.actual->next->expr;
4314 60 : whence = c->ext.actual->next->next->expr;
4315 :
4316 60 : if (unit->ts.kind != gfc_c_int_kind)
4317 : {
4318 0 : ts.type = BT_INTEGER;
4319 0 : ts.kind = gfc_c_int_kind;
4320 0 : ts.u.derived = NULL;
4321 0 : ts.u.cl = NULL;
4322 0 : gfc_convert_type (unit, &ts, 2);
4323 : }
4324 :
4325 60 : if (offset->ts.kind != gfc_intio_kind)
4326 : {
4327 60 : ts.type = BT_INTEGER;
4328 60 : ts.kind = gfc_intio_kind;
4329 60 : ts.u.derived = NULL;
4330 60 : ts.u.cl = NULL;
4331 60 : gfc_convert_type (offset, &ts, 2);
4332 : }
4333 :
4334 60 : if (whence->ts.kind != gfc_c_int_kind)
4335 : {
4336 0 : ts.type = BT_INTEGER;
4337 0 : ts.kind = gfc_c_int_kind;
4338 0 : ts.u.derived = NULL;
4339 0 : ts.u.cl = NULL;
4340 0 : gfc_convert_type (whence, &ts, 2);
4341 : }
4342 :
4343 60 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4344 60 : }
4345 :
4346 : void
4347 36 : gfc_resolve_ftell_sub (gfc_code *c)
4348 : {
4349 36 : const char *name;
4350 36 : gfc_expr *unit;
4351 36 : gfc_expr *offset;
4352 36 : gfc_typespec ts;
4353 36 : gfc_clear_ts (&ts);
4354 :
4355 36 : unit = c->ext.actual->expr;
4356 36 : offset = c->ext.actual->next->expr;
4357 :
4358 36 : if (unit->ts.kind != gfc_c_int_kind)
4359 : {
4360 0 : ts.type = BT_INTEGER;
4361 0 : ts.kind = gfc_c_int_kind;
4362 0 : ts.u.derived = NULL;
4363 0 : ts.u.cl = NULL;
4364 0 : gfc_convert_type (unit, &ts, 2);
4365 : }
4366 :
4367 36 : name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4368 36 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4369 36 : }
4370 :
4371 :
4372 : void
4373 1 : gfc_resolve_ttynam_sub (gfc_code *c)
4374 : {
4375 1 : gfc_typespec ts;
4376 1 : gfc_clear_ts (&ts);
4377 :
4378 1 : if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4379 : {
4380 0 : ts.type = BT_INTEGER;
4381 0 : ts.kind = gfc_c_int_kind;
4382 0 : ts.u.derived = NULL;
4383 0 : ts.u.cl = NULL;
4384 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4385 : }
4386 :
4387 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4388 1 : }
4389 :
4390 :
4391 : /* Resolve the UMASK intrinsic subroutine. */
4392 :
4393 : void
4394 0 : gfc_resolve_umask_sub (gfc_code *c)
4395 : {
4396 0 : const char *name;
4397 0 : int kind;
4398 :
4399 0 : if (c->ext.actual->next->expr != NULL)
4400 0 : kind = c->ext.actual->next->expr->ts.kind;
4401 : else
4402 0 : kind = gfc_default_integer_kind;
4403 :
4404 0 : name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4405 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4406 0 : }
4407 :
4408 : /* Resolve the UNLINK intrinsic subroutine. */
4409 :
4410 : void
4411 10 : gfc_resolve_unlink_sub (gfc_code *c)
4412 : {
4413 10 : const char *name;
4414 10 : int kind;
4415 :
4416 10 : if (c->ext.actual->next->expr != NULL)
4417 1 : kind = c->ext.actual->next->expr->ts.kind;
4418 : else
4419 9 : kind = gfc_default_integer_kind;
4420 :
4421 10 : name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4422 10 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4423 10 : }
|
