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