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