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