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