Branch data Line data Source code
1 : : /* Intrinsic function resolution.
2 : : Copyright (C) 2000-2023 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 : 57606010 : gfc_get_string (const char *format, ...)
49 : : {
50 : : /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */
51 : 57606010 : char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1];
52 : 57606010 : const char *str;
53 : 57606010 : va_list ap;
54 : 57606010 : tree ident;
55 : :
56 : : /* Handle common case without vsnprintf and temporary buffer. */
57 : 57606010 : if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
58 : : {
59 : 49634423 : va_start (ap, format);
60 : 49634423 : str = va_arg (ap, const char *);
61 : 49634423 : va_end (ap);
62 : : }
63 : : else
64 : : {
65 : 7971587 : int ret;
66 : 7971587 : va_start (ap, format);
67 : 7971587 : ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
68 : 7971587 : va_end (ap);
69 : 7971587 : if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
70 : 0 : gfc_internal_error ("identifier overflow: %d", ret);
71 : 7971587 : temp_name[sizeof (temp_name) - 1] = 0;
72 : 7971587 : str = temp_name;
73 : : }
74 : :
75 : 57606010 : ident = get_identifier (str);
76 : 57606010 : 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 : 13630 : resolve_mask_arg (gfc_expr *mask)
110 : : {
111 : :
112 : 13630 : gfc_typespec ts;
113 : 13630 : gfc_clear_ts (&ts);
114 : :
115 : 13630 : 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 : 4423 : 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 : 9207 : 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 : 13630 : }
141 : :
142 : :
143 : : static void
144 : 27821 : resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
145 : : const char *name, bool coarray)
146 : : {
147 : 27821 : f->ts.type = BT_INTEGER;
148 : 27821 : if (kind)
149 : 4112 : f->ts.kind = mpz_get_si (kind->value.integer);
150 : : else
151 : 23709 : f->ts.kind = gfc_default_integer_kind;
152 : :
153 : 27821 : if (dim == NULL)
154 : : {
155 : 4118 : f->rank = 1;
156 : 4118 : if (array->rank != -1)
157 : : {
158 : 2634 : f->shape = gfc_get_shape (1);
159 : 4830 : mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
160 : 2196 : : array->rank);
161 : : }
162 : : }
163 : :
164 : 27821 : f->value.function.name = gfc_get_string ("%s", name);
165 : 27821 : }
166 : :
167 : :
168 : : static void
169 : 5447 : resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
170 : : gfc_expr *dim, gfc_expr *mask)
171 : : {
172 : 5447 : const char *prefix;
173 : :
174 : 5447 : f->ts = array->ts;
175 : :
176 : 5447 : if (mask)
177 : : {
178 : 762 : if (mask->rank == 0)
179 : : prefix = "s";
180 : : else
181 : 521 : prefix = "m";
182 : :
183 : 762 : resolve_mask_arg (mask);
184 : : }
185 : : else
186 : : prefix = "";
187 : :
188 : 5447 : if (dim != NULL)
189 : : {
190 : 2043 : f->rank = array->rank - 1;
191 : 2043 : f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
192 : 2043 : gfc_resolve_dim_arg (dim);
193 : : }
194 : :
195 : 5447 : f->value.function.name
196 : 10894 : = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
197 : 5447 : gfc_type_letter (array->ts.type),
198 : : gfc_type_abi_kind (&array->ts));
199 : 5447 : }
200 : :
201 : :
202 : : /********************** Resolution functions **********************/
203 : :
204 : :
205 : : void
206 : 23619 : gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
207 : : {
208 : 23619 : f->ts = a->ts;
209 : 23619 : if (f->ts.type == BT_COMPLEX)
210 : 2943 : f->ts.type = BT_REAL;
211 : :
212 : 23619 : f->value.function.name
213 : 23619 : = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type),
214 : : gfc_type_abi_kind (&a->ts));
215 : 23619 : }
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 : 1121 : gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
230 : : {
231 : 1121 : f->ts.type = BT_CHARACTER;
232 : 1121 : f->ts.kind = string->ts.kind;
233 : 1121 : if (string->ts.deferred)
234 : 60 : f->ts = string->ts;
235 : 1061 : else if (string->ts.u.cl)
236 : 1061 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
237 : :
238 : 1121 : f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
239 : 1121 : }
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 : 1590 : gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
302 : : {
303 : 1590 : f->ts.type = BT_REAL;
304 : 1590 : f->ts.kind = x->ts.kind;
305 : 1590 : f->value.function.name
306 : 1590 : = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
307 : : gfc_type_abi_kind (&x->ts));
308 : 1590 : }
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 : 1184 : gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
363 : : {
364 : 1184 : f->ts = mask->ts;
365 : :
366 : 1184 : 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 : 1184 : f->value.function.name
374 : 1184 : = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
375 : : gfc_type_abi_kind (&mask->ts));
376 : 1184 : }
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 : 30428 : gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
412 : : {
413 : 30428 : f->ts = mask->ts;
414 : :
415 : 30428 : if (dim != NULL)
416 : : {
417 : 133 : gfc_resolve_dim_arg (dim);
418 : 133 : f->rank = mask->rank - 1;
419 : 133 : f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
420 : : }
421 : :
422 : 30428 : f->value.function.name
423 : 30428 : = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
424 : : gfc_type_abi_kind (&mask->ts));
425 : 30428 : }
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 : 5812 : gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
544 : : {
545 : 5812 : f->ts = f->value.function.isym->ts;
546 : 5812 : }
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 : 1565 : gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
629 : : {
630 : 1565 : f->ts.type = BT_COMPLEX;
631 : 1565 : f->ts.kind = (kind == NULL)
632 : 1217 : ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
633 : :
634 : 1565 : 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 : 1392 : f->value.function.name
641 : 4176 : = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
642 : 1392 : gfc_type_letter (x->ts.type),
643 : : gfc_type_abi_kind (&x->ts),
644 : 1392 : gfc_type_letter (y->ts.type),
645 : : gfc_type_abi_kind (&y->ts));
646 : 1565 : }
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 : 355 : gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
718 : : {
719 : 355 : f->ts.type = BT_INTEGER;
720 : 355 : if (kind)
721 : 5 : f->ts.kind = mpz_get_si (kind->value.integer);
722 : : else
723 : 350 : f->ts.kind = gfc_default_integer_kind;
724 : :
725 : 355 : if (dim != NULL)
726 : : {
727 : 124 : f->rank = mask->rank - 1;
728 : 124 : gfc_resolve_dim_arg (dim);
729 : 124 : f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
730 : : }
731 : :
732 : 355 : resolve_mask_arg (mask);
733 : :
734 : 355 : f->value.function.name
735 : 355 : = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts),
736 : 355 : gfc_type_letter (mask->ts.type));
737 : 355 : }
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 : 133 : gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1174 : : {
1175 : 133 : resolve_transformational ("iall", f, array, dim, mask);
1176 : 133 : }
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 : 84 : gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1200 : : {
1201 : 84 : resolve_transformational ("iany", f, array, dim, mask);
1202 : 84 : }
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 : 3569 : gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1338 : : {
1339 : 3569 : f->ts.type = BT_INTEGER;
1340 : 3569 : f->ts.kind = (kind == NULL)
1341 : 3003 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1342 : 3569 : f->value.function.name
1343 : 7138 : = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1344 : 3569 : gfc_type_letter (a->ts.type),
1345 : : gfc_type_abi_kind (&a->ts));
1346 : 3569 : }
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 : 84 : gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1387 : : {
1388 : 84 : resolve_transformational ("iparity", f, array, dim, mask);
1389 : 84 : }
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 : 827 : gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
1415 : : {
1416 : 827 : f->ts.type = BT_LOGICAL;
1417 : 827 : f->ts.kind = gfc_default_logical_kind;
1418 : 827 : f->value.function.name = gfc_get_string ("__is_contiguous");
1419 : 827 : }
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 : 1266 : gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1451 : : {
1452 : 1266 : int s_kind;
1453 : :
1454 : 1266 : s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1455 : :
1456 : 1266 : f->ts = i->ts;
1457 : 1266 : f->value.function.name
1458 : 1266 : = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1459 : 1266 : }
1460 : :
1461 : :
1462 : : void
1463 : 14790 : gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1464 : : {
1465 : 14790 : resolve_bound (f, array, dim, kind, "__lbound", false);
1466 : 14790 : }
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 : 11130 : gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1478 : : {
1479 : 11130 : f->ts.type = BT_INTEGER;
1480 : 11130 : if (kind)
1481 : 224 : f->ts.kind = mpz_get_si (kind->value.integer);
1482 : : else
1483 : 10906 : f->ts.kind = gfc_default_integer_kind;
1484 : 11130 : f->value.function.name
1485 : 11130 : = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1486 : : gfc_default_integer_kind);
1487 : 11130 : }
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 : 6785 : gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1523 : : {
1524 : 6785 : f->ts.type= BT_INTEGER;
1525 : 6785 : f->ts.kind = gfc_index_integer_kind;
1526 : 6785 : f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1527 : 6785 : }
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 : 3586 : gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1661 : : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1662 : : {
1663 : 3586 : const char *name;
1664 : 3586 : int i, j, idim;
1665 : 3586 : int fkind;
1666 : 3586 : int d_num;
1667 : :
1668 : 3586 : 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 : 3586 : if (kind)
1673 : 16 : fkind = mpz_get_si (kind->value.integer);
1674 : : else
1675 : 3570 : fkind = gfc_default_integer_kind;
1676 : :
1677 : 3586 : if (fkind < MINMAXLOC_MIN_KIND)
1678 : 8 : f->ts.kind = MINMAXLOC_MIN_KIND;
1679 : : else
1680 : 3578 : f->ts.kind = fkind;
1681 : :
1682 : 3586 : 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 : 2101 : f->rank = array->rank - 1;
1691 : 2101 : gfc_resolve_dim_arg (dim);
1692 : 2101 : 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 : 3586 : if (mask)
1706 : : {
1707 : 2632 : if (mask->rank == 0)
1708 : : name = "smaxloc";
1709 : : else
1710 : 1432 : name = "mmaxloc";
1711 : :
1712 : 2632 : resolve_mask_arg (mask);
1713 : : }
1714 : : else
1715 : : name = "maxloc";
1716 : :
1717 : 3586 : if (dim)
1718 : : {
1719 : 2101 : if (array->ts.type != BT_CHARACTER || f->rank != 0)
1720 : : d_num = 1;
1721 : : else
1722 : 3586 : d_num = 2;
1723 : : }
1724 : : else
1725 : : d_num = 0;
1726 : :
1727 : 3586 : f->value.function.name
1728 : 7172 : = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1729 : 3586 : gfc_type_letter (array->ts.type),
1730 : : gfc_type_abi_kind (&array->ts));
1731 : :
1732 : 3586 : if (kind)
1733 : 16 : fkind = mpz_get_si (kind->value.integer);
1734 : : else
1735 : 3570 : fkind = gfc_default_integer_kind;
1736 : :
1737 : 3586 : 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 : 3586 : 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 : 3586 : }
1756 : :
1757 : :
1758 : : void
1759 : 1005 : 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 : 1005 : const char *name;
1764 : 1005 : int i, j, idim;
1765 : 1005 : int fkind;
1766 : 1005 : int d_num;
1767 : :
1768 : : /* See at the end of the function for why this is necessary. */
1769 : :
1770 : 1005 : if (f->do_not_resolve_again)
1771 : : return;
1772 : :
1773 : 548 : f->ts.type = BT_INTEGER;
1774 : :
1775 : : /* We have a single library version, which uses index_type. */
1776 : :
1777 : 548 : if (kind)
1778 : 0 : fkind = mpz_get_si (kind->value.integer);
1779 : : else
1780 : 548 : fkind = gfc_default_integer_kind;
1781 : :
1782 : 548 : 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 : 548 : if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
1788 : 536 : || array->ts.kind != value->ts.kind)
1789 : 12 : gfc_convert_type_warn (value, &array->ts, 2, 0);
1790 : :
1791 : 548 : 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 : 384 : f->rank = array->rank - 1;
1800 : 384 : gfc_resolve_dim_arg (dim);
1801 : 384 : 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 : 548 : if (mask)
1815 : : {
1816 : 276 : if (mask->rank == 0)
1817 : : name = "sfindloc";
1818 : : else
1819 : 186 : name = "mfindloc";
1820 : :
1821 : 276 : resolve_mask_arg (mask);
1822 : : }
1823 : : else
1824 : : name = "findloc";
1825 : :
1826 : 548 : if (dim)
1827 : : {
1828 : 384 : if (f->rank > 0)
1829 : : d_num = 1;
1830 : : else
1831 : 156 : d_num = 2;
1832 : : }
1833 : : else
1834 : : d_num = 0;
1835 : :
1836 : 548 : 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 : 548 : f->value.function.name
1846 : 1096 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1847 : 548 : 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 : 548 : if (f->ts.kind != fkind)
1856 : : {
1857 : 548 : f->do_not_resolve_again = 1;
1858 : 548 : gfc_typespec ts;
1859 : 548 : gfc_clear_ts (&ts);
1860 : :
1861 : 548 : ts.type = BT_INTEGER;
1862 : 548 : ts.kind = fkind;
1863 : 548 : gfc_convert_type_warn (f, &ts, 2, 0);
1864 : : }
1865 : :
1866 : : }
1867 : :
1868 : : void
1869 : 2641 : gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1870 : : gfc_expr *mask)
1871 : : {
1872 : 2641 : const char *name;
1873 : 2641 : int i, j, idim;
1874 : :
1875 : 2641 : f->ts = array->ts;
1876 : :
1877 : 2641 : if (dim != NULL)
1878 : : {
1879 : 1811 : f->rank = array->rank - 1;
1880 : 1811 : gfc_resolve_dim_arg (dim);
1881 : :
1882 : 1811 : 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 : 2641 : if (mask)
1896 : : {
1897 : 1809 : if (mask->rank == 0)
1898 : : name = "smaxval";
1899 : : else
1900 : 1101 : name = "mmaxval";
1901 : :
1902 : 1809 : resolve_mask_arg (mask);
1903 : : }
1904 : : else
1905 : : name = "maxval";
1906 : :
1907 : 2641 : if (array->ts.type != BT_CHARACTER)
1908 : 2317 : f->value.function.name
1909 : 4634 : = gfc_get_string (PREFIX ("%s_%c%d"), name,
1910 : 2317 : gfc_type_letter (array->ts.type),
1911 : : gfc_type_abi_kind (&array->ts));
1912 : : else
1913 : 324 : f->value.function.name
1914 : 648 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1915 : 324 : gfc_type_letter (array->ts.type),
1916 : : gfc_type_abi_kind (&array->ts));
1917 : 2641 : }
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 : 5241 : gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1993 : : gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1994 : : {
1995 : 5241 : const char *name;
1996 : 5241 : int i, j, idim;
1997 : 5241 : int fkind;
1998 : 5241 : int d_num;
1999 : :
2000 : 5241 : 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 : 5241 : if (kind)
2005 : 4 : fkind = mpz_get_si (kind->value.integer);
2006 : : else
2007 : 5237 : fkind = gfc_default_integer_kind;
2008 : :
2009 : 5241 : if (fkind < MINMAXLOC_MIN_KIND)
2010 : 2 : f->ts.kind = MINMAXLOC_MIN_KIND;
2011 : : else
2012 : 5239 : f->ts.kind = fkind;
2013 : :
2014 : 5241 : 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 : 2790 : f->rank = array->rank - 1;
2023 : 2790 : gfc_resolve_dim_arg (dim);
2024 : 2790 : 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 : 5241 : if (mask)
2038 : : {
2039 : 3757 : if (mask->rank == 0)
2040 : : name = "sminloc";
2041 : : else
2042 : 2587 : name = "mminloc";
2043 : :
2044 : 3757 : resolve_mask_arg (mask);
2045 : : }
2046 : : else
2047 : : name = "minloc";
2048 : :
2049 : 5241 : if (dim)
2050 : : {
2051 : 2790 : if (array->ts.type != BT_CHARACTER || f->rank != 0)
2052 : : d_num = 1;
2053 : : else
2054 : 5241 : d_num = 2;
2055 : : }
2056 : : else
2057 : : d_num = 0;
2058 : :
2059 : 5241 : f->value.function.name
2060 : 10482 : = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2061 : 5241 : gfc_type_letter (array->ts.type),
2062 : : gfc_type_abi_kind (&array->ts));
2063 : :
2064 : 5241 : 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 : 5241 : 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 : 5241 : }
2083 : :
2084 : :
2085 : : void
2086 : 3745 : gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2087 : : gfc_expr *mask)
2088 : : {
2089 : 3745 : const char *name;
2090 : 3745 : int i, j, idim;
2091 : :
2092 : 3745 : f->ts = array->ts;
2093 : :
2094 : 3745 : if (dim != NULL)
2095 : : {
2096 : 2637 : f->rank = array->rank - 1;
2097 : 2637 : gfc_resolve_dim_arg (dim);
2098 : :
2099 : 2637 : 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 : 3745 : if (mask)
2113 : : {
2114 : 2667 : if (mask->rank == 0)
2115 : : name = "sminval";
2116 : : else
2117 : 2001 : name = "mminval";
2118 : :
2119 : 2667 : resolve_mask_arg (mask);
2120 : : }
2121 : : else
2122 : : name = "minval";
2123 : :
2124 : 3745 : if (array->ts.type != BT_CHARACTER)
2125 : 3427 : f->value.function.name
2126 : 6854 : = gfc_get_string (PREFIX ("%s_%c%d"), name,
2127 : 3427 : gfc_type_letter (array->ts.type),
2128 : : gfc_type_abi_kind (&array->ts));
2129 : : else
2130 : 318 : f->value.function.name
2131 : 636 : = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2132 : 318 : gfc_type_letter (array->ts.type),
2133 : : gfc_type_abi_kind (&array->ts));
2134 : 3745 : }
2135 : :
2136 : :
2137 : : void
2138 : 3479 : gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2139 : : {
2140 : 3479 : f->ts.type = a->ts.type;
2141 : 3479 : if (p != NULL)
2142 : 3431 : f->ts.kind = gfc_kind_max (a,p);
2143 : : else
2144 : 48 : f->ts.kind = a->ts.kind;
2145 : :
2146 : 3479 : if (p != NULL && a->ts.kind != p->ts.kind)
2147 : : {
2148 : 59 : if (a->ts.kind == gfc_kind_max (a,p))
2149 : 59 : gfc_convert_type (p, &a->ts, 2);
2150 : : else
2151 : 0 : gfc_convert_type (a, &p->ts, 2);
2152 : : }
2153 : :
2154 : 3479 : f->value.function.name
2155 : 3479 : = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type),
2156 : : gfc_type_abi_kind (&f->ts));
2157 : 3479 : }
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 : 384 : gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2196 : : {
2197 : 384 : f->ts.type = BT_INTEGER;
2198 : 384 : f->ts.kind = (kind == NULL)
2199 : 48 : ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2200 : 384 : f->value.function.name
2201 : 384 : = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2202 : 384 : }
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 : 643 : gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2286 : : gfc_expr *mask)
2287 : : {
2288 : 643 : resolve_transformational ("product", f, array, dim, mask);
2289 : 643 : }
2290 : :
2291 : :
2292 : : void
2293 : 1426 : gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2294 : : {
2295 : 1426 : f->ts.type = BT_INTEGER;
2296 : 1426 : f->ts.kind = gfc_default_integer_kind;
2297 : 1426 : f->value.function.name = gfc_get_string ("__rank");
2298 : 1426 : }
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 : 858 : gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2343 : : gfc_expr *ncopies)
2344 : : {
2345 : 858 : gfc_expr *tmp;
2346 : 858 : f->ts.type = BT_CHARACTER;
2347 : 858 : f->ts.kind = string->ts.kind;
2348 : 858 : f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2349 : :
2350 : : /* If possible, generate a character length. */
2351 : 858 : if (f->ts.u.cl == NULL)
2352 : 500 : f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2353 : :
2354 : 858 : tmp = NULL;
2355 : 858 : if (string->expr_type == EXPR_CONSTANT)
2356 : : {
2357 : 285 : 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 : 780 : if (tmp)
2366 : 780 : f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2367 : 858 : }
2368 : :
2369 : :
2370 : : void
2371 : 1641 : gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2372 : : gfc_expr *pad ATTRIBUTE_UNUSED,
2373 : : gfc_expr *order ATTRIBUTE_UNUSED)
2374 : : {
2375 : 1641 : mpz_t rank;
2376 : 1641 : int kind;
2377 : 1641 : int i;
2378 : :
2379 : 1641 : if (source->ts.type == BT_CHARACTER && source->ref)
2380 : 272 : gfc_resolve_substring_charlen (source);
2381 : :
2382 : 1641 : f->ts = source->ts;
2383 : :
2384 : 1641 : gfc_array_size (shape, &rank);
2385 : 1641 : f->rank = mpz_get_si (rank);
2386 : 1641 : mpz_clear (rank);
2387 : 1641 : switch (source->ts.type)
2388 : : {
2389 : 1593 : case BT_COMPLEX:
2390 : 1593 : case BT_REAL:
2391 : 1593 : case BT_INTEGER:
2392 : 1593 : case BT_LOGICAL:
2393 : 1593 : case BT_CHARACTER:
2394 : 1593 : kind = source->ts.kind;
2395 : 1593 : break;
2396 : :
2397 : : default:
2398 : : kind = 0;
2399 : : break;
2400 : : }
2401 : :
2402 : 1593 : switch (kind)
2403 : : {
2404 : 1301 : case 4:
2405 : 1301 : case 8:
2406 : 1301 : case 10:
2407 : 1301 : case 16:
2408 : 1301 : if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2409 : 267 : f->value.function.name
2410 : 534 : = gfc_get_string (PREFIX ("reshape_%c%d"),
2411 : 267 : gfc_type_letter (source->ts.type),
2412 : : gfc_type_abi_kind (&source->ts));
2413 : 1034 : else if (source->ts.type == BT_CHARACTER)
2414 : 12 : f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2415 : : kind);
2416 : : else
2417 : 1022 : f->value.function.name
2418 : 1022 : = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2419 : : break;
2420 : :
2421 : 340 : default:
2422 : 680 : f->value.function.name = (source->ts.type == BT_CHARACTER
2423 : 340 : ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2424 : 340 : break;
2425 : : }
2426 : :
2427 : 1641 : if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
2428 : : {
2429 : 1378 : gfc_constructor *c;
2430 : 1378 : f->shape = gfc_get_shape (f->rank);
2431 : 1378 : c = gfc_constructor_first (shape->value.constructor);
2432 : 5950 : for (i = 0; i < f->rank; i++)
2433 : : {
2434 : 3194 : mpz_init_set (f->shape[i], c->expr->value.integer);
2435 : 3194 : c = gfc_constructor_next (c);
2436 : : }
2437 : : }
2438 : :
2439 : : /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2440 : : so many runtime variations. */
2441 : 1641 : if (shape->ts.kind != gfc_index_integer_kind)
2442 : : {
2443 : 1142 : gfc_typespec ts = shape->ts;
2444 : 1142 : ts.kind = gfc_index_integer_kind;
2445 : 1142 : gfc_convert_type_warn (shape, &ts, 2, 0);
2446 : : }
2447 : 1641 : if (order && order->ts.kind != gfc_index_integer_kind)
2448 : 110 : gfc_convert_type_warn (order, &shape->ts, 2, 0);
2449 : 1641 : }
2450 : :
2451 : :
2452 : : void
2453 : 132 : gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2454 : : {
2455 : 132 : f->ts = x->ts;
2456 : 132 : f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2457 : 132 : }
2458 : :
2459 : : void
2460 : 401 : gfc_resolve_fe_runtime_error (gfc_code *c)
2461 : : {
2462 : 401 : const char *name;
2463 : 401 : gfc_actual_arglist *a;
2464 : :
2465 : 401 : name = gfc_get_string (PREFIX ("runtime_error"));
2466 : :
2467 : 1203 : for (a = c->ext.actual->next; a; a = a->next)
2468 : 802 : a->name = "%VAL";
2469 : :
2470 : 401 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2471 : : /* We set the backend_decl here because runtime_error is a
2472 : : variadic function and we would use the wrong calling
2473 : : convention otherwise. */
2474 : 401 : c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2475 : 401 : }
2476 : :
2477 : : void
2478 : 156 : gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2479 : : {
2480 : 156 : f->ts = x->ts;
2481 : 156 : f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2482 : 156 : }
2483 : :
2484 : :
2485 : : void
2486 : 814 : gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2487 : : gfc_expr *set ATTRIBUTE_UNUSED,
2488 : : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2489 : : {
2490 : 814 : f->ts.type = BT_INTEGER;
2491 : 814 : if (kind)
2492 : 232 : f->ts.kind = mpz_get_si (kind->value.integer);
2493 : : else
2494 : 582 : f->ts.kind = gfc_default_integer_kind;
2495 : 814 : f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2496 : 814 : }
2497 : :
2498 : :
2499 : : void
2500 : 52 : gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2501 : : {
2502 : 52 : t1->ts = t0->ts;
2503 : 52 : t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2504 : 52 : }
2505 : :
2506 : :
2507 : : void
2508 : 620 : gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2509 : : gfc_expr *i ATTRIBUTE_UNUSED)
2510 : : {
2511 : 620 : f->ts = x->ts;
2512 : 620 : f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2513 : 620 : }
2514 : :
2515 : :
2516 : : void
2517 : 2329 : gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2518 : : {
2519 : 2329 : f->ts.type = BT_INTEGER;
2520 : :
2521 : 2329 : if (kind)
2522 : 57 : f->ts.kind = mpz_get_si (kind->value.integer);
2523 : : else
2524 : 2272 : f->ts.kind = gfc_default_integer_kind;
2525 : :
2526 : 2329 : f->rank = 1;
2527 : 2329 : if (array->rank != -1)
2528 : : {
2529 : 1477 : f->shape = gfc_get_shape (1);
2530 : 1477 : mpz_init_set_ui (f->shape[0], array->rank);
2531 : : }
2532 : :
2533 : 2329 : f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2534 : 2329 : }
2535 : :
2536 : :
2537 : : void
2538 : 534 : gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2539 : : {
2540 : 534 : f->ts = i->ts;
2541 : 534 : if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2542 : 102 : f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2543 : 432 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2544 : 348 : f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2545 : 84 : else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2546 : 84 : f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2547 : : else
2548 : 0 : gcc_unreachable ();
2549 : 534 : }
2550 : :
2551 : :
2552 : : void
2553 : 1373 : gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2554 : : {
2555 : 1373 : f->ts = a->ts;
2556 : 1373 : f->value.function.name
2557 : 1373 : = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type),
2558 : : gfc_type_abi_kind (&a->ts));
2559 : 1373 : }
2560 : :
2561 : :
2562 : : void
2563 : 1 : gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2564 : : {
2565 : 1 : f->ts.type = BT_INTEGER;
2566 : 1 : f->ts.kind = gfc_c_int_kind;
2567 : :
2568 : : /* handler can be either BT_INTEGER or BT_PROCEDURE */
2569 : 1 : if (handler->ts.type == BT_INTEGER)
2570 : : {
2571 : 0 : if (handler->ts.kind != gfc_c_int_kind)
2572 : 0 : gfc_convert_type (handler, &f->ts, 2);
2573 : 0 : f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2574 : : }
2575 : : else
2576 : 1 : f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2577 : :
2578 : 1 : if (number->ts.kind != gfc_c_int_kind)
2579 : 0 : gfc_convert_type (number, &f->ts, 2);
2580 : 1 : }
2581 : :
2582 : :
2583 : : void
2584 : 808 : gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2585 : : {
2586 : 808 : f->ts = x->ts;
2587 : 808 : f->value.function.name
2588 : 808 : = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type),
2589 : : gfc_type_abi_kind (&x->ts));
2590 : 808 : }
2591 : :
2592 : :
2593 : : void
2594 : 302 : gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2595 : : {
2596 : 302 : f->ts = x->ts;
2597 : 302 : f->value.function.name
2598 : 302 : = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type),
2599 : : gfc_type_abi_kind (&x->ts));
2600 : 302 : }
2601 : :
2602 : :
2603 : : void
2604 : 23826 : gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2605 : : gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2606 : : {
2607 : 23826 : f->ts.type = BT_INTEGER;
2608 : 23826 : if (kind)
2609 : 5347 : f->ts.kind = mpz_get_si (kind->value.integer);
2610 : : else
2611 : 18479 : f->ts.kind = gfc_default_integer_kind;
2612 : 23826 : }
2613 : :
2614 : :
2615 : : void
2616 : 0 : gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2617 : : gfc_expr *dim ATTRIBUTE_UNUSED)
2618 : : {
2619 : 0 : f->ts.type = BT_INTEGER;
2620 : 0 : f->ts.kind = gfc_index_integer_kind;
2621 : 0 : }
2622 : :
2623 : :
2624 : : void
2625 : 213 : gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2626 : : {
2627 : 213 : f->ts = x->ts;
2628 : 213 : f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2629 : 213 : }
2630 : :
2631 : :
2632 : : void
2633 : 710 : gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2634 : : gfc_expr *ncopies)
2635 : : {
2636 : 710 : if (source->ts.type == BT_CHARACTER && source->ref)
2637 : 84 : gfc_resolve_substring_charlen (source);
2638 : :
2639 : 710 : if (source->ts.type == BT_CHARACTER)
2640 : 123 : check_charlen_present (source);
2641 : :
2642 : 710 : f->ts = source->ts;
2643 : 710 : f->rank = source->rank + 1;
2644 : 710 : if (source->rank == 0)
2645 : : {
2646 : 63 : if (source->ts.type == BT_CHARACTER)
2647 : 39 : f->value.function.name
2648 : 39 : = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2649 : : : gfc_get_string
2650 : 0 : (PREFIX ("spread_char%d_scalar"),
2651 : : source->ts.kind);
2652 : : else
2653 : 24 : f->value.function.name = PREFIX ("spread_scalar");
2654 : : }
2655 : : else
2656 : : {
2657 : 647 : if (source->ts.type == BT_CHARACTER)
2658 : 84 : f->value.function.name
2659 : 132 : = source->ts.kind == 1 ? PREFIX ("spread_char")
2660 : : : gfc_get_string
2661 : 48 : (PREFIX ("spread_char%d"),
2662 : : source->ts.kind);
2663 : : else
2664 : 563 : f->value.function.name = PREFIX ("spread");
2665 : : }
2666 : :
2667 : 710 : if (dim && gfc_is_constant_expr (dim)
2668 : 1420 : && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2669 : : {
2670 : 442 : int i, idim;
2671 : 442 : idim = mpz_get_ui (dim->value.integer);
2672 : 442 : f->shape = gfc_get_shape (f->rank);
2673 : 464 : for (i = 0; i < (idim - 1); i++)
2674 : 22 : mpz_init_set (f->shape[i], source->shape[i]);
2675 : :
2676 : 442 : mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2677 : :
2678 : 1694 : for (i = idim; i < f->rank ; i++)
2679 : 810 : mpz_init_set (f->shape[i], source->shape[i-1]);
2680 : : }
2681 : :
2682 : :
2683 : 710 : gfc_resolve_dim_arg (dim);
2684 : 710 : gfc_resolve_index (ncopies, 1);
2685 : 710 : }
2686 : :
2687 : :
2688 : : void
2689 : 1222 : gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2690 : : {
2691 : 1222 : f->ts = x->ts;
2692 : 1222 : f->value.function.name
2693 : 1222 : = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type),
2694 : : gfc_type_abi_kind (&x->ts));
2695 : 1222 : }
2696 : :
2697 : :
2698 : : /* Resolve the g77 compatibility function STAT AND FSTAT. */
2699 : :
2700 : : void
2701 : 13 : gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2702 : : gfc_expr *a ATTRIBUTE_UNUSED)
2703 : : {
2704 : 13 : f->ts.type = BT_INTEGER;
2705 : 13 : f->ts.kind = gfc_default_integer_kind;
2706 : 13 : f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2707 : 13 : }
2708 : :
2709 : :
2710 : : void
2711 : 7 : gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2712 : : gfc_expr *a ATTRIBUTE_UNUSED)
2713 : : {
2714 : 7 : f->ts.type = BT_INTEGER;
2715 : 7 : f->ts.kind = gfc_default_integer_kind;
2716 : 7 : f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2717 : 7 : }
2718 : :
2719 : :
2720 : : void
2721 : 6 : gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2722 : : {
2723 : 6 : f->ts.type = BT_INTEGER;
2724 : 6 : f->ts.kind = gfc_default_integer_kind;
2725 : 6 : if (n->ts.kind != f->ts.kind)
2726 : 0 : gfc_convert_type (n, &f->ts, 2);
2727 : :
2728 : 6 : f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2729 : 6 : }
2730 : :
2731 : :
2732 : : void
2733 : 43 : gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2734 : : {
2735 : 43 : gfc_typespec ts;
2736 : 43 : gfc_clear_ts (&ts);
2737 : :
2738 : 43 : f->ts.type = BT_INTEGER;
2739 : 43 : f->ts.kind = gfc_c_int_kind;
2740 : 43 : if (u->ts.kind != gfc_c_int_kind)
2741 : : {
2742 : 0 : ts.type = BT_INTEGER;
2743 : 0 : ts.kind = gfc_c_int_kind;
2744 : 0 : ts.u.derived = NULL;
2745 : 0 : ts.u.cl = NULL;
2746 : 0 : gfc_convert_type (u, &ts, 2);
2747 : : }
2748 : :
2749 : 43 : f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2750 : 43 : }
2751 : :
2752 : :
2753 : : void
2754 : 3 : gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2755 : : {
2756 : 3 : f->ts.type = BT_INTEGER;
2757 : 3 : f->ts.kind = gfc_c_int_kind;
2758 : 3 : f->value.function.name = gfc_get_string (PREFIX ("fget"));
2759 : 3 : }
2760 : :
2761 : :
2762 : : void
2763 : 25 : gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2764 : : {
2765 : 25 : gfc_typespec ts;
2766 : 25 : gfc_clear_ts (&ts);
2767 : :
2768 : 25 : f->ts.type = BT_INTEGER;
2769 : 25 : f->ts.kind = gfc_c_int_kind;
2770 : 25 : if (u->ts.kind != gfc_c_int_kind)
2771 : : {
2772 : 0 : ts.type = BT_INTEGER;
2773 : 0 : ts.kind = gfc_c_int_kind;
2774 : 0 : ts.u.derived = NULL;
2775 : 0 : ts.u.cl = NULL;
2776 : 0 : gfc_convert_type (u, &ts, 2);
2777 : : }
2778 : :
2779 : 25 : f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2780 : 25 : }
2781 : :
2782 : :
2783 : : void
2784 : 1 : gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2785 : : {
2786 : 1 : f->ts.type = BT_INTEGER;
2787 : 1 : f->ts.kind = gfc_c_int_kind;
2788 : 1 : f->value.function.name = gfc_get_string (PREFIX ("fput"));
2789 : 1 : }
2790 : :
2791 : :
2792 : : void
2793 : 258 : gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2794 : : {
2795 : 258 : gfc_typespec ts;
2796 : 258 : gfc_clear_ts (&ts);
2797 : :
2798 : 258 : f->ts.type = BT_INTEGER;
2799 : 258 : f->ts.kind = gfc_intio_kind;
2800 : 258 : if (u->ts.kind != gfc_c_int_kind)
2801 : : {
2802 : 0 : ts.type = BT_INTEGER;
2803 : 0 : ts.kind = gfc_c_int_kind;
2804 : 0 : ts.u.derived = NULL;
2805 : 0 : ts.u.cl = NULL;
2806 : 0 : gfc_convert_type (u, &ts, 2);
2807 : : }
2808 : :
2809 : 258 : f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2810 : 258 : }
2811 : :
2812 : :
2813 : : void
2814 : 634 : gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2815 : : gfc_expr *kind)
2816 : : {
2817 : 634 : f->ts.type = BT_INTEGER;
2818 : 634 : if (kind)
2819 : 390 : f->ts.kind = mpz_get_si (kind->value.integer);
2820 : : else
2821 : 244 : f->ts.kind = gfc_default_integer_kind;
2822 : 634 : }
2823 : :
2824 : :
2825 : : void
2826 : 4021 : gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2827 : : {
2828 : 4021 : resolve_transformational ("sum", f, array, dim, mask);
2829 : 4021 : }
2830 : :
2831 : :
2832 : : void
2833 : 4 : gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2834 : : gfc_expr *p2 ATTRIBUTE_UNUSED)
2835 : : {
2836 : 4 : f->ts.type = BT_INTEGER;
2837 : 4 : f->ts.kind = gfc_default_integer_kind;
2838 : 4 : f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2839 : 4 : }
2840 : :
2841 : :
2842 : : /* Resolve the g77 compatibility function SYSTEM. */
2843 : :
2844 : : void
2845 : 0 : gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2846 : : {
2847 : 0 : f->ts.type = BT_INTEGER;
2848 : 0 : f->ts.kind = 4;
2849 : 0 : f->value.function.name = gfc_get_string (PREFIX ("system"));
2850 : 0 : }
2851 : :
2852 : :
2853 : : void
2854 : 662 : gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2855 : : {
2856 : 662 : f->ts = x->ts;
2857 : 662 : f->value.function.name
2858 : 662 : = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type),
2859 : : gfc_type_abi_kind (&x->ts));
2860 : 662 : }
2861 : :
2862 : :
2863 : : void
2864 : 302 : gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2865 : : {
2866 : 302 : f->ts = x->ts;
2867 : 302 : f->value.function.name
2868 : 302 : = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type),
2869 : : gfc_type_abi_kind (&x->ts));
2870 : 302 : }
2871 : :
2872 : :
2873 : : /* Resolve failed_images (team, kind). */
2874 : :
2875 : : void
2876 : 24 : gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2877 : : gfc_expr *kind)
2878 : : {
2879 : 24 : static char failed_images[] = "_gfortran_caf_failed_images";
2880 : 24 : f->rank = 1;
2881 : 24 : f->ts.type = BT_INTEGER;
2882 : 24 : if (kind == NULL)
2883 : 8 : f->ts.kind = gfc_default_integer_kind;
2884 : : else
2885 : 16 : gfc_extract_int (kind, &f->ts.kind);
2886 : 24 : f->value.function.name = failed_images;
2887 : 24 : }
2888 : :
2889 : :
2890 : : /* Resolve image_status (image, team). */
2891 : :
2892 : : void
2893 : 66 : gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2894 : : gfc_expr *team ATTRIBUTE_UNUSED)
2895 : : {
2896 : 66 : static char image_status[] = "_gfortran_caf_image_status";
2897 : 66 : f->ts.type = BT_INTEGER;
2898 : 66 : f->ts.kind = gfc_default_integer_kind;
2899 : 66 : f->value.function.name = image_status;
2900 : 66 : }
2901 : :
2902 : :
2903 : : /* Resolve get_team (). */
2904 : :
2905 : : void
2906 : 3 : gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2907 : : {
2908 : 3 : static char get_team[] = "_gfortran_caf_get_team";
2909 : 3 : f->rank = 0;
2910 : 3 : f->ts.type = BT_INTEGER;
2911 : 3 : f->ts.kind = gfc_default_integer_kind;
2912 : 3 : f->value.function.name = get_team;
2913 : 3 : }
2914 : :
2915 : :
2916 : : /* Resolve image_index (...). */
2917 : :
2918 : : void
2919 : 154 : gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2920 : : gfc_expr *sub ATTRIBUTE_UNUSED)
2921 : : {
2922 : 154 : static char image_index[] = "__image_index";
2923 : 154 : f->ts.type = BT_INTEGER;
2924 : 154 : f->ts.kind = gfc_default_integer_kind;
2925 : 154 : f->value.function.name = image_index;
2926 : 154 : }
2927 : :
2928 : :
2929 : : /* Resolve stopped_images (team, kind). */
2930 : :
2931 : : void
2932 : 24 : gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2933 : : gfc_expr *kind)
2934 : : {
2935 : 24 : static char stopped_images[] = "_gfortran_caf_stopped_images";
2936 : 24 : f->rank = 1;
2937 : 24 : f->ts.type = BT_INTEGER;
2938 : 24 : if (kind == NULL)
2939 : 8 : f->ts.kind = gfc_default_integer_kind;
2940 : : else
2941 : 16 : gfc_extract_int (kind, &f->ts.kind);
2942 : 24 : f->value.function.name = stopped_images;
2943 : 24 : }
2944 : :
2945 : :
2946 : : /* Resolve team_number (team). */
2947 : :
2948 : : void
2949 : 65 : gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
2950 : : {
2951 : 65 : static char team_number[] = "_gfortran_caf_team_number";
2952 : 65 : f->rank = 0;
2953 : 65 : f->ts.type = BT_INTEGER;
2954 : 65 : f->ts.kind = gfc_default_integer_kind;
2955 : 65 : f->value.function.name = team_number;
2956 : 65 : }
2957 : :
2958 : :
2959 : : void
2960 : 1582 : gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2961 : : gfc_expr *distance ATTRIBUTE_UNUSED)
2962 : : {
2963 : 1582 : static char this_image[] = "__this_image";
2964 : 1582 : if (array && gfc_is_coarray (array))
2965 : 712 : resolve_bound (f, array, dim, NULL, "__this_image", true);
2966 : : else
2967 : : {
2968 : 870 : f->ts.type = BT_INTEGER;
2969 : 870 : f->ts.kind = gfc_default_integer_kind;
2970 : 870 : f->value.function.name = this_image;
2971 : : }
2972 : 1582 : }
2973 : :
2974 : :
2975 : : void
2976 : 14 : gfc_resolve_time (gfc_expr *f)
2977 : : {
2978 : 14 : f->ts.type = BT_INTEGER;
2979 : 14 : f->ts.kind = 4;
2980 : 14 : f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2981 : 14 : }
2982 : :
2983 : :
2984 : : void
2985 : 2 : gfc_resolve_time8 (gfc_expr *f)
2986 : : {
2987 : 2 : f->ts.type = BT_INTEGER;
2988 : 2 : f->ts.kind = 8;
2989 : 2 : f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2990 : 2 : }
2991 : :
2992 : :
2993 : : void
2994 : 1833 : gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2995 : : gfc_expr *mold, gfc_expr *size)
2996 : : {
2997 : : /* TODO: Make this do something meaningful. */
2998 : 1833 : static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2999 : :
3000 : 1833 : if (mold->ts.type == BT_CHARACTER
3001 : 597 : && !mold->ts.u.cl->length
3002 : 1984 : && gfc_is_constant_expr (mold))
3003 : : {
3004 : 107 : int len;
3005 : 107 : if (mold->expr_type == EXPR_CONSTANT)
3006 : : {
3007 : 107 : len = mold->value.character.length;
3008 : 107 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3009 : : NULL, len);
3010 : : }
3011 : : else
3012 : : {
3013 : 0 : gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3014 : 0 : len = c->expr->value.character.length;
3015 : 0 : mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
3016 : : NULL, len);
3017 : : }
3018 : : }
3019 : :
3020 : 1833 : f->ts = mold->ts;
3021 : :
3022 : 1833 : if (size == NULL && mold->rank == 0)
3023 : : {
3024 : 1087 : f->rank = 0;
3025 : 1087 : f->value.function.name = transfer0;
3026 : : }
3027 : : else
3028 : : {
3029 : 746 : f->rank = 1;
3030 : 746 : f->value.function.name = transfer1;
3031 : 746 : if (size && gfc_is_constant_expr (size))
3032 : : {
3033 : 144 : f->shape = gfc_get_shape (1);
3034 : 144 : mpz_init_set (f->shape[0], size->value.integer);
3035 : : }
3036 : : }
3037 : 1833 : }
3038 : :
3039 : :
3040 : : void
3041 : 1599 : gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3042 : : {
3043 : :
3044 : 1599 : if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3045 : 156 : gfc_resolve_substring_charlen (matrix);
3046 : :
3047 : 1599 : f->ts = matrix->ts;
3048 : 1599 : f->rank = 2;
3049 : 1599 : if (matrix->shape)
3050 : : {
3051 : 1267 : f->shape = gfc_get_shape (2);
3052 : 1267 : mpz_init_set (f->shape[0], matrix->shape[1]);
3053 : 1267 : mpz_init_set (f->shape[1], matrix->shape[0]);
3054 : : }
3055 : :
3056 : 1599 : switch (matrix->ts.kind)
3057 : : {
3058 : 1485 : case 4:
3059 : 1485 : case 8:
3060 : 1485 : case 10:
3061 : 1485 : case 16:
3062 : 1485 : switch (matrix->ts.type)
3063 : : {
3064 : 470 : case BT_REAL:
3065 : 470 : case BT_COMPLEX:
3066 : 470 : f->value.function.name
3067 : 940 : = gfc_get_string (PREFIX ("transpose_%c%d"),
3068 : 470 : gfc_type_letter (matrix->ts.type),
3069 : : gfc_type_abi_kind (&matrix->ts));
3070 : 470 : break;
3071 : :
3072 : 937 : case BT_INTEGER:
3073 : 937 : case BT_LOGICAL:
3074 : : /* Use the integer routines for real and logical cases. This
3075 : : assumes they all have the same alignment requirements. */
3076 : 937 : f->value.function.name
3077 : 937 : = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3078 : 937 : break;
3079 : :
3080 : 78 : default:
3081 : 78 : if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3082 : 78 : f->value.function.name = PREFIX ("transpose_char4");
3083 : : else
3084 : 0 : f->value.function.name = PREFIX ("transpose");
3085 : : break;
3086 : : }
3087 : : break;
3088 : :
3089 : 114 : default:
3090 : 228 : f->value.function.name = (matrix->ts.type == BT_CHARACTER
3091 : 114 : ? PREFIX ("transpose_char")
3092 : : : PREFIX ("transpose"));
3093 : 114 : break;
3094 : : }
3095 : 1599 : }
3096 : :
3097 : :
3098 : : void
3099 : 4280 : gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3100 : : {
3101 : 4280 : f->ts.type = BT_CHARACTER;
3102 : 4280 : f->ts.kind = string->ts.kind;
3103 : 4280 : f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3104 : 4280 : }
3105 : :
3106 : :
3107 : : /* Resolve the degree trigonometric functions. This amounts to setting
3108 : : the function return type-spec from its argument and building a
3109 : : library function names of the form _gfortran_sind_r4. */
3110 : :
3111 : : void
3112 : 1404 : gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3113 : : {
3114 : 1404 : f->ts = x->ts;
3115 : 1404 : f->value.function.name
3116 : 2808 : = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3117 : 1404 : gfc_type_letter (x->ts.type),
3118 : : gfc_type_abi_kind (&x->ts));
3119 : 1404 : }
3120 : :
3121 : :
3122 : : void
3123 : 144 : gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3124 : : {
3125 : 144 : f->ts = y->ts;
3126 : 144 : f->value.function.name
3127 : 144 : = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3128 : : x->ts.kind);
3129 : 144 : }
3130 : :
3131 : :
3132 : : void
3133 : 11569 : gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3134 : : {
3135 : 11569 : resolve_bound (f, array, dim, kind, "__ubound", false);
3136 : 11569 : }
3137 : :
3138 : :
3139 : : void
3140 : 372 : gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3141 : : {
3142 : 372 : resolve_bound (f, array, dim, kind, "__ucobound", true);
3143 : 372 : }
3144 : :
3145 : :
3146 : : /* Resolve the g77 compatibility function UMASK. */
3147 : :
3148 : : void
3149 : 0 : gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3150 : : {
3151 : 0 : f->ts.type = BT_INTEGER;
3152 : 0 : f->ts.kind = n->ts.kind;
3153 : 0 : f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3154 : 0 : }
3155 : :
3156 : :
3157 : : /* Resolve the g77 compatibility function UNLINK. */
3158 : :
3159 : : void
3160 : 1 : gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3161 : : {
3162 : 1 : f->ts.type = BT_INTEGER;
3163 : 1 : f->ts.kind = 4;
3164 : 1 : f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3165 : 1 : }
3166 : :
3167 : :
3168 : : void
3169 : 0 : gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3170 : : {
3171 : 0 : gfc_typespec ts;
3172 : 0 : gfc_clear_ts (&ts);
3173 : :
3174 : 0 : f->ts.type = BT_CHARACTER;
3175 : 0 : f->ts.kind = gfc_default_character_kind;
3176 : :
3177 : 0 : if (unit->ts.kind != gfc_c_int_kind)
3178 : : {
3179 : 0 : ts.type = BT_INTEGER;
3180 : 0 : ts.kind = gfc_c_int_kind;
3181 : 0 : ts.u.derived = NULL;
3182 : 0 : ts.u.cl = NULL;
3183 : 0 : gfc_convert_type (unit, &ts, 2);
3184 : : }
3185 : :
3186 : 0 : f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3187 : 0 : }
3188 : :
3189 : :
3190 : : void
3191 : 454 : gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3192 : : gfc_expr *field ATTRIBUTE_UNUSED)
3193 : : {
3194 : 454 : if (vector->ts.type == BT_CHARACTER && vector->ref)
3195 : 54 : gfc_resolve_substring_charlen (vector);
3196 : :
3197 : 454 : f->ts = vector->ts;
3198 : 454 : f->rank = mask->rank;
3199 : 454 : resolve_mask_arg (mask);
3200 : :
3201 : 454 : if (vector->ts.type == BT_CHARACTER)
3202 : : {
3203 : 54 : if (vector->ts.kind == 1)
3204 : 30 : f->value.function.name
3205 : 54 : = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3206 : : else
3207 : 24 : f->value.function.name
3208 : 24 : = gfc_get_string (PREFIX ("unpack%d_char%d"),
3209 : 24 : field->rank > 0 ? 1 : 0, vector->ts.kind);
3210 : : }
3211 : : else
3212 : 400 : f->value.function.name
3213 : 493 : = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3214 : 454 : }
3215 : :
3216 : :
3217 : : void
3218 : 254 : gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3219 : : gfc_expr *set ATTRIBUTE_UNUSED,
3220 : : gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3221 : : {
3222 : 254 : f->ts.type = BT_INTEGER;
3223 : 254 : if (kind)
3224 : 16 : f->ts.kind = mpz_get_si (kind->value.integer);
3225 : : else
3226 : 238 : f->ts.kind = gfc_default_integer_kind;
3227 : 254 : f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3228 : 254 : }
3229 : :
3230 : :
3231 : : void
3232 : 20 : gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3233 : : {
3234 : 20 : f->ts.type = i->ts.type;
3235 : 20 : f->ts.kind = gfc_kind_max (i, j);
3236 : :
3237 : 20 : if (i->ts.kind != j->ts.kind)
3238 : : {
3239 : 0 : if (i->ts.kind == gfc_kind_max (i, j))
3240 : 0 : gfc_convert_type (j, &i->ts, 2);
3241 : : else
3242 : 0 : gfc_convert_type (i, &j->ts, 2);
3243 : : }
3244 : :
3245 : 20 : f->value.function.name
3246 : 20 : = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type),
3247 : : gfc_type_abi_kind (&f->ts));
3248 : 20 : }
3249 : :
3250 : :
3251 : : /* Intrinsic subroutine resolution. */
3252 : :
3253 : : void
3254 : 0 : gfc_resolve_alarm_sub (gfc_code *c)
3255 : : {
3256 : 0 : const char *name;
3257 : 0 : gfc_expr *seconds, *handler;
3258 : 0 : gfc_typespec ts;
3259 : 0 : gfc_clear_ts (&ts);
3260 : :
3261 : 0 : seconds = c->ext.actual->expr;
3262 : 0 : handler = c->ext.actual->next->expr;
3263 : 0 : ts.type = BT_INTEGER;
3264 : 0 : ts.kind = gfc_c_int_kind;
3265 : :
3266 : : /* handler can be either BT_INTEGER or BT_PROCEDURE.
3267 : : In all cases, the status argument is of default integer kind
3268 : : (enforced in check.cc) so that the function suffix is fixed. */
3269 : 0 : if (handler->ts.type == BT_INTEGER)
3270 : : {
3271 : 0 : if (handler->ts.kind != gfc_c_int_kind)
3272 : 0 : gfc_convert_type (handler, &ts, 2);
3273 : 0 : name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3274 : : gfc_default_integer_kind);
3275 : : }
3276 : : else
3277 : 0 : name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3278 : : gfc_default_integer_kind);
3279 : :
3280 : 0 : if (seconds->ts.kind != gfc_c_int_kind)
3281 : 0 : gfc_convert_type (seconds, &ts, 2);
3282 : :
3283 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3284 : 0 : }
3285 : :
3286 : : void
3287 : 21 : gfc_resolve_cpu_time (gfc_code *c)
3288 : : {
3289 : 21 : const char *name;
3290 : 21 : name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3291 : 21 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3292 : 21 : }
3293 : :
3294 : :
3295 : : /* Create a formal arglist based on an actual one and set the INTENTs given. */
3296 : :
3297 : : static gfc_formal_arglist*
3298 : 174 : create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3299 : : {
3300 : 174 : gfc_formal_arglist* head;
3301 : 174 : gfc_formal_arglist* tail;
3302 : 174 : int i;
3303 : :
3304 : 174 : if (!actual)
3305 : : return NULL;
3306 : :
3307 : 174 : head = tail = gfc_get_formal_arglist ();
3308 : 1044 : for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3309 : : {
3310 : 870 : gfc_symbol* sym;
3311 : :
3312 : 870 : sym = gfc_new_symbol ("dummyarg", NULL);
3313 : 870 : sym->ts = actual->expr->ts;
3314 : :
3315 : 870 : sym->attr.intent = ints[i];
3316 : 870 : tail->sym = sym;
3317 : :
3318 : 870 : if (actual->next)
3319 : 696 : tail->next = gfc_get_formal_arglist ();
3320 : : }
3321 : :
3322 : : return head;
3323 : : }
3324 : :
3325 : :
3326 : : void
3327 : 17 : gfc_resolve_atomic_def (gfc_code *c)
3328 : : {
3329 : 17 : const char *name = "atomic_define";
3330 : 17 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3331 : 17 : }
3332 : :
3333 : :
3334 : : void
3335 : 121 : gfc_resolve_atomic_ref (gfc_code *c)
3336 : : {
3337 : 121 : const char *name = "atomic_ref";
3338 : 121 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3339 : 121 : }
3340 : :
3341 : : void
3342 : 70 : gfc_resolve_event_query (gfc_code *c)
3343 : : {
3344 : 70 : const char *name = "event_query";
3345 : 70 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3346 : 70 : }
3347 : :
3348 : : void
3349 : 174 : gfc_resolve_mvbits (gfc_code *c)
3350 : : {
3351 : 174 : static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3352 : : INTENT_INOUT, INTENT_IN};
3353 : 174 : const char *name;
3354 : :
3355 : : /* TO and FROM are guaranteed to have the same kind parameter. */
3356 : 348 : name = gfc_get_string (PREFIX ("mvbits_i%d"),
3357 : 174 : c->ext.actual->expr->ts.kind);
3358 : 174 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3359 : : /* Mark as elemental subroutine as this does not happen automatically. */
3360 : 174 : c->resolved_sym->attr.elemental = 1;
3361 : :
3362 : : /* Create a dummy formal arglist so the INTENTs are known later for purpose
3363 : : of creating temporaries. */
3364 : 174 : c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3365 : 174 : }
3366 : :
3367 : :
3368 : : /* Set up the call to RANDOM_INIT. */
3369 : :
3370 : : void
3371 : 90 : gfc_resolve_random_init (gfc_code *c)
3372 : : {
3373 : 90 : const char *name;
3374 : 90 : name = gfc_get_string (PREFIX ("random_init"));
3375 : 90 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3376 : 90 : }
3377 : :
3378 : :
3379 : : void
3380 : 479 : gfc_resolve_random_number (gfc_code *c)
3381 : : {
3382 : 479 : const char *name;
3383 : 479 : int kind;
3384 : :
3385 : 479 : kind = gfc_type_abi_kind (&c->ext.actual->expr->ts);
3386 : 479 : if (c->ext.actual->expr->rank == 0)
3387 : 81 : name = gfc_get_string (PREFIX ("random_r%d"), kind);
3388 : : else
3389 : 398 : name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3390 : :
3391 : 479 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3392 : 479 : }
3393 : :
3394 : :
3395 : : void
3396 : 249 : gfc_resolve_random_seed (gfc_code *c)
3397 : : {
3398 : 249 : const char *name;
3399 : :
3400 : 249 : name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3401 : 249 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3402 : 249 : }
3403 : :
3404 : :
3405 : : void
3406 : 9 : gfc_resolve_rename_sub (gfc_code *c)
3407 : : {
3408 : 9 : const char *name;
3409 : 9 : int kind;
3410 : :
3411 : : /* Find the type of status. If not present use default integer kind. */
3412 : 9 : if (c->ext.actual->next->next->expr != NULL)
3413 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3414 : : else
3415 : 2 : kind = gfc_default_integer_kind;
3416 : :
3417 : 9 : name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3418 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3419 : 9 : }
3420 : :
3421 : :
3422 : : void
3423 : 9 : gfc_resolve_link_sub (gfc_code *c)
3424 : : {
3425 : 9 : const char *name;
3426 : 9 : int kind;
3427 : :
3428 : 9 : if (c->ext.actual->next->next->expr != NULL)
3429 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3430 : : else
3431 : 2 : kind = gfc_default_integer_kind;
3432 : :
3433 : 9 : name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3434 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3435 : 9 : }
3436 : :
3437 : :
3438 : : void
3439 : 9 : gfc_resolve_symlnk_sub (gfc_code *c)
3440 : : {
3441 : 9 : const char *name;
3442 : 9 : int kind;
3443 : :
3444 : 9 : if (c->ext.actual->next->next->expr != NULL)
3445 : 7 : kind = c->ext.actual->next->next->expr->ts.kind;
3446 : : else
3447 : 2 : kind = gfc_default_integer_kind;
3448 : :
3449 : 9 : name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3450 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3451 : 9 : }
3452 : :
3453 : :
3454 : : /* G77 compatibility subroutines dtime() and etime(). */
3455 : :
3456 : : void
3457 : 0 : gfc_resolve_dtime_sub (gfc_code *c)
3458 : : {
3459 : 0 : const char *name;
3460 : 0 : name = gfc_get_string (PREFIX ("dtime_sub"));
3461 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3462 : 0 : }
3463 : :
3464 : : void
3465 : 1 : gfc_resolve_etime_sub (gfc_code *c)
3466 : : {
3467 : 1 : const char *name;
3468 : 1 : name = gfc_get_string (PREFIX ("etime_sub"));
3469 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3470 : 1 : }
3471 : :
3472 : :
3473 : : /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3474 : :
3475 : : void
3476 : 12 : gfc_resolve_itime (gfc_code *c)
3477 : : {
3478 : 12 : c->resolved_sym
3479 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3480 : : gfc_default_integer_kind));
3481 : 12 : }
3482 : :
3483 : : void
3484 : 12 : gfc_resolve_idate (gfc_code *c)
3485 : : {
3486 : 12 : c->resolved_sym
3487 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3488 : : gfc_default_integer_kind));
3489 : 12 : }
3490 : :
3491 : : void
3492 : 12 : gfc_resolve_ltime (gfc_code *c)
3493 : : {
3494 : 12 : c->resolved_sym
3495 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3496 : : gfc_default_integer_kind));
3497 : 12 : }
3498 : :
3499 : : void
3500 : 12 : gfc_resolve_gmtime (gfc_code *c)
3501 : : {
3502 : 12 : c->resolved_sym
3503 : 12 : = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3504 : : gfc_default_integer_kind));
3505 : 12 : }
3506 : :
3507 : :
3508 : : /* G77 compatibility subroutine second(). */
3509 : :
3510 : : void
3511 : 0 : gfc_resolve_second_sub (gfc_code *c)
3512 : : {
3513 : 0 : const char *name;
3514 : 0 : name = gfc_get_string (PREFIX ("second_sub"));
3515 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3516 : 0 : }
3517 : :
3518 : :
3519 : : void
3520 : 19 : gfc_resolve_sleep_sub (gfc_code *c)
3521 : : {
3522 : 19 : const char *name;
3523 : 19 : int kind;
3524 : :
3525 : 19 : if (c->ext.actual->expr != NULL)
3526 : 19 : kind = c->ext.actual->expr->ts.kind;
3527 : : else
3528 : 0 : kind = gfc_default_integer_kind;
3529 : :
3530 : 19 : name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3531 : 19 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3532 : 19 : }
3533 : :
3534 : :
3535 : : /* G77 compatibility function srand(). */
3536 : :
3537 : : void
3538 : 0 : gfc_resolve_srand (gfc_code *c)
3539 : : {
3540 : 0 : const char *name;
3541 : 0 : name = gfc_get_string (PREFIX ("srand"));
3542 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3543 : 0 : }
3544 : :
3545 : :
3546 : : /* Resolve the getarg intrinsic subroutine. */
3547 : :
3548 : : void
3549 : 55 : gfc_resolve_getarg (gfc_code *c)
3550 : : {
3551 : 55 : const char *name;
3552 : :
3553 : 55 : if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3554 : : {
3555 : 9 : gfc_typespec ts;
3556 : 9 : gfc_clear_ts (&ts);
3557 : :
3558 : 9 : ts.type = BT_INTEGER;
3559 : 9 : ts.kind = gfc_default_integer_kind;
3560 : :
3561 : 9 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3562 : : }
3563 : :
3564 : 55 : name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3565 : 55 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3566 : 55 : }
3567 : :
3568 : :
3569 : : /* Resolve the getcwd intrinsic subroutine. */
3570 : :
3571 : : void
3572 : 8 : gfc_resolve_getcwd_sub (gfc_code *c)
3573 : : {
3574 : 8 : const char *name;
3575 : 8 : int kind;
3576 : :
3577 : 8 : if (c->ext.actual->next->expr != NULL)
3578 : 1 : kind = c->ext.actual->next->expr->ts.kind;
3579 : : else
3580 : 7 : kind = gfc_default_integer_kind;
3581 : :
3582 : 8 : name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3583 : 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3584 : 8 : }
3585 : :
3586 : :
3587 : : /* Resolve the get_command intrinsic subroutine. */
3588 : :
3589 : : void
3590 : 3 : gfc_resolve_get_command (gfc_code *c)
3591 : : {
3592 : 3 : const char *name;
3593 : 3 : int kind;
3594 : 3 : kind = gfc_default_integer_kind;
3595 : 3 : name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3596 : 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3597 : 3 : }
3598 : :
3599 : :
3600 : : /* Resolve the get_command_argument intrinsic subroutine. */
3601 : :
3602 : : void
3603 : 4 : gfc_resolve_get_command_argument (gfc_code *c)
3604 : : {
3605 : 4 : const char *name;
3606 : 4 : int kind;
3607 : 4 : kind = gfc_default_integer_kind;
3608 : 4 : name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3609 : 4 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3610 : 4 : }
3611 : :
3612 : :
3613 : : /* Resolve the get_environment_variable intrinsic subroutine. */
3614 : :
3615 : : void
3616 : 26 : gfc_resolve_get_environment_variable (gfc_code *code)
3617 : : {
3618 : 26 : const char *name;
3619 : 26 : int kind;
3620 : 26 : kind = gfc_default_integer_kind;
3621 : 26 : name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3622 : 26 : code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3623 : 26 : }
3624 : :
3625 : :
3626 : : void
3627 : 0 : gfc_resolve_signal_sub (gfc_code *c)
3628 : : {
3629 : 0 : const char *name;
3630 : 0 : gfc_expr *number, *handler, *status;
3631 : 0 : gfc_typespec ts;
3632 : 0 : gfc_clear_ts (&ts);
3633 : :
3634 : 0 : number = c->ext.actual->expr;
3635 : 0 : handler = c->ext.actual->next->expr;
3636 : 0 : status = c->ext.actual->next->next->expr;
3637 : 0 : ts.type = BT_INTEGER;
3638 : 0 : ts.kind = gfc_c_int_kind;
3639 : :
3640 : : /* handler can be either BT_INTEGER or BT_PROCEDURE */
3641 : 0 : if (handler->ts.type == BT_INTEGER)
3642 : : {
3643 : 0 : if (handler->ts.kind != gfc_c_int_kind)
3644 : 0 : gfc_convert_type (handler, &ts, 2);
3645 : 0 : name = gfc_get_string (PREFIX ("signal_sub_int"));
3646 : : }
3647 : : else
3648 : 0 : name = gfc_get_string (PREFIX ("signal_sub"));
3649 : :
3650 : 0 : if (number->ts.kind != gfc_c_int_kind)
3651 : 0 : gfc_convert_type (number, &ts, 2);
3652 : 0 : if (status != NULL && status->ts.kind != gfc_c_int_kind)
3653 : 0 : gfc_convert_type (status, &ts, 2);
3654 : :
3655 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3656 : 0 : }
3657 : :
3658 : :
3659 : : /* Resolve the SYSTEM intrinsic subroutine. */
3660 : :
3661 : : void
3662 : 2 : gfc_resolve_system_sub (gfc_code *c)
3663 : : {
3664 : 2 : const char *name;
3665 : 2 : name = gfc_get_string (PREFIX ("system_sub"));
3666 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3667 : 2 : }
3668 : :
3669 : :
3670 : : /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3671 : :
3672 : : void
3673 : 196 : gfc_resolve_system_clock (gfc_code *c)
3674 : : {
3675 : 196 : const char *name;
3676 : 196 : int kind;
3677 : 196 : gfc_expr *count = c->ext.actual->expr;
3678 : 196 : gfc_expr *count_max = c->ext.actual->next->next->expr;
3679 : :
3680 : : /* The INTEGER(8) version has higher precision, it is used if both COUNT
3681 : : and COUNT_MAX can hold 64-bit values, or are absent. */
3682 : 196 : if ((!count || count->ts.kind >= 8)
3683 : 73 : && (!count_max || count_max->ts.kind >= 8))
3684 : : kind = 8;
3685 : : else
3686 : 159 : kind = gfc_default_integer_kind;
3687 : :
3688 : 196 : name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3689 : 196 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3690 : 196 : }
3691 : :
3692 : :
3693 : : /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3694 : : void
3695 : 20 : gfc_resolve_execute_command_line (gfc_code *c)
3696 : : {
3697 : 20 : const char *name;
3698 : 20 : name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3699 : : gfc_default_integer_kind);
3700 : 20 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3701 : 20 : }
3702 : :
3703 : :
3704 : : /* Resolve the EXIT intrinsic subroutine. */
3705 : :
3706 : : void
3707 : 3 : gfc_resolve_exit (gfc_code *c)
3708 : : {
3709 : 3 : const char *name;
3710 : 3 : gfc_typespec ts;
3711 : 3 : gfc_expr *n;
3712 : 3 : gfc_clear_ts (&ts);
3713 : :
3714 : : /* The STATUS argument has to be of default kind. If it is not,
3715 : : we convert it. */
3716 : 3 : ts.type = BT_INTEGER;
3717 : 3 : ts.kind = gfc_default_integer_kind;
3718 : 3 : n = c->ext.actual->expr;
3719 : 3 : if (n != NULL && n->ts.kind != ts.kind)
3720 : 0 : gfc_convert_type (n, &ts, 2);
3721 : :
3722 : 3 : name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3723 : 3 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3724 : 3 : }
3725 : :
3726 : :
3727 : : /* Resolve the FLUSH intrinsic subroutine. */
3728 : :
3729 : : void
3730 : 19 : gfc_resolve_flush (gfc_code *c)
3731 : : {
3732 : 19 : const char *name;
3733 : 19 : gfc_typespec ts;
3734 : 19 : gfc_expr *n;
3735 : 19 : gfc_clear_ts (&ts);
3736 : :
3737 : 19 : ts.type = BT_INTEGER;
3738 : 19 : ts.kind = gfc_default_integer_kind;
3739 : 19 : n = c->ext.actual->expr;
3740 : 19 : if (n != NULL && n->ts.kind != ts.kind)
3741 : 0 : gfc_convert_type (n, &ts, 2);
3742 : :
3743 : 19 : name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3744 : 19 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3745 : 19 : }
3746 : :
3747 : :
3748 : : void
3749 : 1 : gfc_resolve_ctime_sub (gfc_code *c)
3750 : : {
3751 : 1 : gfc_typespec ts;
3752 : 1 : gfc_clear_ts (&ts);
3753 : :
3754 : : /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3755 : 1 : if (c->ext.actual->expr->ts.kind != 8)
3756 : : {
3757 : 0 : ts.type = BT_INTEGER;
3758 : 0 : ts.kind = 8;
3759 : 0 : ts.u.derived = NULL;
3760 : 0 : ts.u.cl = NULL;
3761 : 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
3762 : : }
3763 : :
3764 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3765 : 1 : }
3766 : :
3767 : :
3768 : : void
3769 : 1 : gfc_resolve_fdate_sub (gfc_code *c)
3770 : : {
3771 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3772 : 1 : }
3773 : :
3774 : :
3775 : : void
3776 : 2 : gfc_resolve_gerror (gfc_code *c)
3777 : : {
3778 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3779 : 2 : }
3780 : :
3781 : :
3782 : : void
3783 : 2 : gfc_resolve_getlog (gfc_code *c)
3784 : : {
3785 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3786 : 2 : }
3787 : :
3788 : :
3789 : : void
3790 : 9 : gfc_resolve_hostnm_sub (gfc_code *c)
3791 : : {
3792 : 9 : const char *name;
3793 : 9 : int kind;
3794 : :
3795 : 9 : if (c->ext.actual->next->expr != NULL)
3796 : 7 : kind = c->ext.actual->next->expr->ts.kind;
3797 : : else
3798 : 2 : kind = gfc_default_integer_kind;
3799 : :
3800 : 9 : name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3801 : 9 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3802 : 9 : }
3803 : :
3804 : :
3805 : : void
3806 : 2 : gfc_resolve_perror (gfc_code *c)
3807 : : {
3808 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3809 : 2 : }
3810 : :
3811 : : /* Resolve the STAT and FSTAT intrinsic subroutines. */
3812 : :
3813 : : void
3814 : 14 : gfc_resolve_stat_sub (gfc_code *c)
3815 : : {
3816 : 14 : const char *name;
3817 : 14 : name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3818 : 14 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3819 : 14 : }
3820 : :
3821 : :
3822 : : void
3823 : 8 : gfc_resolve_lstat_sub (gfc_code *c)
3824 : : {
3825 : 8 : const char *name;
3826 : 8 : name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3827 : 8 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3828 : 8 : }
3829 : :
3830 : :
3831 : : void
3832 : 6 : gfc_resolve_fstat_sub (gfc_code *c)
3833 : : {
3834 : 6 : const char *name;
3835 : 6 : gfc_expr *u;
3836 : 6 : gfc_typespec *ts;
3837 : :
3838 : 6 : u = c->ext.actual->expr;
3839 : 6 : ts = &c->ext.actual->next->expr->ts;
3840 : 6 : if (u->ts.kind != ts->kind)
3841 : 0 : gfc_convert_type (u, ts, 2);
3842 : 6 : name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3843 : 6 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3844 : 6 : }
3845 : :
3846 : :
3847 : : void
3848 : 44 : gfc_resolve_fgetc_sub (gfc_code *c)
3849 : : {
3850 : 44 : const char *name;
3851 : 44 : gfc_typespec ts;
3852 : 44 : gfc_expr *u, *st;
3853 : 44 : gfc_clear_ts (&ts);
3854 : :
3855 : 44 : u = c->ext.actual->expr;
3856 : 44 : st = c->ext.actual->next->next->expr;
3857 : :
3858 : 44 : if (u->ts.kind != gfc_c_int_kind)
3859 : : {
3860 : 0 : ts.type = BT_INTEGER;
3861 : 0 : ts.kind = gfc_c_int_kind;
3862 : 0 : ts.u.derived = NULL;
3863 : 0 : ts.u.cl = NULL;
3864 : 0 : gfc_convert_type (u, &ts, 2);
3865 : : }
3866 : :
3867 : 44 : if (st != NULL)
3868 : 31 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3869 : : else
3870 : 13 : name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3871 : :
3872 : 44 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3873 : 44 : }
3874 : :
3875 : :
3876 : : void
3877 : 2 : gfc_resolve_fget_sub (gfc_code *c)
3878 : : {
3879 : 2 : const char *name;
3880 : 2 : gfc_expr *st;
3881 : :
3882 : 2 : st = c->ext.actual->next->expr;
3883 : 2 : if (st != NULL)
3884 : 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3885 : : else
3886 : 1 : name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3887 : :
3888 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3889 : 2 : }
3890 : :
3891 : :
3892 : : void
3893 : 33 : gfc_resolve_fputc_sub (gfc_code *c)
3894 : : {
3895 : 33 : const char *name;
3896 : 33 : gfc_typespec ts;
3897 : 33 : gfc_expr *u, *st;
3898 : 33 : gfc_clear_ts (&ts);
3899 : :
3900 : 33 : u = c->ext.actual->expr;
3901 : 33 : st = c->ext.actual->next->next->expr;
3902 : :
3903 : 33 : if (u->ts.kind != gfc_c_int_kind)
3904 : : {
3905 : 0 : ts.type = BT_INTEGER;
3906 : 0 : ts.kind = gfc_c_int_kind;
3907 : 0 : ts.u.derived = NULL;
3908 : 0 : ts.u.cl = NULL;
3909 : 0 : gfc_convert_type (u, &ts, 2);
3910 : : }
3911 : :
3912 : 33 : if (st != NULL)
3913 : 25 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3914 : : else
3915 : 8 : name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3916 : :
3917 : 33 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3918 : 33 : }
3919 : :
3920 : :
3921 : : void
3922 : 2 : gfc_resolve_fput_sub (gfc_code *c)
3923 : : {
3924 : 2 : const char *name;
3925 : 2 : gfc_expr *st;
3926 : :
3927 : 2 : st = c->ext.actual->next->expr;
3928 : 2 : if (st != NULL)
3929 : 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3930 : : else
3931 : 1 : name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3932 : :
3933 : 2 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3934 : 2 : }
3935 : :
3936 : :
3937 : : void
3938 : 60 : gfc_resolve_fseek_sub (gfc_code *c)
3939 : : {
3940 : 60 : gfc_expr *unit;
3941 : 60 : gfc_expr *offset;
3942 : 60 : gfc_expr *whence;
3943 : 60 : gfc_typespec ts;
3944 : 60 : gfc_clear_ts (&ts);
3945 : :
3946 : 60 : unit = c->ext.actual->expr;
3947 : 60 : offset = c->ext.actual->next->expr;
3948 : 60 : whence = c->ext.actual->next->next->expr;
3949 : :
3950 : 60 : if (unit->ts.kind != gfc_c_int_kind)
3951 : : {
3952 : 0 : ts.type = BT_INTEGER;
3953 : 0 : ts.kind = gfc_c_int_kind;
3954 : 0 : ts.u.derived = NULL;
3955 : 0 : ts.u.cl = NULL;
3956 : 0 : gfc_convert_type (unit, &ts, 2);
3957 : : }
3958 : :
3959 : 60 : if (offset->ts.kind != gfc_intio_kind)
3960 : : {
3961 : 60 : ts.type = BT_INTEGER;
3962 : 60 : ts.kind = gfc_intio_kind;
3963 : 60 : ts.u.derived = NULL;
3964 : 60 : ts.u.cl = NULL;
3965 : 60 : gfc_convert_type (offset, &ts, 2);
3966 : : }
3967 : :
3968 : 60 : if (whence->ts.kind != gfc_c_int_kind)
3969 : : {
3970 : 0 : ts.type = BT_INTEGER;
3971 : 0 : ts.kind = gfc_c_int_kind;
3972 : 0 : ts.u.derived = NULL;
3973 : 0 : ts.u.cl = NULL;
3974 : 0 : gfc_convert_type (whence, &ts, 2);
3975 : : }
3976 : :
3977 : 60 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3978 : 60 : }
3979 : :
3980 : : void
3981 : 36 : gfc_resolve_ftell_sub (gfc_code *c)
3982 : : {
3983 : 36 : const char *name;
3984 : 36 : gfc_expr *unit;
3985 : 36 : gfc_expr *offset;
3986 : 36 : gfc_typespec ts;
3987 : 36 : gfc_clear_ts (&ts);
3988 : :
3989 : 36 : unit = c->ext.actual->expr;
3990 : 36 : offset = c->ext.actual->next->expr;
3991 : :
3992 : 36 : if (unit->ts.kind != gfc_c_int_kind)
3993 : : {
3994 : 0 : ts.type = BT_INTEGER;
3995 : 0 : ts.kind = gfc_c_int_kind;
3996 : 0 : ts.u.derived = NULL;
3997 : 0 : ts.u.cl = NULL;
3998 : 0 : gfc_convert_type (unit, &ts, 2);
3999 : : }
4000 : :
4001 : 36 : name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4002 : 36 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4003 : 36 : }
4004 : :
4005 : :
4006 : : void
4007 : 1 : gfc_resolve_ttynam_sub (gfc_code *c)
4008 : : {
4009 : 1 : gfc_typespec ts;
4010 : 1 : gfc_clear_ts (&ts);
4011 : :
4012 : 1 : if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4013 : : {
4014 : 0 : ts.type = BT_INTEGER;
4015 : 0 : ts.kind = gfc_c_int_kind;
4016 : 0 : ts.u.derived = NULL;
4017 : 0 : ts.u.cl = NULL;
4018 : 0 : gfc_convert_type (c->ext.actual->expr, &ts, 2);
4019 : : }
4020 : :
4021 : 1 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4022 : 1 : }
4023 : :
4024 : :
4025 : : /* Resolve the UMASK intrinsic subroutine. */
4026 : :
4027 : : void
4028 : 0 : gfc_resolve_umask_sub (gfc_code *c)
4029 : : {
4030 : 0 : const char *name;
4031 : 0 : int kind;
4032 : :
4033 : 0 : if (c->ext.actual->next->expr != NULL)
4034 : 0 : kind = c->ext.actual->next->expr->ts.kind;
4035 : : else
4036 : 0 : kind = gfc_default_integer_kind;
4037 : :
4038 : 0 : name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4039 : 0 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4040 : 0 : }
4041 : :
4042 : : /* Resolve the UNLINK intrinsic subroutine. */
4043 : :
4044 : : void
4045 : 10 : gfc_resolve_unlink_sub (gfc_code *c)
4046 : : {
4047 : 10 : const char *name;
4048 : 10 : int kind;
4049 : :
4050 : 10 : if (c->ext.actual->next->expr != NULL)
4051 : 1 : kind = c->ext.actual->next->expr->ts.kind;
4052 : : else
4053 : 9 : kind = gfc_default_integer_kind;
4054 : :
4055 : 10 : name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4056 : 10 : c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4057 : 10 : }
|
