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