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