Branch data Line data Source code
1 : : /* Intrinsic function resolution.
2 : : Copyright (C) 2000-2024 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 : 62567350 : gfc_get_string (const char *format, ...)
49 : : {
50 : : /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 : 62567350 : char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 : 62567350 : const char *str;
53 : 62567350 : va_list ap;
54 : 62567350 : tree ident;
55 : :
56 : : /* Handle common case without vsnprintf and temporary buffer. */
57 : 62567350 : if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 : : {
59 : 54112087 : va_start (ap, format);
60 : 54112087 : str = va_arg (ap, const char *);
61 : 54112087 : va_end (ap);
62 : : }
63 : : else
64 : : {
65 : 8455263 : int ret;
66 : 8455263 : va_start (ap, format);
67 : 8455263 : ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 : 8455263 : va_end (ap);
69 : 8455263 : if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 : 0 : gfc_internal_error ("identifier overflow: %d", ret);
71 : 8455263 : temp_name[sizeof (temp_name) - 1] = 0;
72 : 8455263 : str = temp_name;
73 : : }
74 : :
75 : 62567350 : ident = get_identifier (str);
76 : 62567350 : 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 : 1389 : check_charlen_present (gfc_expr *source)
83 : : {
84 : 1389 : if (source->ts.u.cl == NULL)
85 : 0 : source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
86 : :
87 : 1389 : if (source->expr_type == EXPR_CONSTANT)
88 : : {
89 : 92 : source->ts.u.cl->length
90 : 92 : = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
91 : : source->value.character.length);
92 : 92 : source->rank = 0;
93 : : }
94 : 1297 : 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 : 1389 : }
105 : :
106 : : /* Helper function for resolving the "mask" argument. */
107 : :
108 : : static void
109 : 16550 : resolve_mask_arg (gfc_expr *mask)
110 : : {
111 : :
112 : 16550 : gfc_typespec ts;
113 : 16550 : gfc_clear_ts (&ts);
114 : :
115 : 16550 : 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 : 11117 : if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
134 : : {
135 : 904 : ts.type = BT_LOGICAL;
136 : 904 : ts.kind = 1;
137 : 904 : gfc_convert_type_warn (mask, &ts, 2, 0);
138 : : }
139 : : }
140 : 16550 : }
141 : :
142 : :
143 : : static void
144 : 30197 : resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145 : : const char *name, bool coarray)
146 : : {
147 : 30197 : f->ts.type = BT_INTEGER;
148 : 30197 : if (kind)
149 : 4112 : f->ts.kind = mpz_get_si (kind->value.integer);
150 : : else
151 : 26085 : f->ts.kind = gfc_default_integer_kind;
152 : :
153 : 30197 : if (dim == NULL)
154 : : {
155 : 6350 : 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 : 4818 : if (!f->shape || f->rank != 1)
160 : : {
161 : 2510 : if (f->shape)
162 : 0 : gfc_free_shape (&f->shape, f->rank);
163 : 2510 : f->shape = gfc_get_shape (1);
164 : : }
165 : 4818 : 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 : 6350 : f->rank = 1;
169 : 6350 : f->corank = 0;
170 : : }
171 : :
172 : 30197 : f->value.function.name = gfc_get_string ("%s", name);
173 : 30197 : }
174 : :
175 : :
176 : : static void
177 : 5864 : 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 : 5864 : const char *prefix;
182 : 5864 : bt type;
183 : :
184 : 5864 : f->ts = array->ts;
185 : :
186 : 5864 : 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 : 5864 : if (dim != NULL)
199 : : {
200 : 2325 : f->rank = array->rank - 1;
201 : 2325 : f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
202 : 2325 : 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 : 5864 : if (use_integer && array->ts.type == BT_UNSIGNED)
210 : : type = BT_INTEGER;
211 : : else
212 : 5756 : type = array->ts.type;
213 : :
214 : 5864 : f->value.function.name
215 : 11728 : = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
216 : 5864 : gfc_type_letter (type),
217 : : gfc_type_abi_kind (&array->ts));
218 : 5864 : }
219 : :
220 : :
221 : : /********************** Resolution functions **********************/
222 : :
223 : :
224 : : void
225 : 23871 : gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
226 : : {
227 : 23871 : f->ts = a->ts;
228 : 23871 : if (f->ts.type == BT_COMPLEX)
229 : 2994 : f->ts.type = BT_REAL;
230 : :
231 : 23871 : f->value.function.name
232 : 23871 : = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
233 : : gfc_type_abi_kind (&a->ts));
234 : 23871 : }
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 : 1133 : gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
249 : : {
250 : 1133 : f->ts.type = BT_CHARACTER;
251 : 1133 : f->ts.kind = string->ts.kind;
252 : 1133 : if (string->ts.deferred)
253 : 60 : f->ts = string->ts;
254 : 1073 : else if (string->ts.u.cl)
255 : 1073 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
256 : :
257 : 1133 : f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
258 : 1133 : }
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 : 7178 : gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
277 : : bool is_achar)
278 : : {
279 : 7178 : f->ts.type = BT_CHARACTER;
280 : 7178 : f->ts.kind = (kind == NULL)
281 : 710 : ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
282 : 7178 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
283 : 7178 : f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
284 : :
285 : 7178 : f->value.function.name
286 : 16162 : = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
287 : 7178 : gfc_type_letter (x->ts.type),
288 : : gfc_type_abi_kind (&x->ts));
289 : 7178 : }
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 : 1620 : gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
321 : : {
322 : 1620 : f->ts.type = BT_REAL;
323 : 1620 : f->ts.kind = x->ts.kind;
324 : 1620 : f->value.function.name
325 : 1620 : = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
326 : : gfc_type_abi_kind (&x->ts));
327 : 1620 : }
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 : 1200 : gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
382 : : {
383 : 1200 : f->ts = mask->ts;
384 : :
385 : 1200 : 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 : 1200 : f->value.function.name
393 : 1200 : = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
394 : : gfc_type_abi_kind (&mask->ts));
395 : 1200 : }
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 : 37184 : gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
431 : : {
432 : 37184 : f->ts = mask->ts;
433 : :
434 : 37184 : 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 : 37184 : f->value.function.name
442 : 37184 : = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
443 : : gfc_type_abi_kind (&mask->ts));
444 : 37184 : }
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 : 544 : gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
467 : : {
468 : 544 : f->ts = x->ts;
469 : 544 : f->value.function.name
470 : 544 : = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type),
471 : : gfc_type_abi_kind (&x->ts));
472 : 544 : }
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 : 5821 : gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
563 : : {
564 : 5821 : f->ts = f->value.function.isym->ts;
565 : 5821 : }
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 : 1806 : gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
590 : : {
591 : 1806 : gfc_resolve_char_achar (f, a, kind, false);
592 : 1806 : }
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 : 1750 : gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
648 : : {
649 : 1750 : f->ts.type = BT_COMPLEX;
650 : 1750 : f->ts.kind = (kind == NULL)
651 : 1313 : ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
652 : :
653 : 1750 : 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 : 1572 : f->value.function.name
660 : 4716 : = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
661 : 1572 : gfc_type_letter (x->ts.type),
662 : : gfc_type_abi_kind (&x->ts),
663 : 1572 : gfc_type_letter (y->ts.type),
664 : : gfc_type_abi_kind (&y->ts));
665 : 1750 : }
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 : 860 : gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
717 : : {
718 : 860 : f->ts = x->ts;
719 : 860 : f->value.function.name
720 : 860 : = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type),
721 : : gfc_type_abi_kind (&x->ts));
722 : 860 : }
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 : 385 : gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
737 : : {
738 : 385 : f->ts.type = BT_INTEGER;
739 : 385 : if (kind)
740 : 5 : f->ts.kind = mpz_get_si (kind->value.integer);
741 : : else
742 : 380 : f->ts.kind = gfc_default_integer_kind;
743 : :
744 : 385 : 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 : 385 : resolve_mask_arg (mask);
752 : :
753 : 385 : f->value.function.name
754 : 385 : = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts),
755 : 385 : gfc_type_letter (mask->ts.type));
756 : 385 : }
757 : :
758 : :
759 : : void
760 : 889 : gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
761 : : gfc_expr *dim)
762 : : {
763 : 889 : int n, m;
764 : :
765 : 889 : if (array->ts.type == BT_CHARACTER && array->ref)
766 : 426 : gfc_resolve_substring_charlen (array);
767 : :
768 : 889 : f->ts = array->ts;
769 : 889 : f->rank = array->rank;
770 : 889 : f->corank = array->corank;
771 : 889 : f->shape = gfc_copy_shape (array->shape, array->rank);
772 : :
773 : 889 : 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 : 889 : m = gfc_default_integer_kind;
780 : 889 : if (dim != NULL)
781 : 320 : 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 : 889 : if (shift->ts.kind < m)
786 : : {
787 : 68 : gfc_typespec ts;
788 : 68 : gfc_clear_ts (&ts);
789 : 68 : ts.type = BT_INTEGER;
790 : 68 : ts.kind = m;
791 : 68 : gfc_convert_type_warn (shift, &ts, 2, 0);
792 : : }
793 : :
794 : 889 : if (dim != NULL)
795 : : {
796 : 320 : 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 : 302 : gfc_resolve_dim_arg (dim);
805 : : /* Convert dim to shift's kind to reduce variations. */
806 : 302 : if (dim->ts.kind != shift->ts.kind)
807 : 278 : gfc_convert_type_warn (dim, &shift->ts, 2, 0);
808 : : }
809 : : }
810 : :
811 : 889 : if (array->ts.type == BT_CHARACTER)
812 : : {
813 : 426 : if (array->ts.kind == gfc_default_character_kind)
814 : 264 : f->value.function.name
815 : 264 : = 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 : 889 : }
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 : 294 : gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
863 : : {
864 : 294 : f->ts.type = a->ts.type;
865 : 294 : if (p != NULL)
866 : 246 : f->ts.kind = gfc_kind_max (a,p);
867 : : else
868 : 48 : f->ts.kind = a->ts.kind;
869 : :
870 : 294 : 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 : 294 : f->value.function.name
879 : 294 : = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type),
880 : : gfc_type_abi_kind (&f->ts));
881 : 294 : }
882 : :
883 : :
884 : : void
885 : 176 : gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
886 : : {
887 : 176 : gfc_expr temp;
888 : :
889 : 176 : temp.expr_type = EXPR_OP;
890 : 176 : gfc_clear_ts (&temp.ts);
891 : 176 : temp.value.op.op = INTRINSIC_NONE;
892 : 176 : temp.value.op.op1 = a;
893 : 176 : temp.value.op.op2 = b;
894 : 176 : gfc_type_convert_binary (&temp, 1);
895 : 176 : f->ts = temp.ts;
896 : 176 : f->value.function.name
897 : 352 : = gfc_get_string (PREFIX ("dot_product_%c%d"),
898 : 176 : gfc_type_letter (f->ts.type),
899 : : gfc_type_abi_kind (&f->ts));
900 : 176 : }
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 : 1508 : gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
932 : : gfc_expr *boundary, gfc_expr *dim)
933 : : {
934 : 1508 : int n, m;
935 : :
936 : 1508 : if (array->ts.type == BT_CHARACTER && array->ref)
937 : 759 : gfc_resolve_substring_charlen (array);
938 : :
939 : 1508 : f->ts = array->ts;
940 : 1508 : f->rank = array->rank;
941 : 1508 : f->corank = array->corank;
942 : 1508 : f->shape = gfc_copy_shape (array->shape, array->rank);
943 : :
944 : 1508 : n = 0;
945 : 1508 : if (shift->rank > 0)
946 : 489 : n = n | 1;
947 : 1508 : 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 : 1508 : m = gfc_default_integer_kind;
952 : 1508 : if (dim != NULL)
953 : 813 : 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 : 1508 : 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 : 1508 : if (dim != NULL)
967 : : {
968 : 813 : 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 : 777 : gfc_resolve_dim_arg (dim);
977 : : /* Convert dim to shift's kind to reduce variations. */
978 : 777 : if (dim->ts.kind != shift->ts.kind)
979 : 717 : gfc_convert_type_warn (dim, &shift->ts, 2, 0);
980 : : }
981 : : }
982 : :
983 : 1508 : 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 : 749 : f->value.function.name
995 : 749 : = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
996 : 1508 : }
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 : 1590 : 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 : 1590 : 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 : 1590 : f->ts = i->ts;
1218 : 1590 : const char *name = i->ts.kind == BT_UNSIGNED ? "__iand_m_%d" : "__iand_%d";
1219 : 1590 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1220 : 1590 : }
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 : 1596 : gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1272 : : {
1273 : 1596 : f->ts.type = BT_INTEGER;
1274 : 1596 : if (kind)
1275 : 8 : f->ts.kind = mpz_get_si (kind->value.integer);
1276 : : else
1277 : 1588 : f->ts.kind = gfc_default_integer_kind;
1278 : 1596 : f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1279 : 1596 : }
1280 : :
1281 : :
1282 : : void
1283 : 100 : gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1284 : : {
1285 : 100 : gfc_resolve_nint (f, a, NULL);
1286 : 100 : }
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 : 1767 : 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 : 1767 : 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 : 1767 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ieor_m_%d" : "__ieor_%d";
1314 : 1767 : f->ts = i->ts;
1315 : 1767 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1316 : 1767 : }
1317 : :
1318 : :
1319 : : void
1320 : 1299 : 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 : 1299 : 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 : 1299 : const char *name = i->ts.kind == BT_UNSIGNED ? "__ior_m_%d" : "__ior_%d";
1335 : 1299 : f->ts = i->ts;
1336 : 1299 : f->value.function.name = gfc_get_string (name, i->ts.kind);
1337 : 1299 : }
1338 : :
1339 : :
1340 : : void
1341 : 1064 : 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 : 1064 : gfc_typespec ts;
1346 : 1064 : gfc_clear_ts (&ts);
1347 : :
1348 : 1064 : f->ts.type = BT_INTEGER;
1349 : 1064 : if (kind)
1350 : 268 : f->ts.kind = mpz_get_si (kind->value.integer);
1351 : : else
1352 : 796 : f->ts.kind = gfc_default_integer_kind;
1353 : :
1354 : 1064 : 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 : 1064 : f->value.function.name
1364 : 1064 : = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1365 : 1064 : }
1366 : :
1367 : :
1368 : : void
1369 : 4137 : gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1370 : : {
1371 : 4137 : f->ts.type = BT_INTEGER;
1372 : 4137 : f->ts.kind = (kind == NULL)
1373 : 3319 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1374 : 4137 : f->value.function.name
1375 : 8274 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1376 : 4137 : gfc_type_letter (a->ts.type),
1377 : : gfc_type_abi_kind (&a->ts));
1378 : 4137 : }
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 : 15314 : gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1508 : : {
1509 : 15314 : resolve_bound (f, array, dim, kind, "__lbound", false);
1510 : 15314 : }
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 : 12938 : gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1522 : : {
1523 : 12938 : f->ts.type = BT_INTEGER;
1524 : 12938 : if (kind)
1525 : 224 : f->ts.kind = mpz_get_si (kind->value.integer);
1526 : : else
1527 : 12714 : f->ts.kind = gfc_default_integer_kind;
1528 : 12938 : f->value.function.name
1529 : 12938 : = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1530 : : gfc_default_integer_kind);
1531 : 12938 : }
1532 : :
1533 : :
1534 : : void
1535 : 3575 : gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1536 : : {
1537 : 3575 : f->ts.type = BT_INTEGER;
1538 : 3575 : if (kind)
1539 : 433 : f->ts.kind = mpz_get_si (kind->value.integer);
1540 : : else
1541 : 3142 : f->ts.kind = gfc_default_integer_kind;
1542 : 3575 : f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1543 : 3575 : }
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 : 6917 : gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1567 : : {
1568 : 6917 : f->ts.type= BT_INTEGER;
1569 : 6917 : f->ts.kind = gfc_index_integer_kind;
1570 : 6917 : f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1571 : 6917 : }
1572 : :
1573 : :
1574 : : void
1575 : 385 : gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1576 : : {
1577 : 385 : f->ts = x->ts;
1578 : 385 : f->value.function.name
1579 : 385 : = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type),
1580 : : gfc_type_abi_kind (&x->ts));
1581 : 385 : }
1582 : :
1583 : :
1584 : : void
1585 : 344 : gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1586 : : {
1587 : 344 : f->ts = x->ts;
1588 : 344 : f->value.function.name
1589 : 344 : = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1590 : : gfc_type_abi_kind (&x->ts));
1591 : 344 : }
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 : 1164 : gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1612 : : {
1613 : 1164 : gfc_expr temp;
1614 : 1164 : bt type;
1615 : :
1616 : 1164 : 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 : 1127 : temp.expr_type = EXPR_OP;
1624 : 1127 : gfc_clear_ts (&temp.ts);
1625 : 1127 : temp.value.op.op = INTRINSIC_NONE;
1626 : 1127 : temp.value.op.op1 = a;
1627 : 1127 : temp.value.op.op2 = b;
1628 : 1127 : gfc_type_convert_binary (&temp, 1);
1629 : 1127 : f->ts = temp.ts;
1630 : : }
1631 : :
1632 : 1164 : f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1633 : 1164 : f->corank = a->corank;
1634 : :
1635 : 1164 : if (a->rank == 2 && b->rank == 2)
1636 : : {
1637 : 764 : if (a->shape && b->shape)
1638 : : {
1639 : 559 : f->shape = gfc_get_shape (f->rank);
1640 : 559 : mpz_init_set (f->shape[0], a->shape[0]);
1641 : 559 : mpz_init_set (f->shape[1], b->shape[1]);
1642 : : }
1643 : : }
1644 : 400 : 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 : 218 : if (a->shape)
1657 : : {
1658 : 167 : f->shape = gfc_get_shape (f->rank);
1659 : 167 : 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 : 1164 : if (f->ts.type == BT_UNSIGNED)
1667 : : type = BT_INTEGER;
1668 : : else
1669 : 1158 : type = f->ts.type;
1670 : :
1671 : 1164 : f->value.function.name
1672 : 1164 : = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (type),
1673 : : gfc_type_abi_kind (&f->ts));
1674 : 1164 : }
1675 : :
1676 : :
1677 : : static void
1678 : 4184 : gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1679 : : {
1680 : 4184 : gfc_actual_arglist *a;
1681 : :
1682 : 4184 : f->ts.type = args->expr->ts.type;
1683 : 4184 : f->ts.kind = args->expr->ts.kind;
1684 : : /* Find the largest type kind. */
1685 : 9261 : for (a = args->next; a; a = a->next)
1686 : : {
1687 : 5077 : 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 : 13445 : for (a = args; a; a = a->next)
1693 : : {
1694 : 9261 : if (a->expr->ts.kind != f->ts.kind)
1695 : 42 : gfc_convert_type (a->expr, &f->ts, 2);
1696 : : }
1697 : :
1698 : 4184 : f->value.function.name
1699 : 4184 : = gfc_get_string (name, gfc_type_letter (f->ts.type),
1700 : : gfc_type_abi_kind (&f->ts));
1701 : 4184 : }
1702 : :
1703 : :
1704 : : void
1705 : 2694 : gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1706 : : {
1707 : 2694 : gfc_resolve_minmax ("__max_%c%d", f, args);
1708 : 2694 : }
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 : 2821 : gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1932 : : gfc_expr *mask)
1933 : : {
1934 : 2821 : const char *name;
1935 : 2821 : int i, j, idim;
1936 : :
1937 : 2821 : f->ts = array->ts;
1938 : :
1939 : 2821 : 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 : 2821 : if (mask)
1958 : : {
1959 : 1881 : if (mask->rank == 0)
1960 : : name = "smaxval";
1961 : : else
1962 : 1143 : name = "mmaxval";
1963 : :
1964 : 1881 : resolve_mask_arg (mask);
1965 : : }
1966 : : else
1967 : : name = "maxval";
1968 : :
1969 : 2821 : if (array->ts.type != BT_CHARACTER)
1970 : 2401 : f->value.function.name
1971 : 4802 : = gfc_get_string (PREFIX ("%s_%c%d"), name,
1972 : 2401 : 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 : 2821 : }
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 : 3819 : gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
2031 : : gfc_expr *fsource ATTRIBUTE_UNUSED,
2032 : : gfc_expr *mask ATTRIBUTE_UNUSED)
2033 : : {
2034 : 3819 : if (tsource->ts.type == BT_CHARACTER && tsource->ref)
2035 : 12 : gfc_resolve_substring_charlen (tsource);
2036 : :
2037 : 3819 : if (fsource->ts.type == BT_CHARACTER && fsource->ref)
2038 : 24 : gfc_resolve_substring_charlen (fsource);
2039 : :
2040 : 3819 : if (tsource->ts.type == BT_CHARACTER)
2041 : 1266 : check_charlen_present (tsource);
2042 : :
2043 : 3819 : f->ts = tsource->ts;
2044 : 3819 : f->value.function.name
2045 : 3819 : = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
2046 : : gfc_type_abi_kind (&tsource->ts));
2047 : 3819 : }
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 : 1490 : gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
2065 : : {
2066 : 1490 : gfc_resolve_minmax ("__min_%c%d", f, args);
2067 : 1490 : }
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 : 3902 : gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2218 : : {
2219 : 3902 : f->ts.type = a->ts.type;
2220 : 3902 : if (p != NULL)
2221 : 3854 : f->ts.kind = gfc_kind_max (a,p);
2222 : : else
2223 : 48 : f->ts.kind = a->ts.kind;
2224 : :
2225 : 3902 : 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 : 3902 : f->value.function.name
2234 : 3902 : = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2235 : : gfc_type_abi_kind (&f->ts));
2236 : 3902 : }
2237 : :
2238 : :
2239 : : void
2240 : 1800 : gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2241 : : {
2242 : 1800 : f->ts.type = a->ts.type;
2243 : 1800 : if (p != NULL)
2244 : 1800 : f->ts.kind = gfc_kind_max (a,p);
2245 : : else
2246 : 0 : f->ts.kind = a->ts.kind;
2247 : :
2248 : 1800 : 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 : 1800 : f->value.function.name
2257 : 1800 : = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2258 : : gfc_type_abi_kind (&f->ts));
2259 : 1800 : }
2260 : :
2261 : : void
2262 : 5494 : gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2263 : : {
2264 : 5494 : if (p->ts.kind != a->ts.kind)
2265 : 600 : gfc_convert_type (p, &a->ts, 2);
2266 : :
2267 : 5494 : f->ts = a->ts;
2268 : 5494 : f->value.function.name
2269 : 5494 : = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2270 : : gfc_type_abi_kind (&a->ts));
2271 : 5494 : }
2272 : :
2273 : : void
2274 : 396 : gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2275 : : {
2276 : 396 : f->ts.type = BT_INTEGER;
2277 : 396 : f->ts.kind = (kind == NULL)
2278 : 48 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2279 : 396 : f->value.function.name
2280 : 396 : = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2281 : 396 : }
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 : 918 : gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2322 : : gfc_expr *vector ATTRIBUTE_UNUSED)
2323 : : {
2324 : 918 : if (array->ts.type == BT_CHARACTER && array->ref)
2325 : 134 : gfc_resolve_substring_charlen (array);
2326 : :
2327 : 918 : f->ts = array->ts;
2328 : 918 : f->rank = 1;
2329 : :
2330 : 918 : resolve_mask_arg (mask);
2331 : :
2332 : 918 : if (mask->rank != 0)
2333 : : {
2334 : 570 : if (array->ts.type == BT_CHARACTER)
2335 : 87 : f->value.function.name
2336 : 147 : = array->ts.kind == 1 ? PREFIX ("pack_char")
2337 : : : gfc_get_string
2338 : 60 : (PREFIX ("pack_char%d"),
2339 : : array->ts.kind);
2340 : : else
2341 : 483 : 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 : 918 : }
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 : 649 : gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2366 : : gfc_expr *mask)
2367 : : {
2368 : 649 : resolve_transformational ("product", f, array, dim, mask, true);
2369 : 649 : }
2370 : :
2371 : :
2372 : : void
2373 : 1463 : gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2374 : : {
2375 : 1463 : f->ts.type = BT_INTEGER;
2376 : 1463 : f->ts.kind = gfc_default_integer_kind;
2377 : 1463 : f->value.function.name = gfc_get_string ("__rank");
2378 : 1463 : }
2379 : :
2380 : :
2381 : : void
2382 : 5583 : gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2383 : : {
2384 : 5583 : f->ts.type = BT_REAL;
2385 : :
2386 : 5583 : if (kind != NULL)
2387 : 1246 : f->ts.kind = mpz_get_si (kind->value.integer);
2388 : : else
2389 : 4337 : f->ts.kind = (a->ts.type == BT_COMPLEX)
2390 : 4337 : ? a->ts.kind : gfc_default_real_kind;
2391 : :
2392 : 5583 : f->value.function.name
2393 : 11166 : = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2394 : 5583 : gfc_type_letter (a->ts.type),
2395 : : gfc_type_abi_kind (&a->ts));
2396 : 5583 : }
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 : : void
2412 : 4 : gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2413 : : gfc_expr *p2 ATTRIBUTE_UNUSED)
2414 : : {
2415 : 4 : f->ts.type = BT_INTEGER;
2416 : 4 : f->ts.kind = gfc_default_integer_kind;
2417 : 4 : f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2418 : 4 : }
2419 : :
2420 : :
2421 : : void
2422 : 904 : gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2423 : : gfc_expr *ncopies)
2424 : : {
2425 : 904 : gfc_expr *tmp;
2426 : 904 : f->ts.type = BT_CHARACTER;
2427 : 904 : f->ts.kind = string->ts.kind;
2428 : 904 : f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2429 : :
2430 : : /* If possible, generate a character length. */
2431 : 904 : if (f->ts.u.cl == NULL)
2432 : 546 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2433 : :
2434 : 904 : tmp = NULL;
2435 : 904 : if (string->expr_type == EXPR_CONSTANT)
2436 : : {
2437 : 331 : tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2438 : : string->value.character.length);
2439 : : }
2440 : 573 : else if (string->ts.u.cl && string->ts.u.cl->length)
2441 : : {
2442 : 495 : tmp = gfc_copy_expr (string->ts.u.cl->length);
2443 : : }
2444 : :
2445 : 826 : if (tmp)
2446 : : {
2447 : : /* Force-convert to gfc_charlen_int_kind before gfc_multiply. */
2448 : 826 : gfc_expr *e = gfc_copy_expr (ncopies);
2449 : 826 : gfc_typespec ts = tmp->ts;
2450 : 826 : ts.kind = gfc_charlen_int_kind;
2451 : 826 : gfc_convert_type_warn (e, &ts, 2, 0);
2452 : 826 : gfc_convert_type_warn (tmp, &ts, 2, 0);
2453 : 826 : f->ts.u.cl->length = gfc_multiply (tmp, e);
2454 : : }
2455 : 904 : }
2456 : :
2457 : :
2458 : : void
2459 : 3359 : gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2460 : : gfc_expr *pad ATTRIBUTE_UNUSED,
2461 : : gfc_expr *order ATTRIBUTE_UNUSED)
2462 : : {
2463 : 3359 : mpz_t rank;
2464 : 3359 : int kind;
2465 : 3359 : int i;
2466 : :
2467 : 3359 : if (source->ts.type == BT_CHARACTER && source->ref)
2468 : 272 : gfc_resolve_substring_charlen (source);
2469 : :
2470 : 3359 : f->ts = source->ts;
2471 : :
2472 : 3359 : gfc_array_size (shape, &rank);
2473 : 3359 : f->rank = mpz_get_si (rank);
2474 : 3359 : mpz_clear (rank);
2475 : 3359 : switch (source->ts.type)
2476 : : {
2477 : 3311 : case BT_COMPLEX:
2478 : 3311 : case BT_REAL:
2479 : 3311 : case BT_INTEGER:
2480 : 3311 : case BT_LOGICAL:
2481 : 3311 : case BT_CHARACTER:
2482 : 3311 : kind = source->ts.kind;
2483 : 3311 : break;
2484 : :
2485 : : default:
2486 : : kind = 0;
2487 : : break;
2488 : : }
2489 : :
2490 : 3311 : switch (kind)
2491 : : {
2492 : 3017 : case 4:
2493 : 3017 : case 8:
2494 : 3017 : case 10:
2495 : 3017 : case 16:
2496 : 3017 : if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2497 : 953 : f->value.function.name
2498 : 1906 : = gfc_get_string (PREFIX ("reshape_%c%d"),
2499 : 953 : gfc_type_letter (source->ts.type),
2500 : : gfc_type_abi_kind (&source->ts));
2501 : 2064 : else if (source->ts.type == BT_CHARACTER)
2502 : 14 : f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2503 : : kind);
2504 : : else
2505 : 2050 : f->value.function.name
2506 : 2050 : = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2507 : : break;
2508 : :
2509 : 342 : default:
2510 : 684 : f->value.function.name = (source->ts.type == BT_CHARACTER
2511 : 342 : ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2512 : 342 : break;
2513 : : }
2514 : :
2515 : 3359 : if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2516 : : {
2517 : 1774 : gfc_constructor *c;
2518 : 1774 : f->shape = gfc_get_shape (f->rank);
2519 : 1774 : c = gfc_constructor_first (shape->value.constructor);
2520 : 7788 : for (i = 0; i < f->rank; i++)
2521 : : {
2522 : 4240 : mpz_init_set (f->shape[i], c->expr->value.integer);
2523 : 4240 : c = gfc_constructor_next (c);
2524 : : }
2525 : : }
2526 : :
2527 : : /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2528 : : so many runtime variations. */
2529 : 3359 : if (shape->ts.kind != gfc_index_integer_kind)
2530 : : {
2531 : 2816 : gfc_typespec ts = shape->ts;
2532 : 2816 : ts.kind = gfc_index_integer_kind;
2533 : 2816 : gfc_convert_type_warn (shape, &ts, 2, 0);
2534 : : }
2535 : 3359 : if (order && order->ts.kind != gfc_index_integer_kind)
2536 : 110 : gfc_convert_type_warn (order, &shape->ts, 2, 0);
2537 : 3359 : }
2538 : :
2539 : :
2540 : : void
2541 : 132 : gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2542 : : {
2543 : 132 : f->ts = x->ts;
2544 : 132 : f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2545 : 132 : }
2546 : :
2547 : : void
2548 : 401 : gfc_resolve_fe_runtime_error (gfc_code *c)
2549 : : {
2550 : 401 : const char *name;
2551 : 401 : gfc_actual_arglist *a;
2552 : :
2553 : 401 : name = gfc_get_string (PREFIX ("runtime_error"));
2554 : :
2555 : 1203 : for (a = c->ext.actual->next; a; a = a->next)
2556 : 802 : a->name = "%VAL";
2557 : :
2558 : 401 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2559 : : /* We set the backend_decl here because runtime_error is a
2560 : : variadic function and we would use the wrong calling
2561 : : convention otherwise. */
2562 : 401 : c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2563 : 401 : }
2564 : :
2565 : : void
2566 : 156 : gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2567 : : {
2568 : 156 : f->ts = x->ts;
2569 : 156 : f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2570 : 156 : }
2571 : :
2572 : :
2573 : : void
2574 : 814 : gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2575 : : gfc_expr *set ATTRIBUTE_UNUSED,
2576 : : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2577 : : {
2578 : 814 : f->ts.type = BT_INTEGER;
2579 : 814 : if (kind)
2580 : 232 : f->ts.kind = mpz_get_si (kind->value.integer);
2581 : : else
2582 : 582 : f->ts.kind = gfc_default_integer_kind;
2583 : 814 : f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2584 : 814 : }
2585 : :
2586 : :
2587 : : void
2588 : 52 : gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2589 : : {
2590 : 52 : t1->ts = t0->ts;
2591 : 52 : t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2592 : 52 : }
2593 : :
2594 : :
2595 : : void
2596 : 620 : gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2597 : : gfc_expr *i ATTRIBUTE_UNUSED)
2598 : : {
2599 : 620 : f->ts = x->ts;
2600 : 620 : f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2601 : 620 : }
2602 : :
2603 : :
2604 : : void
2605 : 9265 : gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2606 : : {
2607 : 9265 : f->ts.type = BT_INTEGER;
2608 : :
2609 : 9265 : if (kind)
2610 : 57 : f->ts.kind = mpz_get_si (kind->value.integer);
2611 : : else
2612 : 9208 : f->ts.kind = gfc_default_integer_kind;
2613 : :
2614 : 9265 : f->rank = 1;
2615 : 9265 : if (array->rank != -1)
2616 : : {
2617 : 8389 : f->shape = gfc_get_shape (1);
2618 : 8389 : mpz_init_set_ui (f->shape[0], array->rank);
2619 : : }
2620 : :
2621 : 9265 : f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2622 : 9265 : }
2623 : :
2624 : :
2625 : : void
2626 : 768 : gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2627 : : {
2628 : 768 : f->ts = i->ts;
2629 : 768 : if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2630 : 192 : f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2631 : 576 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2632 : 420 : f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2633 : 156 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2634 : 156 : f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2635 : : else
2636 : 0 : gcc_unreachable ();
2637 : 768 : }
2638 : :
2639 : :
2640 : : void
2641 : 1323 : gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2642 : : {
2643 : 1323 : f->ts = a->ts;
2644 : 1323 : f->value.function.name
2645 : 1323 : = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
2646 : : gfc_type_abi_kind (&a->ts));
2647 : 1323 : }
2648 : :
2649 : :
2650 : : void
2651 : 1 : gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2652 : : {
2653 : 1 : f->ts.type = BT_INTEGER;
2654 : 1 : f->ts.kind = gfc_c_int_kind;
2655 : :
2656 : : /* handler can be either BT_INTEGER or BT_PROCEDURE */
2657 : 1 : if (handler->ts.type == BT_INTEGER)
2658 : : {
2659 : 0 : if (handler->ts.kind != gfc_c_int_kind)
2660 : 0 : gfc_convert_type (handler, &f->ts, 2);
2661 : 0 : f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2662 : : }
2663 : : else
2664 : 1 : f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2665 : :
2666 : 1 : if (number->ts.kind != gfc_c_int_kind)
2667 : 0 : gfc_convert_type (number, &f->ts, 2);
2668 : 1 : }
2669 : :
2670 : :
2671 : : void
2672 : 808 : gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2673 : : {
2674 : 808 : f->ts = x->ts;
2675 : 808 : f->value.function.name
2676 : 808 : = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2677 : : gfc_type_abi_kind (&x->ts));
2678 : 808 : }
2679 : :
2680 : :
2681 : : void
2682 : 302 : gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2683 : : {
2684 : 302 : f->ts = x->ts;
2685 : 302 : f->value.function.name
2686 : 302 : = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
2687 : : gfc_type_abi_kind (&x->ts));
2688 : 302 : }
2689 : :
2690 : :
2691 : : void
2692 : 27512 : gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2693 : : gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2694 : : {
2695 : 27512 : f->ts.type = BT_INTEGER;
2696 : 27512 : if (kind)
2697 : 5347 : f->ts.kind = mpz_get_si (kind->value.integer);
2698 : : else
2699 : 22165 : f->ts.kind = gfc_default_integer_kind;
2700 : 27512 : }
2701 : :
2702 : :
2703 : : void
2704 : 0 : gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2705 : : gfc_expr *dim ATTRIBUTE_UNUSED)
2706 : : {
2707 : 0 : f->ts.type = BT_INTEGER;
2708 : 0 : f->ts.kind = gfc_index_integer_kind;
2709 : 0 : }
2710 : :
2711 : :
2712 : : void
2713 : 213 : gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2714 : : {
2715 : 213 : f->ts = x->ts;
2716 : 213 : f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2717 : 213 : }
2718 : :
2719 : :
2720 : : void
2721 : 710 : gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2722 : : gfc_expr *ncopies)
2723 : : {
2724 : 710 : if (source->ts.type == BT_CHARACTER && source->ref)
2725 : 84 : gfc_resolve_substring_charlen (source);
2726 : :
2727 : 710 : if (source->ts.type == BT_CHARACTER)
2728 : 123 : check_charlen_present (source);
2729 : :
2730 : 710 : f->ts = source->ts;
2731 : 710 : f->rank = source->rank + 1;
2732 : 710 : if (source->rank == 0)
2733 : : {
2734 : 63 : if (source->ts.type == BT_CHARACTER)
2735 : 39 : f->value.function.name
2736 : 39 : = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2737 : : : gfc_get_string
2738 : 0 : (PREFIX ("spread_char%d_scalar"),
2739 : : source->ts.kind);
2740 : : else
2741 : 24 : f->value.function.name = PREFIX ("spread_scalar");
2742 : : }
2743 : : else
2744 : : {
2745 : 647 : if (source->ts.type == BT_CHARACTER)
2746 : 84 : f->value.function.name
2747 : 132 : = source->ts.kind == 1 ? PREFIX ("spread_char")
2748 : : : gfc_get_string
2749 : 48 : (PREFIX ("spread_char%d"),
2750 : : source->ts.kind);
2751 : : else
2752 : 563 : f->value.function.name = PREFIX ("spread");
2753 : : }
2754 : :
2755 : 710 : if (dim && gfc_is_constant_expr (dim)
2756 : 1420 : && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2757 : : {
2758 : 442 : int i, idim;
2759 : 442 : idim = mpz_get_ui (dim->value.integer);
2760 : 442 : f->shape = gfc_get_shape (f->rank);
2761 : 464 : for (i = 0; i < (idim - 1); i++)
2762 : 22 : mpz_init_set (f->shape[i], source->shape[i]);
2763 : :
2764 : 442 : mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2765 : :
2766 : 1694 : for (i = idim; i < f->rank ; i++)
2767 : 810 : mpz_init_set (f->shape[i], source->shape[i-1]);
2768 : : }
2769 : :
2770 : :
2771 : 710 : gfc_resolve_dim_arg (dim);
2772 : 710 : gfc_resolve_index (ncopies, 1);
2773 : 710 : }
2774 : :
2775 : :
2776 : : void
2777 : 1214 : gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2778 : : {
2779 : 1214 : f->ts = x->ts;
2780 : 1214 : f->value.function.name
2781 : 1214 : = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
2782 : : gfc_type_abi_kind (&x->ts));
2783 : 1214 : }
2784 : :
2785 : :
2786 : : /* Resolve the g77 compatibility function STAT AND FSTAT. */
2787 : :
2788 : : void
2789 : 13 : gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2790 : : gfc_expr *a ATTRIBUTE_UNUSED)
2791 : : {
2792 : 13 : f->ts.type = BT_INTEGER;
2793 : 13 : f->ts.kind = gfc_default_integer_kind;
2794 : 13 : f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2795 : 13 : }
2796 : :
2797 : :
2798 : : void
2799 : 7 : gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2800 : : gfc_expr *a ATTRIBUTE_UNUSED)
2801 : : {
2802 : 7 : f->ts.type = BT_INTEGER;
2803 : 7 : f->ts.kind = gfc_default_integer_kind;
2804 : 7 : f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2805 : 7 : }
2806 : :
2807 : :
2808 : : void
2809 : 6 : gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2810 : : {
2811 : 6 : f->ts.type = BT_INTEGER;
2812 : 6 : f->ts.kind = gfc_default_integer_kind;
2813 : 6 : if (n->ts.kind != f->ts.kind)
2814 : 0 : gfc_convert_type (n, &f->ts, 2);
2815 : :
2816 : 6 : f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2817 : 6 : }
2818 : :
2819 : :
2820 : : void
2821 : 43 : gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2822 : : {
2823 : 43 : gfc_typespec ts;
2824 : 43 : gfc_clear_ts (&ts);
2825 : :
2826 : 43 : f->ts.type = BT_INTEGER;
2827 : 43 : f->ts.kind = gfc_c_int_kind;
2828 : 43 : if (u->ts.kind != gfc_c_int_kind)
2829 : : {
2830 : 0 : ts.type = BT_INTEGER;
2831 : 0 : ts.kind = gfc_c_int_kind;
2832 : 0 : ts.u.derived = NULL;
2833 : 0 : ts.u.cl = NULL;
2834 : 0 : gfc_convert_type (u, &ts, 2);
2835 : : }
2836 : :
2837 : 43 : f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2838 : 43 : }
2839 : :
2840 : :
2841 : : void
2842 : 3 : gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2843 : : {
2844 : 3 : f->ts.type = BT_INTEGER;
2845 : 3 : f->ts.kind = gfc_c_int_kind;
2846 : 3 : f->value.function.name = gfc_get_string (PREFIX ("fget"));
2847 : 3 : }
2848 : :
2849 : :
2850 : : void
2851 : 25 : gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2852 : : {
2853 : 25 : gfc_typespec ts;
2854 : 25 : gfc_clear_ts (&ts);
2855 : :
2856 : 25 : f->ts.type = BT_INTEGER;
2857 : 25 : f->ts.kind = gfc_c_int_kind;
2858 : 25 : if (u->ts.kind != gfc_c_int_kind)
2859 : : {
2860 : 0 : ts.type = BT_INTEGER;
2861 : 0 : ts.kind = gfc_c_int_kind;
2862 : 0 : ts.u.derived = NULL;
2863 : 0 : ts.u.cl = NULL;
2864 : 0 : gfc_convert_type (u, &ts, 2);
2865 : : }
2866 : :
2867 : 25 : f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2868 : 25 : }
2869 : :
2870 : :
2871 : : void
2872 : 1 : gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2873 : : {
2874 : 1 : f->ts.type = BT_INTEGER;
2875 : 1 : f->ts.kind = gfc_c_int_kind;
2876 : 1 : f->value.function.name = gfc_get_string (PREFIX ("fput"));
2877 : 1 : }
2878 : :
2879 : :
2880 : : void
2881 : 258 : gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2882 : : {
2883 : 258 : gfc_typespec ts;
2884 : 258 : gfc_clear_ts (&ts);
2885 : :
2886 : 258 : f->ts.type = BT_INTEGER;
2887 : 258 : f->ts.kind = gfc_intio_kind;
2888 : 258 : if (u->ts.kind != gfc_c_int_kind)
2889 : : {
2890 : 0 : ts.type = BT_INTEGER;
2891 : 0 : ts.kind = gfc_c_int_kind;
2892 : 0 : ts.u.derived = NULL;
2893 : 0 : ts.u.cl = NULL;
2894 : 0 : gfc_convert_type (u, &ts, 2);
2895 : : }
2896 : :
2897 : 258 : f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2898 : 258 : }
2899 : :
2900 : :
2901 : : void
2902 : 748 : gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2903 : : gfc_expr *kind)
2904 : : {
2905 : 748 : f->ts.type = BT_INTEGER;
2906 : 748 : if (kind)
2907 : 390 : f->ts.kind = mpz_get_si (kind->value.integer);
2908 : : else
2909 : 358 : f->ts.kind = gfc_default_integer_kind;
2910 : 748 : }
2911 : :
2912 : :
2913 : : void
2914 : 4216 : gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2915 : : {
2916 : 4216 : resolve_transformational ("sum", f, array, dim, mask, true);
2917 : 4216 : }
2918 : :
2919 : :
2920 : : void
2921 : 4 : gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2922 : : gfc_expr *p2 ATTRIBUTE_UNUSED)
2923 : : {
2924 : 4 : f->ts.type = BT_INTEGER;
2925 : 4 : f->ts.kind = gfc_default_integer_kind;
2926 : 4 : f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2927 : 4 : }
2928 : :
2929 : :
2930 : : /* Resolve the g77 compatibility function SYSTEM. */
2931 : :
2932 : : void
2933 : 0 : gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2934 : : {
2935 : 0 : f->ts.type = BT_INTEGER;
2936 : 0 : f->ts.kind = 4;
2937 : 0 : f->value.function.name = gfc_get_string (PREFIX ("system"));
2938 : 0 : }
2939 : :
2940 : :
2941 : : void
2942 : 662 : gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2943 : : {
2944 : 662 : f->ts = x->ts;
2945 : 662 : f->value.function.name
2946 : 662 : = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
2947 : : gfc_type_abi_kind (&x->ts));
2948 : 662 : }
2949 : :
2950 : :
2951 : : void
2952 : 302 : gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2953 : : {
2954 : 302 : f->ts = x->ts;
2955 : 302 : f->value.function.name
2956 : 302 : = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
2957 : : gfc_type_abi_kind (&x->ts));
2958 : 302 : }
2959 : :
2960 : :
2961 : : /* Resolve failed_images (team, kind). */
2962 : :
2963 : : void
2964 : 24 : gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2965 : : gfc_expr *kind)
2966 : : {
2967 : 24 : static char failed_images[] = "_gfortran_caf_failed_images";
2968 : 24 : f->rank = 1;
2969 : 24 : f->ts.type = BT_INTEGER;
2970 : 24 : if (kind == NULL)
2971 : 8 : f->ts.kind = gfc_default_integer_kind;
2972 : : else
2973 : 16 : gfc_extract_int (kind, &f->ts.kind);
2974 : 24 : f->value.function.name = failed_images;
2975 : 24 : }
2976 : :
2977 : :
2978 : : /* Resolve image_status (image, team). */
2979 : :
2980 : : void
2981 : 66 : gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2982 : : gfc_expr *team ATTRIBUTE_UNUSED)
2983 : : {
2984 : 66 : static char image_status[] = "_gfortran_caf_image_status";
2985 : 66 : f->ts.type = BT_INTEGER;
2986 : 66 : f->ts.kind = gfc_default_integer_kind;
2987 : 66 : f->value.function.name = image_status;
2988 : 66 : }
2989 : :
2990 : :
2991 : : /* Resolve get_team (). */
2992 : :
2993 : : void
2994 : 3 : gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2995 : : {
2996 : 3 : static char get_team[] = "_gfortran_caf_get_team";
2997 : 3 : f->rank = 0;
2998 : 3 : f->ts.type = BT_INTEGER;
2999 : 3 : f->ts.kind = gfc_default_integer_kind;
3000 : 3 : f->value.function.name = get_team;
3001 : 3 : }
3002 : :
3003 : :
3004 : : /* Resolve image_index (...). */
3005 : :
3006 : : void
3007 : 154 : gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
3008 : : gfc_expr *sub ATTRIBUTE_UNUSED)
3009 : : {
3010 : 154 : static char image_index[] = "__image_index";
3011 : 154 : f->ts.type = BT_INTEGER;
3012 : 154 : f->ts.kind = gfc_default_integer_kind;
3013 : 154 : f->value.function.name = image_index;
3014 : 154 : }
3015 : :
3016 : :
3017 : : /* Resolve stopped_images (team, kind). */
3018 : :
3019 : : void
3020 : 24 : gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
3021 : : gfc_expr *kind)
3022 : : {
3023 : 24 : static char stopped_images[] = "_gfortran_caf_stopped_images";
3024 : 24 : f->rank = 1;
3025 : 24 : f->ts.type = BT_INTEGER;
3026 : 24 : if (kind == NULL)
3027 : 8 : f->ts.kind = gfc_default_integer_kind;
3028 : : else
3029 : 16 : gfc_extract_int (kind, &f->ts.kind);
3030 : 24 : f->value.function.name = stopped_images;
3031 : 24 : }
3032 : :
3033 : :
3034 : : /* Resolve team_number (team). */
3035 : :
3036 : : void
3037 : 65 : gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
3038 : : {
3039 : 65 : static char team_number[] = "_gfortran_caf_team_number";
3040 : 65 : f->rank = 0;
3041 : 65 : f->ts.type = BT_INTEGER;
3042 : 65 : f->ts.kind = gfc_default_integer_kind;
3043 : 65 : f->value.function.name = team_number;
3044 : 65 : }
3045 : :
3046 : :
3047 : : void
3048 : 1603 : gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
3049 : : gfc_expr *distance ATTRIBUTE_UNUSED)
3050 : : {
3051 : 1603 : static char this_image[] = "__this_image";
3052 : 1603 : if (array && gfc_is_coarray (array))
3053 : 718 : resolve_bound (f, array, dim, NULL, "__this_image", true);
3054 : : else
3055 : : {
3056 : 885 : f->ts.type = BT_INTEGER;
3057 : 885 : f->ts.kind = gfc_default_integer_kind;
3058 : 885 : f->value.function.name = this_image;
3059 : : }
3060 : 1603 : }
3061 : :
3062 : :
3063 : : void
3064 : 14 : gfc_resolve_time (gfc_expr *f)
3065 : : {
3066 : 14 : f->ts.type = BT_INTEGER;
3067 : 14 : f->ts.kind = 4;
3068 : 14 : f->value.function.name = gfc_get_string (PREFIX ("time_func"));
3069 : 14 : }
3070 : :
3071 : :
3072 : : void
3073 : 2 : gfc_resolve_time8 (gfc_expr *f)
3074 : : {
3075 : 2 : f->ts.type = BT_INTEGER;
3076 : 2 : f->ts.kind = 8;
3077 : 2 : f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
3078 : 2 : }
3079 : :
3080 : :
3081 : : void
3082 : 1978 : gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
3083 : : gfc_expr *mold, gfc_expr *size)
3084 : : {
3085 : : /* TODO: Make this do something meaningful. */
3086 : 1978 : static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3087 : :
3088 : 1978 : if (mold->ts.type == BT_CHARACTER
3089 : 650 : && !mold->ts.u.cl->length
3090 : 2183 : && gfc_is_constant_expr (mold))
3091 : : {
3092 : 107 : int len;
3093 : 107 : if (mold->expr_type == EXPR_CONSTANT)
3094 : : {
3095 : 107 : len = mold->value.character.length;
3096 : 107 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3097 : : NULL, len);
3098 : : }
3099 : : else
3100 : : {
3101 : 0 : gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3102 : 0 : len = c->expr->value.character.length;
3103 : 0 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3104 : : NULL, len);
3105 : : }
3106 : : }
3107 : :
3108 : 1978 : if (UNLIMITED_POLY (mold))
3109 : 0 : gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
3110 : : &mold->where);
3111 : :
3112 : 1978 : f->ts = mold->ts;
3113 : :
3114 : 1978 : if (size == NULL && mold->rank == 0)
3115 : : {
3116 : 1203 : f->rank = 0;
3117 : 1203 : f->value.function.name = transfer0;
3118 : : }
3119 : : else
3120 : : {
3121 : 775 : f->rank = 1;
3122 : 775 : f->value.function.name = transfer1;
3123 : 775 : if (size && gfc_is_constant_expr (size))
3124 : : {
3125 : 149 : f->shape = gfc_get_shape (1);
3126 : 149 : mpz_init_set (f->shape[0], size->value.integer);
3127 : : }
3128 : : }
3129 : 1978 : }
3130 : :
3131 : :
3132 : : void
3133 : 1599 : gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3134 : : {
3135 : :
3136 : 1599 : if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3137 : 156 : gfc_resolve_substring_charlen (matrix);
3138 : :
3139 : 1599 : f->ts = matrix->ts;
3140 : 1599 : f->rank = 2;
3141 : 1599 : if (matrix->shape)
3142 : : {
3143 : 1267 : f->shape = gfc_get_shape (2);
3144 : 1267 : mpz_init_set (f->shape[0], matrix->shape[1]);
3145 : 1267 : mpz_init_set (f->shape[1], matrix->shape[0]);
3146 : : }
3147 : :
3148 : 1599 : switch (matrix->ts.kind)
3149 : : {
3150 : 1485 : case 4:
3151 : 1485 : case 8:
3152 : 1485 : case 10:
3153 : 1485 : case 16:
3154 : 1485 : switch (matrix->ts.type)
3155 : : {
3156 : 470 : case BT_REAL:
3157 : 470 : case BT_COMPLEX:
3158 : 470 : f->value.function.name
3159 : 940 : = gfc_get_string (PREFIX ("transpose_%c%d"),
3160 : 470 : gfc_type_letter (matrix->ts.type),
3161 : : gfc_type_abi_kind (&matrix->ts));
3162 : 470 : break;
3163 : :
3164 : 937 : case BT_INTEGER:
3165 : 937 : case BT_LOGICAL:
3166 : : /* Use the integer routines for real and logical cases. This
3167 : : assumes they all have the same alignment requirements. */
3168 : 937 : f->value.function.name
3169 : 937 : = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3170 : 937 : break;
3171 : :
3172 : 78 : default:
3173 : 78 : if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3174 : 78 : f->value.function.name = PREFIX ("transpose_char4");
3175 : : else
3176 : 0 : f->value.function.name = PREFIX ("transpose");
3177 : : break;
3178 : : }
3179 : : break;
3180 : :
3181 : 114 : default:
3182 : 228 : f->value.function.name = (matrix->ts.type == BT_CHARACTER
3183 : 114 : ? PREFIX ("transpose_char")
3184 : : : PREFIX ("transpose"));
3185 : 114 : break;
3186 : : }
3187 : 1599 : }
3188 : :
3189 : :
3190 : : void
3191 : 4432 : gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3192 : : {
3193 : 4432 : f->ts.type = BT_CHARACTER;
3194 : 4432 : f->ts.kind = string->ts.kind;
3195 : 4432 : f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3196 : 4432 : }
3197 : :
3198 : :
3199 : : /* Resolve the degree trigonometric functions. This amounts to setting
3200 : : the function return type-spec from its argument and building a
3201 : : library function names of the form _gfortran_sind_r4. */
3202 : :
3203 : : void
3204 : 1404 : gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3205 : : {
3206 : 1404 : f->ts = x->ts;
3207 : 1404 : f->value.function.name
3208 : 2808 : = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3209 : 1404 : gfc_type_letter (x->ts.type),
3210 : : gfc_type_abi_kind (&x->ts));
3211 : 1404 : }
3212 : :
3213 : :
3214 : : void
3215 : 144 : gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3216 : : {
3217 : 144 : f->ts = y->ts;
3218 : 144 : f->value.function.name
3219 : 144 : = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3220 : : x->ts.kind);
3221 : 144 : }
3222 : :
3223 : :
3224 : : void
3225 : 13399 : gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3226 : : {
3227 : 13399 : resolve_bound (f, array, dim, kind, "__ubound", false);
3228 : 13399 : }
3229 : :
3230 : :
3231 : : void
3232 : 384 : gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3233 : : {
3234 : 384 : resolve_bound (f, array, dim, kind, "__ucobound", true);
3235 : 384 : }
3236 : :
3237 : :
3238 : : /* Resolve the g77 compatibility function UMASK. */
3239 : :
3240 : : void
3241 : 0 : gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3242 : : {
3243 : 0 : f->ts.type = BT_INTEGER;
3244 : 0 : f->ts.kind = n->ts.kind;
3245 : 0 : f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3246 : 0 : }
3247 : :
3248 : :
3249 : : /* Resolve the g77 compatibility function UNLINK. */
3250 : :
3251 : : void
3252 : 1 : gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3253 : : {
3254 : 1 : f->ts.type = BT_INTEGER;
3255 : 1 : f->ts.kind = 4;
3256 : 1 : f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3257 : 1 : }
3258 : :
3259 : :
3260 : : void
3261 : 0 : gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3262 : : {
3263 : 0 : gfc_typespec ts;
3264 : 0 : gfc_clear_ts (&ts);
3265 : :
3266 : 0 : f->ts.type = BT_CHARACTER;
3267 : 0 : f->ts.kind = gfc_default_character_kind;
3268 : :
3269 : 0 : if (unit->ts.kind != gfc_c_int_kind)
3270 : : {
3271 : 0 : ts.type = BT_INTEGER;
3272 : 0 : ts.kind = gfc_c_int_kind;
3273 : 0 : ts.u.derived = NULL;
3274 : 0 : ts.u.cl = NULL;
3275 : 0 : gfc_convert_type (unit, &ts, 2);
3276 : : }
3277 : :
3278 : 0 : f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3279 : 0 : }
3280 : :
3281 : :
3282 : : void
3283 : 454 : gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3284 : : gfc_expr *field ATTRIBUTE_UNUSED)
3285 : : {
3286 : 454 : if (vector->ts.type == BT_CHARACTER && vector->ref)
3287 : 54 : gfc_resolve_substring_charlen (vector);
3288 : :
3289 : 454 : f->ts = vector->ts;
3290 : 454 : f->rank = mask->rank;
3291 : 454 : resolve_mask_arg (mask);
3292 : :
3293 : 454 : if (vector->ts.type == BT_CHARACTER)
3294 : : {
3295 : 54 : if (vector->ts.kind == 1)
3296 : 30 : f->value.function.name
3297 : 54 : = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3298 : : else
3299 : 24 : f->value.function.name
3300 : 24 : = gfc_get_string (PREFIX ("unpack%d_char%d"),
3301 : 24 : field->rank > 0 ? 1 : 0, vector->ts.kind);
3302 : : }
3303 : : else
3304 : 400 : f->value.function.name
3305 : 493 : = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3306 : 454 : }
3307 : :
3308 : :
3309 : : void
3310 : 254 : gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3311 : : gfc_expr *set ATTRIBUTE_UNUSED,
3312 : : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3313 : : {
3314 : 254 : f->ts.type = BT_INTEGER;
3315 : 254 : if (kind)
3316 : 16 : f->ts.kind = mpz_get_si (kind->value.integer);
3317 : : else
3318 : 238 : f->ts.kind = gfc_default_integer_kind;
3319 : 254 : f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3320 : 254 : }
3321 : :
3322 : :
3323 : : void
3324 : 20 : gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3325 : : {
3326 : 20 : f->ts.type = i->ts.type;
3327 : 20 : f->ts.kind = gfc_kind_max (i, j);
3328 : :
3329 : 20 : if (i->ts.kind != j->ts.kind)
3330 : : {
3331 : 0 : if (i->ts.kind == gfc_kind_max (i, j))
3332 : 0 : gfc_convert_type (j, &i->ts, 2);
3333 : : else
3334 : 0 : gfc_convert_type (i, &j->ts, 2);
3335 : : }
3336 : :
3337 : 20 : f->value.function.name
3338 : 20 : = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3339 : : gfc_type_abi_kind (&f->ts));
3340 : 20 : }
3341 : :
3342 : :
3343 : : /* Intrinsic subroutine resolution. */
3344 : :
3345 : : void
3346 : 0 : gfc_resolve_alarm_sub (gfc_code *c)
3347 : : {
3348 : 0 : const char *name;
3349 : 0 : gfc_expr *seconds, *handler;
3350 : 0 : gfc_typespec ts;
3351 : 0 : gfc_clear_ts (&ts);
3352 : :
3353 : 0 : seconds = c->ext.actual->expr;
3354 : 0 : handler = c->ext.actual->next->expr;
3355 : 0 : ts.type = BT_INTEGER;
3356 : 0 : ts.kind = gfc_c_int_kind;
3357 : :
3358 : : /* handler can be either BT_INTEGER or BT_PROCEDURE.
3359 : : In all cases, the status argument is of default integer kind
3360 : : (enforced in check.cc) so that the function suffix is fixed. */
3361 : 0 : if (handler->ts.type == BT_INTEGER)
3362 : : {
3363 : 0 : if (handler->ts.kind != gfc_c_int_kind)
3364 : 0 : gfc_convert_type (handler, &ts, 2);
3365 : 0 : name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3366 : : gfc_default_integer_kind);
3367 : : }
3368 : : else
3369 : 0 : name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3370 : : gfc_default_integer_kind);
3371 : :
3372 : 0 : if (seconds->ts.kind != gfc_c_int_kind)
3373 : 0 : gfc_convert_type (seconds, &ts, 2);
3374 : :
3375 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3376 : 0 : }
3377 : :
3378 : : void
3379 : 21 : gfc_resolve_cpu_time (gfc_code *c)
3380 : : {
3381 : 21 : const char *name;
3382 : 21 : name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3383 : 21 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3384 : 21 : }
3385 : :
3386 : :
3387 : : /* Create a formal arglist based on an actual one and set the INTENTs given. */
3388 : :
3389 : : static gfc_formal_arglist*
3390 : 198 : create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3391 : : {
3392 : 198 : gfc_formal_arglist* head;
3393 : 198 : gfc_formal_arglist* tail;
3394 : 198 : int i;
3395 : :
3396 : 198 : if (!actual)
3397 : : return NULL;
3398 : :
3399 : 198 : head = tail = gfc_get_formal_arglist ();
3400 : 1188 : for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3401 : : {
3402 : 990 : gfc_symbol* sym;
3403 : :
3404 : 990 : sym = gfc_new_symbol ("dummyarg", NULL);
3405 : 990 : sym->ts = actual->expr->ts;
3406 : :
3407 : 990 : sym->attr.intent = ints[i];
3408 : 990 : tail->sym = sym;
3409 : :
3410 : 990 : if (actual->next)
3411 : 792 : tail->next = gfc_get_formal_arglist ();
3412 : : }
3413 : :
3414 : : return head;
3415 : : }
3416 : :
3417 : :
3418 : : void
3419 : 17 : gfc_resolve_atomic_def (gfc_code *c)
3420 : : {
3421 : 17 : const char *name = "atomic_define";
3422 : 17 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3423 : 17 : }
3424 : :
3425 : :
3426 : : void
3427 : 121 : gfc_resolve_atomic_ref (gfc_code *c)
3428 : : {
3429 : 121 : const char *name = "atomic_ref";
3430 : 121 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3431 : 121 : }
3432 : :
3433 : : void
3434 : 70 : gfc_resolve_event_query (gfc_code *c)
3435 : : {
3436 : 70 : const char *name = "event_query";
3437 : 70 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3438 : 70 : }
3439 : :
3440 : : void
3441 : 198 : gfc_resolve_mvbits (gfc_code *c)
3442 : : {
3443 : 198 : static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3444 : : INTENT_INOUT, INTENT_IN};
3445 : 198 : const char *name;
3446 : :
3447 : : /* TO and FROM are guaranteed to have the same kind parameter. */
3448 : 396 : name = gfc_get_string (PREFIX ("mvbits_i%d"),
3449 : 198 : c->ext.actual->expr->ts.kind);
3450 : 198 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3451 : : /* Mark as elemental subroutine as this does not happen automatically. */
3452 : 198 : c->resolved_sym->attr.elemental = 1;
3453 : :
3454 : : /* Create a dummy formal arglist so the INTENTs are known later for purpose
3455 : : of creating temporaries. */
3456 : 198 : c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3457 : 198 : }
3458 : :
3459 : :
3460 : : /* Set up the call to RANDOM_INIT. */
3461 : :
3462 : : void
3463 : 90 : gfc_resolve_random_init (gfc_code *c)
3464 : : {
3465 : 90 : const char *name;
3466 : 90 : name = gfc_get_string (PREFIX ("random_init"));
3467 : 90 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3468 : 90 : }
3469 : :
3470 : :
3471 : : void
3472 : 552 : gfc_resolve_random_number (gfc_code *c)
3473 : : {
3474 : 552 : const char *name;
3475 : 552 : int kind;
3476 : 552 : char type;
3477 : :
3478 : 552 : kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3479 : 552 : type = gfc_type_letter (c->ext.actual->expr->ts.type);
3480 : 552 : if (c->ext.actual->expr->rank == 0)
3481 : 105 : name = gfc_get_string (PREFIX ("random_%c%d"), type, kind);
3482 : : else
3483 : 447 : name = gfc_get_string (PREFIX ("arandom_%c%d"), type, kind);
3484 : :
3485 : 552 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3486 : 552 : }
3487 : :
3488 : :
3489 : : void
3490 : 303 : gfc_resolve_random_seed (gfc_code *c)
3491 : : {
3492 : 303 : const char *name;
3493 : :
3494 : 303 : name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3495 : 303 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3496 : 303 : }
3497 : :
3498 : :
3499 : : void
3500 : 9 : gfc_resolve_rename_sub (gfc_code *c)
3501 : : {
3502 : 9 : const char *name;
3503 : 9 : int kind;
3504 : :
3505 : : /* Find the type of status. If not present use default integer kind. */
3506 : 9 : if (c->ext.actual->next->next->expr != NULL)
3507 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3508 : : else
3509 : 2 : kind = gfc_default_integer_kind;
3510 : :
3511 : 9 : name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3512 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3513 : 9 : }
3514 : :
3515 : :
3516 : : void
3517 : 9 : gfc_resolve_link_sub (gfc_code *c)
3518 : : {
3519 : 9 : const char *name;
3520 : 9 : int kind;
3521 : :
3522 : 9 : if (c->ext.actual->next->next->expr != NULL)
3523 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3524 : : else
3525 : 2 : kind = gfc_default_integer_kind;
3526 : :
3527 : 9 : name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3528 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3529 : 9 : }
3530 : :
3531 : :
3532 : : void
3533 : 9 : gfc_resolve_symlnk_sub (gfc_code *c)
3534 : : {
3535 : 9 : const char *name;
3536 : 9 : int kind;
3537 : :
3538 : 9 : if (c->ext.actual->next->next->expr != NULL)
3539 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3540 : : else
3541 : 2 : kind = gfc_default_integer_kind;
3542 : :
3543 : 9 : name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3544 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3545 : 9 : }
3546 : :
3547 : :
3548 : : /* G77 compatibility subroutines dtime() and etime(). */
3549 : :
3550 : : void
3551 : 0 : gfc_resolve_dtime_sub (gfc_code *c)
3552 : : {
3553 : 0 : const char *name;
3554 : 0 : name = gfc_get_string (PREFIX ("dtime_sub"));
3555 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3556 : 0 : }
3557 : :
3558 : : void
3559 : 1 : gfc_resolve_etime_sub (gfc_code *c)
3560 : : {
3561 : 1 : const char *name;
3562 : 1 : name = gfc_get_string (PREFIX ("etime_sub"));
3563 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3564 : 1 : }
3565 : :
3566 : :
3567 : : /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3568 : :
3569 : : void
3570 : 12 : gfc_resolve_itime (gfc_code *c)
3571 : : {
3572 : 12 : c->resolved_sym
3573 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3574 : : gfc_default_integer_kind));
3575 : 12 : }
3576 : :
3577 : : void
3578 : 12 : gfc_resolve_idate (gfc_code *c)
3579 : : {
3580 : 12 : c->resolved_sym
3581 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3582 : : gfc_default_integer_kind));
3583 : 12 : }
3584 : :
3585 : : void
3586 : 12 : gfc_resolve_ltime (gfc_code *c)
3587 : : {
3588 : 12 : c->resolved_sym
3589 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3590 : : gfc_default_integer_kind));
3591 : 12 : }
3592 : :
3593 : : void
3594 : 12 : gfc_resolve_gmtime (gfc_code *c)
3595 : : {
3596 : 12 : c->resolved_sym
3597 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3598 : : gfc_default_integer_kind));
3599 : 12 : }
3600 : :
3601 : :
3602 : : /* G77 compatibility subroutine second(). */
3603 : :
3604 : : void
3605 : 0 : gfc_resolve_second_sub (gfc_code *c)
3606 : : {
3607 : 0 : const char *name;
3608 : 0 : name = gfc_get_string (PREFIX ("second_sub"));
3609 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3610 : 0 : }
3611 : :
3612 : :
3613 : : void
3614 : 19 : gfc_resolve_sleep_sub (gfc_code *c)
3615 : : {
3616 : 19 : const char *name;
3617 : 19 : int kind;
3618 : :
3619 : 19 : if (c->ext.actual->expr != NULL)
3620 : 19 : kind = c->ext.actual->expr->ts.kind;
3621 : : else
3622 : 0 : kind = gfc_default_integer_kind;
3623 : :
3624 : 19 : name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3625 : 19 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3626 : 19 : }
3627 : :
3628 : :
3629 : : /* G77 compatibility function srand(). */
3630 : :
3631 : : void
3632 : 0 : gfc_resolve_srand (gfc_code *c)
3633 : : {
3634 : 0 : const char *name;
3635 : 0 : name = gfc_get_string (PREFIX ("srand"));
3636 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3637 : 0 : }
3638 : :
3639 : :
3640 : : /* Resolve the getarg intrinsic subroutine. */
3641 : :
3642 : : void
3643 : 55 : gfc_resolve_getarg (gfc_code *c)
3644 : : {
3645 : 55 : const char *name;
3646 : :
3647 : 55 : if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3648 : : {
3649 : 9 : gfc_typespec ts;
3650 : 9 : gfc_clear_ts (&ts);
3651 : :
3652 : 9 : ts.type = BT_INTEGER;
3653 : 9 : ts.kind = gfc_default_integer_kind;
3654 : :
3655 : 9 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3656 : : }
3657 : :
3658 : 55 : name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3659 : 55 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3660 : 55 : }
3661 : :
3662 : :
3663 : : /* Resolve the getcwd intrinsic subroutine. */
3664 : :
3665 : : void
3666 : 8 : gfc_resolve_getcwd_sub (gfc_code *c)
3667 : : {
3668 : 8 : const char *name;
3669 : 8 : int kind;
3670 : :
3671 : 8 : if (c->ext.actual->next->expr != NULL)
3672 : 1 : kind = c->ext.actual->next->expr->ts.kind;
3673 : : else
3674 : 7 : kind = gfc_default_integer_kind;
3675 : :
3676 : 8 : name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3677 : 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3678 : 8 : }
3679 : :
3680 : :
3681 : : /* Resolve the get_command intrinsic subroutine. */
3682 : :
3683 : : void
3684 : 3 : gfc_resolve_get_command (gfc_code *c)
3685 : : {
3686 : 3 : const char *name;
3687 : 3 : int kind;
3688 : 3 : kind = gfc_default_integer_kind;
3689 : 3 : name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3690 : 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3691 : 3 : }
3692 : :
3693 : :
3694 : : /* Resolve the get_command_argument intrinsic subroutine. */
3695 : :
3696 : : void
3697 : 4 : gfc_resolve_get_command_argument (gfc_code *c)
3698 : : {
3699 : 4 : const char *name;
3700 : 4 : int kind;
3701 : 4 : kind = gfc_default_integer_kind;
3702 : 4 : name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3703 : 4 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3704 : 4 : }
3705 : :
3706 : :
3707 : : /* Resolve the get_environment_variable intrinsic subroutine. */
3708 : :
3709 : : void
3710 : 26 : gfc_resolve_get_environment_variable (gfc_code *code)
3711 : : {
3712 : 26 : const char *name;
3713 : 26 : int kind;
3714 : 26 : kind = gfc_default_integer_kind;
3715 : 26 : name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3716 : 26 : code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3717 : 26 : }
3718 : :
3719 : :
3720 : : void
3721 : 0 : gfc_resolve_signal_sub (gfc_code *c)
3722 : : {
3723 : 0 : const char *name;
3724 : 0 : gfc_expr *number, *handler, *status;
3725 : 0 : gfc_typespec ts;
3726 : 0 : gfc_clear_ts (&ts);
3727 : :
3728 : 0 : number = c->ext.actual->expr;
3729 : 0 : handler = c->ext.actual->next->expr;
3730 : 0 : status = c->ext.actual->next->next->expr;
3731 : 0 : ts.type = BT_INTEGER;
3732 : 0 : ts.kind = gfc_c_int_kind;
3733 : :
3734 : : /* handler can be either BT_INTEGER or BT_PROCEDURE */
3735 : 0 : if (handler->ts.type == BT_INTEGER)
3736 : : {
3737 : 0 : if (handler->ts.kind != gfc_c_int_kind)
3738 : 0 : gfc_convert_type (handler, &ts, 2);
3739 : 0 : name = gfc_get_string (PREFIX ("signal_sub_int"));
3740 : : }
3741 : : else
3742 : 0 : name = gfc_get_string (PREFIX ("signal_sub"));
3743 : :
3744 : 0 : if (number->ts.kind != gfc_c_int_kind)
3745 : 0 : gfc_convert_type (number, &ts, 2);
3746 : 0 : if (status != NULL && status->ts.kind != gfc_c_int_kind)
3747 : 0 : gfc_convert_type (status, &ts, 2);
3748 : :
3749 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3750 : 0 : }
3751 : :
3752 : :
3753 : : /* Resolve the SYSTEM intrinsic subroutine. */
3754 : :
3755 : : void
3756 : 2 : gfc_resolve_system_sub (gfc_code *c)
3757 : : {
3758 : 2 : const char *name;
3759 : 2 : name = gfc_get_string (PREFIX ("system_sub"));
3760 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3761 : 2 : }
3762 : :
3763 : :
3764 : : /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3765 : :
3766 : : void
3767 : 197 : gfc_resolve_system_clock (gfc_code *c)
3768 : : {
3769 : 197 : const char *name;
3770 : 197 : int kind;
3771 : 197 : gfc_expr *count = c->ext.actual->expr;
3772 : 197 : gfc_expr *count_max = c->ext.actual->next->next->expr;
3773 : :
3774 : : /* The INTEGER(8) version has higher precision, it is used if both COUNT
3775 : : and COUNT_MAX can hold 64-bit values, or are absent. */
3776 : 197 : if ((!count || count->ts.kind >= 8)
3777 : 74 : && (!count_max || count_max->ts.kind >= 8))
3778 : : kind = 8;
3779 : : else
3780 : 159 : kind = gfc_default_integer_kind;
3781 : :
3782 : 197 : name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3783 : 197 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3784 : 197 : }
3785 : :
3786 : :
3787 : : /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3788 : : void
3789 : 20 : gfc_resolve_execute_command_line (gfc_code *c)
3790 : : {
3791 : 20 : const char *name;
3792 : 20 : name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3793 : : gfc_default_integer_kind);
3794 : 20 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3795 : 20 : }
3796 : :
3797 : :
3798 : : /* Resolve the EXIT intrinsic subroutine. */
3799 : :
3800 : : void
3801 : 3 : gfc_resolve_exit (gfc_code *c)
3802 : : {
3803 : 3 : const char *name;
3804 : 3 : gfc_typespec ts;
3805 : 3 : gfc_expr *n;
3806 : 3 : gfc_clear_ts (&ts);
3807 : :
3808 : : /* The STATUS argument has to be of default kind. If it is not,
3809 : : we convert it. */
3810 : 3 : ts.type = BT_INTEGER;
3811 : 3 : ts.kind = gfc_default_integer_kind;
3812 : 3 : n = c->ext.actual->expr;
3813 : 3 : if (n != NULL && n->ts.kind != ts.kind)
3814 : 0 : gfc_convert_type (n, &ts, 2);
3815 : :
3816 : 3 : name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3817 : 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3818 : 3 : }
3819 : :
3820 : :
3821 : : /* Resolve the FLUSH intrinsic subroutine. */
3822 : :
3823 : : void
3824 : 25 : gfc_resolve_flush (gfc_code *c)
3825 : : {
3826 : 25 : const char *name;
3827 : 25 : gfc_typespec ts;
3828 : 25 : gfc_expr *n;
3829 : 25 : gfc_clear_ts (&ts);
3830 : :
3831 : 25 : ts.type = BT_INTEGER;
3832 : 25 : ts.kind = gfc_default_integer_kind;
3833 : 25 : n = c->ext.actual->expr;
3834 : 25 : if (n != NULL && n->ts.kind != ts.kind)
3835 : 0 : gfc_convert_type (n, &ts, 2);
3836 : :
3837 : 25 : name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3838 : 25 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3839 : 25 : }
3840 : :
3841 : :
3842 : : void
3843 : 1 : gfc_resolve_ctime_sub (gfc_code *c)
3844 : : {
3845 : 1 : gfc_typespec ts;
3846 : 1 : gfc_clear_ts (&ts);
3847 : :
3848 : : /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3849 : 1 : if (c->ext.actual->expr->ts.kind != 8)
3850 : : {
3851 : 0 : ts.type = BT_INTEGER;
3852 : 0 : ts.kind = 8;
3853 : 0 : ts.u.derived = NULL;
3854 : 0 : ts.u.cl = NULL;
3855 : 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3856 : : }
3857 : :
3858 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3859 : 1 : }
3860 : :
3861 : :
3862 : : void
3863 : 1 : gfc_resolve_fdate_sub (gfc_code *c)
3864 : : {
3865 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3866 : 1 : }
3867 : :
3868 : :
3869 : : void
3870 : 2 : gfc_resolve_gerror (gfc_code *c)
3871 : : {
3872 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3873 : 2 : }
3874 : :
3875 : :
3876 : : void
3877 : 2 : gfc_resolve_getlog (gfc_code *c)
3878 : : {
3879 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3880 : 2 : }
3881 : :
3882 : :
3883 : : void
3884 : 9 : gfc_resolve_hostnm_sub (gfc_code *c)
3885 : : {
3886 : 9 : const char *name;
3887 : 9 : int kind;
3888 : :
3889 : 9 : if (c->ext.actual->next->expr != NULL)
3890 : 7 : kind = c->ext.actual->next->expr->ts.kind;
3891 : : else
3892 : 2 : kind = gfc_default_integer_kind;
3893 : :
3894 : 9 : name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3895 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3896 : 9 : }
3897 : :
3898 : :
3899 : : void
3900 : 2 : gfc_resolve_perror (gfc_code *c)
3901 : : {
3902 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3903 : 2 : }
3904 : :
3905 : : /* Resolve the STAT and FSTAT intrinsic subroutines. */
3906 : :
3907 : : void
3908 : 14 : gfc_resolve_stat_sub (gfc_code *c)
3909 : : {
3910 : 14 : const char *name;
3911 : 14 : name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3912 : 14 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3913 : 14 : }
3914 : :
3915 : :
3916 : : void
3917 : 8 : gfc_resolve_lstat_sub (gfc_code *c)
3918 : : {
3919 : 8 : const char *name;
3920 : 8 : name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3921 : 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3922 : 8 : }
3923 : :
3924 : :
3925 : : void
3926 : 6 : gfc_resolve_fstat_sub (gfc_code *c)
3927 : : {
3928 : 6 : const char *name;
3929 : 6 : gfc_expr *u;
3930 : 6 : gfc_typespec *ts;
3931 : :
3932 : 6 : u = c->ext.actual->expr;
3933 : 6 : ts = &c->ext.actual->next->expr->ts;
3934 : 6 : if (u->ts.kind != ts->kind)
3935 : 0 : gfc_convert_type (u, ts, 2);
3936 : 6 : name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3937 : 6 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3938 : 6 : }
3939 : :
3940 : :
3941 : : void
3942 : 44 : gfc_resolve_fgetc_sub (gfc_code *c)
3943 : : {
3944 : 44 : const char *name;
3945 : 44 : gfc_typespec ts;
3946 : 44 : gfc_expr *u, *st;
3947 : 44 : gfc_clear_ts (&ts);
3948 : :
3949 : 44 : u = c->ext.actual->expr;
3950 : 44 : st = c->ext.actual->next->next->expr;
3951 : :
3952 : 44 : if (u->ts.kind != gfc_c_int_kind)
3953 : : {
3954 : 0 : ts.type = BT_INTEGER;
3955 : 0 : ts.kind = gfc_c_int_kind;
3956 : 0 : ts.u.derived = NULL;
3957 : 0 : ts.u.cl = NULL;
3958 : 0 : gfc_convert_type (u, &ts, 2);
3959 : : }
3960 : :
3961 : 44 : if (st != NULL)
3962 : 31 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3963 : : else
3964 : 13 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3965 : :
3966 : 44 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3967 : 44 : }
3968 : :
3969 : :
3970 : : void
3971 : 2 : gfc_resolve_fget_sub (gfc_code *c)
3972 : : {
3973 : 2 : const char *name;
3974 : 2 : gfc_expr *st;
3975 : :
3976 : 2 : st = c->ext.actual->next->expr;
3977 : 2 : if (st != NULL)
3978 : 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3979 : : else
3980 : 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3981 : :
3982 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3983 : 2 : }
3984 : :
3985 : :
3986 : : void
3987 : 33 : gfc_resolve_fputc_sub (gfc_code *c)
3988 : : {
3989 : 33 : const char *name;
3990 : 33 : gfc_typespec ts;
3991 : 33 : gfc_expr *u, *st;
3992 : 33 : gfc_clear_ts (&ts);
3993 : :
3994 : 33 : u = c->ext.actual->expr;
3995 : 33 : st = c->ext.actual->next->next->expr;
3996 : :
3997 : 33 : if (u->ts.kind != gfc_c_int_kind)
3998 : : {
3999 : 0 : ts.type = BT_INTEGER;
4000 : 0 : ts.kind = gfc_c_int_kind;
4001 : 0 : ts.u.derived = NULL;
4002 : 0 : ts.u.cl = NULL;
4003 : 0 : gfc_convert_type (u, &ts, 2);
4004 : : }
4005 : :
4006 : 33 : if (st != NULL)
4007 : 25 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
4008 : : else
4009 : 8 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
4010 : :
4011 : 33 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4012 : 33 : }
4013 : :
4014 : :
4015 : : void
4016 : 2 : gfc_resolve_fput_sub (gfc_code *c)
4017 : : {
4018 : 2 : const char *name;
4019 : 2 : gfc_expr *st;
4020 : :
4021 : 2 : st = c->ext.actual->next->expr;
4022 : 2 : if (st != NULL)
4023 : 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
4024 : : else
4025 : 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
4026 : :
4027 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4028 : 2 : }
4029 : :
4030 : :
4031 : : void
4032 : 60 : gfc_resolve_fseek_sub (gfc_code *c)
4033 : : {
4034 : 60 : gfc_expr *unit;
4035 : 60 : gfc_expr *offset;
4036 : 60 : gfc_expr *whence;
4037 : 60 : gfc_typespec ts;
4038 : 60 : gfc_clear_ts (&ts);
4039 : :
4040 : 60 : unit = c->ext.actual->expr;
4041 : 60 : offset = c->ext.actual->next->expr;
4042 : 60 : whence = c->ext.actual->next->next->expr;
4043 : :
4044 : 60 : if (unit->ts.kind != gfc_c_int_kind)
4045 : : {
4046 : 0 : ts.type = BT_INTEGER;
4047 : 0 : ts.kind = gfc_c_int_kind;
4048 : 0 : ts.u.derived = NULL;
4049 : 0 : ts.u.cl = NULL;
4050 : 0 : gfc_convert_type (unit, &ts, 2);
4051 : : }
4052 : :
4053 : 60 : if (offset->ts.kind != gfc_intio_kind)
4054 : : {
4055 : 60 : ts.type = BT_INTEGER;
4056 : 60 : ts.kind = gfc_intio_kind;
4057 : 60 : ts.u.derived = NULL;
4058 : 60 : ts.u.cl = NULL;
4059 : 60 : gfc_convert_type (offset, &ts, 2);
4060 : : }
4061 : :
4062 : 60 : if (whence->ts.kind != gfc_c_int_kind)
4063 : : {
4064 : 0 : ts.type = BT_INTEGER;
4065 : 0 : ts.kind = gfc_c_int_kind;
4066 : 0 : ts.u.derived = NULL;
4067 : 0 : ts.u.cl = NULL;
4068 : 0 : gfc_convert_type (whence, &ts, 2);
4069 : : }
4070 : :
4071 : 60 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
4072 : 60 : }
4073 : :
4074 : : void
4075 : 36 : gfc_resolve_ftell_sub (gfc_code *c)
4076 : : {
4077 : 36 : const char *name;
4078 : 36 : gfc_expr *unit;
4079 : 36 : gfc_expr *offset;
4080 : 36 : gfc_typespec ts;
4081 : 36 : gfc_clear_ts (&ts);
4082 : :
4083 : 36 : unit = c->ext.actual->expr;
4084 : 36 : offset = c->ext.actual->next->expr;
4085 : :
4086 : 36 : if (unit->ts.kind != gfc_c_int_kind)
4087 : : {
4088 : 0 : ts.type = BT_INTEGER;
4089 : 0 : ts.kind = gfc_c_int_kind;
4090 : 0 : ts.u.derived = NULL;
4091 : 0 : ts.u.cl = NULL;
4092 : 0 : gfc_convert_type (unit, &ts, 2);
4093 : : }
4094 : :
4095 : 36 : name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4096 : 36 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4097 : 36 : }
4098 : :
4099 : :
4100 : : void
4101 : 1 : gfc_resolve_ttynam_sub (gfc_code *c)
4102 : : {
4103 : 1 : gfc_typespec ts;
4104 : 1 : gfc_clear_ts (&ts);
4105 : :
4106 : 1 : if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4107 : : {
4108 : 0 : ts.type = BT_INTEGER;
4109 : 0 : ts.kind = gfc_c_int_kind;
4110 : 0 : ts.u.derived = NULL;
4111 : 0 : ts.u.cl = NULL;
4112 : 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4113 : : }
4114 : :
4115 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4116 : 1 : }
4117 : :
4118 : :
4119 : : /* Resolve the UMASK intrinsic subroutine. */
4120 : :
4121 : : void
4122 : 0 : gfc_resolve_umask_sub (gfc_code *c)
4123 : : {
4124 : 0 : const char *name;
4125 : 0 : int kind;
4126 : :
4127 : 0 : if (c->ext.actual->next->expr != NULL)
4128 : 0 : kind = c->ext.actual->next->expr->ts.kind;
4129 : : else
4130 : 0 : kind = gfc_default_integer_kind;
4131 : :
4132 : 0 : name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4133 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4134 : 0 : }
4135 : :
4136 : : /* Resolve the UNLINK intrinsic subroutine. */
4137 : :
4138 : : void
4139 : 10 : gfc_resolve_unlink_sub (gfc_code *c)
4140 : : {
4141 : 10 : const char *name;
4142 : 10 : int kind;
4143 : :
4144 : 10 : if (c->ext.actual->next->expr != NULL)
4145 : 1 : kind = c->ext.actual->next->expr->ts.kind;
4146 : : else
4147 : 9 : kind = gfc_default_integer_kind;
4148 : :
4149 : 10 : name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4150 : 10 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4151 : 10 : }
|
