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_actual_arglist * a)1279 gfc_resolve_index_func (gfc_expr *f, gfc_actual_arglist *a)
1280 {
1281 gfc_typespec ts;
1282 gfc_clear_ts (&ts);
1283 gfc_expr *str, *back, *kind;
1284 gfc_actual_arglist *a_sub_str, *a_back, *a_kind;
1285
1286 if (f->do_not_resolve_again)
1287 return;
1288
1289 a_sub_str = a->next;
1290 a_back = a_sub_str->next;
1291 a_kind = a_back->next;
1292
1293 str = a->expr;
1294 back = a_back->expr;
1295 kind = a_kind->expr;
1296
1297 f->ts.type = BT_INTEGER;
1298 if (kind)
1299 f->ts.kind = mpz_get_si ((kind)->value.integer);
1300 else
1301 f->ts.kind = gfc_default_integer_kind;
1302
1303 if (back && back->ts.kind != gfc_default_integer_kind)
1304 {
1305 ts.type = BT_LOGICAL;
1306 ts.kind = gfc_default_integer_kind;
1307 ts.u.derived = NULL;
1308 ts.u.cl = NULL;
1309 gfc_convert_type (back, &ts, 2);
1310 }
1311
1312 f->value.function.name
1313 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1314
1315 f->do_not_resolve_again = 1;
1316 }
1317
1318
1319 void
gfc_resolve_int(gfc_expr * f,gfc_expr * a,gfc_expr * kind)1320 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1321 {
1322 f->ts.type = BT_INTEGER;
1323 f->ts.kind = (kind == NULL)
1324 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1325 f->value.function.name
1326 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1327 gfc_type_letter (a->ts.type), a->ts.kind);
1328 }
1329
1330
1331 void
gfc_resolve_int2(gfc_expr * f,gfc_expr * a)1332 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1333 {
1334 f->ts.type = BT_INTEGER;
1335 f->ts.kind = 2;
1336 f->value.function.name
1337 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1338 gfc_type_letter (a->ts.type), a->ts.kind);
1339 }
1340
1341
1342 void
gfc_resolve_int8(gfc_expr * f,gfc_expr * a)1343 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1344 {
1345 f->ts.type = BT_INTEGER;
1346 f->ts.kind = 8;
1347 f->value.function.name
1348 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1349 gfc_type_letter (a->ts.type), a->ts.kind);
1350 }
1351
1352
1353 void
gfc_resolve_long(gfc_expr * f,gfc_expr * a)1354 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1355 {
1356 f->ts.type = BT_INTEGER;
1357 f->ts.kind = 4;
1358 f->value.function.name
1359 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1360 gfc_type_letter (a->ts.type), a->ts.kind);
1361 }
1362
1363
1364 void
gfc_resolve_iparity(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask)1365 gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1366 {
1367 resolve_transformational ("iparity", f, array, dim, mask);
1368 }
1369
1370
1371 void
gfc_resolve_isatty(gfc_expr * f,gfc_expr * u)1372 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1373 {
1374 gfc_typespec ts;
1375 gfc_clear_ts (&ts);
1376
1377 f->ts.type = BT_LOGICAL;
1378 f->ts.kind = gfc_default_integer_kind;
1379 if (u->ts.kind != gfc_c_int_kind)
1380 {
1381 ts.type = BT_INTEGER;
1382 ts.kind = gfc_c_int_kind;
1383 ts.u.derived = NULL;
1384 ts.u.cl = NULL;
1385 gfc_convert_type (u, &ts, 2);
1386 }
1387
1388 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1389 }
1390
1391
1392 void
gfc_resolve_is_contiguous(gfc_expr * f,gfc_expr * array ATTRIBUTE_UNUSED)1393 gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
1394 {
1395 f->ts.type = BT_LOGICAL;
1396 f->ts.kind = gfc_default_logical_kind;
1397 f->value.function.name = gfc_get_string ("__is_contiguous");
1398 }
1399
1400
1401 void
gfc_resolve_ishft(gfc_expr * f,gfc_expr * i,gfc_expr * shift)1402 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1403 {
1404 f->ts = i->ts;
1405 f->value.function.name
1406 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1407 }
1408
1409
1410 void
gfc_resolve_rshift(gfc_expr * f,gfc_expr * i,gfc_expr * shift)1411 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1412 {
1413 f->ts = i->ts;
1414 f->value.function.name
1415 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1416 }
1417
1418
1419 void
gfc_resolve_lshift(gfc_expr * f,gfc_expr * i,gfc_expr * shift)1420 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1421 {
1422 f->ts = i->ts;
1423 f->value.function.name
1424 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1425 }
1426
1427
1428 void
gfc_resolve_ishftc(gfc_expr * f,gfc_expr * i,gfc_expr * shift,gfc_expr * size)1429 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1430 {
1431 int s_kind;
1432
1433 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1434
1435 f->ts = i->ts;
1436 f->value.function.name
1437 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1438 }
1439
1440
1441 void
gfc_resolve_lbound(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * kind)1442 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1443 {
1444 resolve_bound (f, array, dim, kind, "__lbound", false);
1445 }
1446
1447
1448 void
gfc_resolve_lcobound(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * kind)1449 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1450 {
1451 resolve_bound (f, array, dim, kind, "__lcobound", true);
1452 }
1453
1454
1455 void
gfc_resolve_len(gfc_expr * f,gfc_expr * string,gfc_expr * kind)1456 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1457 {
1458 f->ts.type = BT_INTEGER;
1459 if (kind)
1460 f->ts.kind = mpz_get_si (kind->value.integer);
1461 else
1462 f->ts.kind = gfc_default_integer_kind;
1463 f->value.function.name
1464 = gfc_get_string ("__len_%d_i%d", string->ts.kind,
1465 gfc_default_integer_kind);
1466 }
1467
1468
1469 void
gfc_resolve_len_trim(gfc_expr * f,gfc_expr * string,gfc_expr * kind)1470 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
1471 {
1472 f->ts.type = BT_INTEGER;
1473 if (kind)
1474 f->ts.kind = mpz_get_si (kind->value.integer);
1475 else
1476 f->ts.kind = gfc_default_integer_kind;
1477 f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
1478 }
1479
1480
1481 void
gfc_resolve_lgamma(gfc_expr * f,gfc_expr * x)1482 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1483 {
1484 f->ts = x->ts;
1485 f->value.function.name
1486 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1487 }
1488
1489
1490 void
gfc_resolve_link(gfc_expr * f,gfc_expr * p1 ATTRIBUTE_UNUSED,gfc_expr * p2 ATTRIBUTE_UNUSED)1491 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1492 gfc_expr *p2 ATTRIBUTE_UNUSED)
1493 {
1494 f->ts.type = BT_INTEGER;
1495 f->ts.kind = gfc_default_integer_kind;
1496 f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind);
1497 }
1498
1499
1500 void
gfc_resolve_loc(gfc_expr * f,gfc_expr * x)1501 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
1502 {
1503 f->ts.type= BT_INTEGER;
1504 f->ts.kind = gfc_index_integer_kind;
1505 f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
1506 }
1507
1508
1509 void
gfc_resolve_log(gfc_expr * f,gfc_expr * x)1510 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
1511 {
1512 f->ts = x->ts;
1513 f->value.function.name
1514 = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1515 }
1516
1517
1518 void
gfc_resolve_log10(gfc_expr * f,gfc_expr * x)1519 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
1520 {
1521 f->ts = x->ts;
1522 f->value.function.name
1523 = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type),
1524 x->ts.kind);
1525 }
1526
1527
1528 void
gfc_resolve_logical(gfc_expr * f,gfc_expr * a,gfc_expr * kind)1529 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1530 {
1531 f->ts.type = BT_LOGICAL;
1532 f->ts.kind = (kind == NULL)
1533 ? gfc_default_logical_kind : mpz_get_si (kind->value.integer);
1534 f->rank = a->rank;
1535
1536 f->value.function.name
1537 = gfc_get_string ("__logical_%d_%c%d", f->ts.kind,
1538 gfc_type_letter (a->ts.type), a->ts.kind);
1539 }
1540
1541
1542 void
gfc_resolve_matmul(gfc_expr * f,gfc_expr * a,gfc_expr * b)1543 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1544 {
1545 gfc_expr temp;
1546
1547 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1548 {
1549 f->ts.type = BT_LOGICAL;
1550 f->ts.kind = gfc_default_logical_kind;
1551 }
1552 else
1553 {
1554 temp.expr_type = EXPR_OP;
1555 gfc_clear_ts (&temp.ts);
1556 temp.value.op.op = INTRINSIC_NONE;
1557 temp.value.op.op1 = a;
1558 temp.value.op.op2 = b;
1559 gfc_type_convert_binary (&temp, 1);
1560 f->ts = temp.ts;
1561 }
1562
1563 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1564
1565 if (a->rank == 2 && b->rank == 2)
1566 {
1567 if (a->shape && b->shape)
1568 {
1569 f->shape = gfc_get_shape (f->rank);
1570 mpz_init_set (f->shape[0], a->shape[0]);
1571 mpz_init_set (f->shape[1], b->shape[1]);
1572 }
1573 }
1574 else if (a->rank == 1)
1575 {
1576 if (b->shape)
1577 {
1578 f->shape = gfc_get_shape (f->rank);
1579 mpz_init_set (f->shape[0], b->shape[1]);
1580 }
1581 }
1582 else
1583 {
1584 /* b->rank == 1 and a->rank == 2 here, all other cases have
1585 been caught in check.c. */
1586 if (a->shape)
1587 {
1588 f->shape = gfc_get_shape (f->rank);
1589 mpz_init_set (f->shape[0], a->shape[0]);
1590 }
1591 }
1592
1593 f->value.function.name
1594 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1595 f->ts.kind);
1596 }
1597
1598
1599 static void
gfc_resolve_minmax(const char * name,gfc_expr * f,gfc_actual_arglist * args)1600 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1601 {
1602 gfc_actual_arglist *a;
1603
1604 f->ts.type = args->expr->ts.type;
1605 f->ts.kind = args->expr->ts.kind;
1606 /* Find the largest type kind. */
1607 for (a = args->next; a; a = a->next)
1608 {
1609 if (a->expr->ts.kind > f->ts.kind)
1610 f->ts.kind = a->expr->ts.kind;
1611 }
1612
1613 /* Convert all parameters to the required kind. */
1614 for (a = args; a; a = a->next)
1615 {
1616 if (a->expr->ts.kind != f->ts.kind)
1617 gfc_convert_type (a->expr, &f->ts, 2);
1618 }
1619
1620 f->value.function.name
1621 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1622 }
1623
1624
1625 void
gfc_resolve_max(gfc_expr * f,gfc_actual_arglist * args)1626 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1627 {
1628 gfc_resolve_minmax ("__max_%c%d", f, args);
1629 }
1630
1631 /* The smallest kind for which a minloc and maxloc implementation exists. */
1632
1633 #define MINMAXLOC_MIN_KIND 4
1634
1635 void
gfc_resolve_maxloc(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back)1636 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1637 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1638 {
1639 const char *name;
1640 int i, j, idim;
1641 int fkind;
1642 int d_num;
1643
1644 f->ts.type = BT_INTEGER;
1645
1646 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1647 we do a type conversion further down. */
1648 if (kind)
1649 fkind = mpz_get_si (kind->value.integer);
1650 else
1651 fkind = gfc_default_integer_kind;
1652
1653 if (fkind < MINMAXLOC_MIN_KIND)
1654 f->ts.kind = MINMAXLOC_MIN_KIND;
1655 else
1656 f->ts.kind = fkind;
1657
1658 if (dim == NULL)
1659 {
1660 f->rank = 1;
1661 f->shape = gfc_get_shape (1);
1662 mpz_init_set_si (f->shape[0], array->rank);
1663 }
1664 else
1665 {
1666 f->rank = array->rank - 1;
1667 gfc_resolve_dim_arg (dim);
1668 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1669 {
1670 idim = (int) mpz_get_si (dim->value.integer);
1671 f->shape = gfc_get_shape (f->rank);
1672 for (i = 0, j = 0; i < f->rank; i++, j++)
1673 {
1674 if (i == (idim - 1))
1675 j++;
1676 mpz_init_set (f->shape[i], array->shape[j]);
1677 }
1678 }
1679 }
1680
1681 if (mask)
1682 {
1683 if (mask->rank == 0)
1684 name = "smaxloc";
1685 else
1686 name = "mmaxloc";
1687
1688 resolve_mask_arg (mask);
1689 }
1690 else
1691 name = "maxloc";
1692
1693 if (dim)
1694 {
1695 if (array->ts.type != BT_CHARACTER || f->rank != 0)
1696 d_num = 1;
1697 else
1698 d_num = 2;
1699 }
1700 else
1701 d_num = 0;
1702
1703 f->value.function.name
1704 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1705 gfc_type_letter (array->ts.type), array->ts.kind);
1706
1707 if (kind)
1708 fkind = mpz_get_si (kind->value.integer);
1709 else
1710 fkind = gfc_default_integer_kind;
1711
1712 if (fkind != f->ts.kind)
1713 {
1714 gfc_typespec ts;
1715 gfc_clear_ts (&ts);
1716
1717 ts.type = BT_INTEGER;
1718 ts.kind = fkind;
1719 gfc_convert_type_warn (f, &ts, 2, 0);
1720 }
1721
1722 if (back->ts.kind != gfc_logical_4_kind)
1723 {
1724 gfc_typespec ts;
1725 gfc_clear_ts (&ts);
1726 ts.type = BT_LOGICAL;
1727 ts.kind = gfc_logical_4_kind;
1728 gfc_convert_type_warn (back, &ts, 2, 0);
1729 }
1730 }
1731
1732
1733 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)1734 gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
1735 gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
1736 gfc_expr *back)
1737 {
1738 const char *name;
1739 int i, j, idim;
1740 int fkind;
1741 int d_num;
1742
1743 /* See at the end of the function for why this is necessary. */
1744
1745 if (f->do_not_resolve_again)
1746 return;
1747
1748 f->ts.type = BT_INTEGER;
1749
1750 /* We have a single library version, which uses index_type. */
1751
1752 if (kind)
1753 fkind = mpz_get_si (kind->value.integer);
1754 else
1755 fkind = gfc_default_integer_kind;
1756
1757 f->ts.kind = gfc_index_integer_kind;
1758
1759 /* Convert value. If array is not LOGICAL and value is, we already
1760 issued an error earlier. */
1761
1762 if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
1763 || array->ts.kind != value->ts.kind)
1764 gfc_convert_type_warn (value, &array->ts, 2, 0);
1765
1766 if (dim == NULL)
1767 {
1768 f->rank = 1;
1769 f->shape = gfc_get_shape (1);
1770 mpz_init_set_si (f->shape[0], array->rank);
1771 }
1772 else
1773 {
1774 f->rank = array->rank - 1;
1775 gfc_resolve_dim_arg (dim);
1776 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1777 {
1778 idim = (int) mpz_get_si (dim->value.integer);
1779 f->shape = gfc_get_shape (f->rank);
1780 for (i = 0, j = 0; i < f->rank; i++, j++)
1781 {
1782 if (i == (idim - 1))
1783 j++;
1784 mpz_init_set (f->shape[i], array->shape[j]);
1785 }
1786 }
1787 }
1788
1789 if (mask)
1790 {
1791 if (mask->rank == 0)
1792 name = "sfindloc";
1793 else
1794 name = "mfindloc";
1795
1796 resolve_mask_arg (mask);
1797 }
1798 else
1799 name = "findloc";
1800
1801 if (dim)
1802 {
1803 if (f->rank > 0)
1804 d_num = 1;
1805 else
1806 d_num = 2;
1807 }
1808 else
1809 d_num = 0;
1810
1811 if (back->ts.kind != gfc_logical_4_kind)
1812 {
1813 gfc_typespec ts;
1814 gfc_clear_ts (&ts);
1815 ts.type = BT_LOGICAL;
1816 ts.kind = gfc_logical_4_kind;
1817 gfc_convert_type_warn (back, &ts, 2, 0);
1818 }
1819
1820 f->value.function.name
1821 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1822 gfc_type_letter (array->ts.type, true), array->ts.kind);
1823
1824 /* We only have a single library function, so we need to convert
1825 here. If the function is resolved from within a convert
1826 function generated on a previous round of resolution, endless
1827 recursion could occur. Guard against that here. */
1828
1829 if (f->ts.kind != fkind)
1830 {
1831 f->do_not_resolve_again = 1;
1832 gfc_typespec ts;
1833 gfc_clear_ts (&ts);
1834
1835 ts.type = BT_INTEGER;
1836 ts.kind = fkind;
1837 gfc_convert_type_warn (f, &ts, 2, 0);
1838 }
1839
1840 }
1841
1842 void
gfc_resolve_maxval(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask)1843 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1844 gfc_expr *mask)
1845 {
1846 const char *name;
1847 int i, j, idim;
1848
1849 f->ts = array->ts;
1850
1851 if (dim != NULL)
1852 {
1853 f->rank = array->rank - 1;
1854 gfc_resolve_dim_arg (dim);
1855
1856 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1857 {
1858 idim = (int) mpz_get_si (dim->value.integer);
1859 f->shape = gfc_get_shape (f->rank);
1860 for (i = 0, j = 0; i < f->rank; i++, j++)
1861 {
1862 if (i == (idim - 1))
1863 j++;
1864 mpz_init_set (f->shape[i], array->shape[j]);
1865 }
1866 }
1867 }
1868
1869 if (mask)
1870 {
1871 if (mask->rank == 0)
1872 name = "smaxval";
1873 else
1874 name = "mmaxval";
1875
1876 resolve_mask_arg (mask);
1877 }
1878 else
1879 name = "maxval";
1880
1881 if (array->ts.type != BT_CHARACTER)
1882 f->value.function.name
1883 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1884 gfc_type_letter (array->ts.type), array->ts.kind);
1885 else
1886 f->value.function.name
1887 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1888 gfc_type_letter (array->ts.type), array->ts.kind);
1889 }
1890
1891
1892 void
gfc_resolve_mclock(gfc_expr * f)1893 gfc_resolve_mclock (gfc_expr *f)
1894 {
1895 f->ts.type = BT_INTEGER;
1896 f->ts.kind = 4;
1897 f->value.function.name = PREFIX ("mclock");
1898 }
1899
1900
1901 void
gfc_resolve_mclock8(gfc_expr * f)1902 gfc_resolve_mclock8 (gfc_expr *f)
1903 {
1904 f->ts.type = BT_INTEGER;
1905 f->ts.kind = 8;
1906 f->value.function.name = PREFIX ("mclock8");
1907 }
1908
1909
1910 void
gfc_resolve_mask(gfc_expr * f,gfc_expr * i ATTRIBUTE_UNUSED,gfc_expr * kind)1911 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1912 gfc_expr *kind)
1913 {
1914 f->ts.type = BT_INTEGER;
1915 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1916 : gfc_default_integer_kind;
1917
1918 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1919 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1920 else
1921 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1922 }
1923
1924
1925 void
gfc_resolve_merge(gfc_expr * f,gfc_expr * tsource,gfc_expr * fsource ATTRIBUTE_UNUSED,gfc_expr * mask ATTRIBUTE_UNUSED)1926 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1927 gfc_expr *fsource ATTRIBUTE_UNUSED,
1928 gfc_expr *mask ATTRIBUTE_UNUSED)
1929 {
1930 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1931 gfc_resolve_substring_charlen (tsource);
1932
1933 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1934 gfc_resolve_substring_charlen (fsource);
1935
1936 if (tsource->ts.type == BT_CHARACTER)
1937 check_charlen_present (tsource);
1938
1939 f->ts = tsource->ts;
1940 f->value.function.name
1941 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1942 tsource->ts.kind);
1943 }
1944
1945
1946 void
gfc_resolve_merge_bits(gfc_expr * f,gfc_expr * i,gfc_expr * j ATTRIBUTE_UNUSED,gfc_expr * mask ATTRIBUTE_UNUSED)1947 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1948 gfc_expr *j ATTRIBUTE_UNUSED,
1949 gfc_expr *mask ATTRIBUTE_UNUSED)
1950 {
1951 f->ts = i->ts;
1952 f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
1953 }
1954
1955
1956 void
gfc_resolve_min(gfc_expr * f,gfc_actual_arglist * args)1957 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1958 {
1959 gfc_resolve_minmax ("__min_%c%d", f, args);
1960 }
1961
1962
1963 void
gfc_resolve_minloc(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask,gfc_expr * kind,gfc_expr * back)1964 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1965 gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
1966 {
1967 const char *name;
1968 int i, j, idim;
1969 int fkind;
1970 int d_num;
1971
1972 f->ts.type = BT_INTEGER;
1973
1974 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1975 we do a type conversion further down. */
1976 if (kind)
1977 fkind = mpz_get_si (kind->value.integer);
1978 else
1979 fkind = gfc_default_integer_kind;
1980
1981 if (fkind < MINMAXLOC_MIN_KIND)
1982 f->ts.kind = MINMAXLOC_MIN_KIND;
1983 else
1984 f->ts.kind = fkind;
1985
1986 if (dim == NULL)
1987 {
1988 f->rank = 1;
1989 f->shape = gfc_get_shape (1);
1990 mpz_init_set_si (f->shape[0], array->rank);
1991 }
1992 else
1993 {
1994 f->rank = array->rank - 1;
1995 gfc_resolve_dim_arg (dim);
1996 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1997 {
1998 idim = (int) mpz_get_si (dim->value.integer);
1999 f->shape = gfc_get_shape (f->rank);
2000 for (i = 0, j = 0; i < f->rank; i++, j++)
2001 {
2002 if (i == (idim - 1))
2003 j++;
2004 mpz_init_set (f->shape[i], array->shape[j]);
2005 }
2006 }
2007 }
2008
2009 if (mask)
2010 {
2011 if (mask->rank == 0)
2012 name = "sminloc";
2013 else
2014 name = "mminloc";
2015
2016 resolve_mask_arg (mask);
2017 }
2018 else
2019 name = "minloc";
2020
2021 if (dim)
2022 {
2023 if (array->ts.type != BT_CHARACTER || f->rank != 0)
2024 d_num = 1;
2025 else
2026 d_num = 2;
2027 }
2028 else
2029 d_num = 0;
2030
2031 f->value.function.name
2032 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
2033 gfc_type_letter (array->ts.type), array->ts.kind);
2034
2035 if (fkind != f->ts.kind)
2036 {
2037 gfc_typespec ts;
2038 gfc_clear_ts (&ts);
2039
2040 ts.type = BT_INTEGER;
2041 ts.kind = fkind;
2042 gfc_convert_type_warn (f, &ts, 2, 0);
2043 }
2044
2045 if (back->ts.kind != gfc_logical_4_kind)
2046 {
2047 gfc_typespec ts;
2048 gfc_clear_ts (&ts);
2049 ts.type = BT_LOGICAL;
2050 ts.kind = gfc_logical_4_kind;
2051 gfc_convert_type_warn (back, &ts, 2, 0);
2052 }
2053 }
2054
2055
2056 void
gfc_resolve_minval(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask)2057 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2058 gfc_expr *mask)
2059 {
2060 const char *name;
2061 int i, j, idim;
2062
2063 f->ts = array->ts;
2064
2065 if (dim != NULL)
2066 {
2067 f->rank = array->rank - 1;
2068 gfc_resolve_dim_arg (dim);
2069
2070 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2071 {
2072 idim = (int) mpz_get_si (dim->value.integer);
2073 f->shape = gfc_get_shape (f->rank);
2074 for (i = 0, j = 0; i < f->rank; i++, j++)
2075 {
2076 if (i == (idim - 1))
2077 j++;
2078 mpz_init_set (f->shape[i], array->shape[j]);
2079 }
2080 }
2081 }
2082
2083 if (mask)
2084 {
2085 if (mask->rank == 0)
2086 name = "sminval";
2087 else
2088 name = "mminval";
2089
2090 resolve_mask_arg (mask);
2091 }
2092 else
2093 name = "minval";
2094
2095 if (array->ts.type != BT_CHARACTER)
2096 f->value.function.name
2097 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2098 gfc_type_letter (array->ts.type), array->ts.kind);
2099 else
2100 f->value.function.name
2101 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2102 gfc_type_letter (array->ts.type), array->ts.kind);
2103 }
2104
2105
2106 void
gfc_resolve_mod(gfc_expr * f,gfc_expr * a,gfc_expr * p)2107 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2108 {
2109 f->ts.type = a->ts.type;
2110 if (p != NULL)
2111 f->ts.kind = gfc_kind_max (a,p);
2112 else
2113 f->ts.kind = a->ts.kind;
2114
2115 if (p != NULL && a->ts.kind != p->ts.kind)
2116 {
2117 if (a->ts.kind == gfc_kind_max (a,p))
2118 gfc_convert_type (p, &a->ts, 2);
2119 else
2120 gfc_convert_type (a, &p->ts, 2);
2121 }
2122
2123 f->value.function.name
2124 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
2125 }
2126
2127
2128 void
gfc_resolve_modulo(gfc_expr * f,gfc_expr * a,gfc_expr * p)2129 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2130 {
2131 f->ts.type = a->ts.type;
2132 if (p != NULL)
2133 f->ts.kind = gfc_kind_max (a,p);
2134 else
2135 f->ts.kind = a->ts.kind;
2136
2137 if (p != NULL && a->ts.kind != p->ts.kind)
2138 {
2139 if (a->ts.kind == gfc_kind_max (a,p))
2140 gfc_convert_type (p, &a->ts, 2);
2141 else
2142 gfc_convert_type (a, &p->ts, 2);
2143 }
2144
2145 f->value.function.name
2146 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2147 f->ts.kind);
2148 }
2149
2150 void
gfc_resolve_nearest(gfc_expr * f,gfc_expr * a,gfc_expr * p)2151 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2152 {
2153 if (p->ts.kind != a->ts.kind)
2154 gfc_convert_type (p, &a->ts, 2);
2155
2156 f->ts = a->ts;
2157 f->value.function.name
2158 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2159 a->ts.kind);
2160 }
2161
2162 void
gfc_resolve_nint(gfc_expr * f,gfc_expr * a,gfc_expr * kind)2163 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2164 {
2165 f->ts.type = BT_INTEGER;
2166 f->ts.kind = (kind == NULL)
2167 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2168 f->value.function.name
2169 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2170 }
2171
2172
2173 void
gfc_resolve_norm2(gfc_expr * f,gfc_expr * array,gfc_expr * dim)2174 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2175 {
2176 resolve_transformational ("norm2", f, array, dim, NULL);
2177 }
2178
2179
2180 void
gfc_resolve_not(gfc_expr * f,gfc_expr * i)2181 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2182 {
2183 f->ts = i->ts;
2184 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
2185 }
2186
2187
2188 void
gfc_resolve_or(gfc_expr * f,gfc_expr * i,gfc_expr * j)2189 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2190 {
2191 f->ts.type = i->ts.type;
2192 f->ts.kind = gfc_kind_max (i, j);
2193
2194 if (i->ts.kind != j->ts.kind)
2195 {
2196 if (i->ts.kind == gfc_kind_max (i, j))
2197 gfc_convert_type (j, &i->ts, 2);
2198 else
2199 gfc_convert_type (i, &j->ts, 2);
2200 }
2201
2202 f->value.function.name
2203 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2204 }
2205
2206
2207 void
gfc_resolve_pack(gfc_expr * f,gfc_expr * array,gfc_expr * mask,gfc_expr * vector ATTRIBUTE_UNUSED)2208 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2209 gfc_expr *vector ATTRIBUTE_UNUSED)
2210 {
2211 if (array->ts.type == BT_CHARACTER && array->ref)
2212 gfc_resolve_substring_charlen (array);
2213
2214 f->ts = array->ts;
2215 f->rank = 1;
2216
2217 resolve_mask_arg (mask);
2218
2219 if (mask->rank != 0)
2220 {
2221 if (array->ts.type == BT_CHARACTER)
2222 f->value.function.name
2223 = array->ts.kind == 1 ? PREFIX ("pack_char")
2224 : gfc_get_string
2225 (PREFIX ("pack_char%d"),
2226 array->ts.kind);
2227 else
2228 f->value.function.name = PREFIX ("pack");
2229 }
2230 else
2231 {
2232 if (array->ts.type == BT_CHARACTER)
2233 f->value.function.name
2234 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2235 : gfc_get_string
2236 (PREFIX ("pack_s_char%d"),
2237 array->ts.kind);
2238 else
2239 f->value.function.name = PREFIX ("pack_s");
2240 }
2241 }
2242
2243
2244 void
gfc_resolve_parity(gfc_expr * f,gfc_expr * array,gfc_expr * dim)2245 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2246 {
2247 resolve_transformational ("parity", f, array, dim, NULL);
2248 }
2249
2250
2251 void
gfc_resolve_product(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask)2252 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2253 gfc_expr *mask)
2254 {
2255 resolve_transformational ("product", f, array, dim, mask);
2256 }
2257
2258
2259 void
gfc_resolve_rank(gfc_expr * f,gfc_expr * array ATTRIBUTE_UNUSED)2260 gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2261 {
2262 f->ts.type = BT_INTEGER;
2263 f->ts.kind = gfc_default_integer_kind;
2264 f->value.function.name = gfc_get_string ("__rank");
2265 }
2266
2267
2268 void
gfc_resolve_real(gfc_expr * f,gfc_expr * a,gfc_expr * kind)2269 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2270 {
2271 f->ts.type = BT_REAL;
2272
2273 if (kind != NULL)
2274 f->ts.kind = mpz_get_si (kind->value.integer);
2275 else
2276 f->ts.kind = (a->ts.type == BT_COMPLEX)
2277 ? a->ts.kind : gfc_default_real_kind;
2278
2279 f->value.function.name
2280 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2281 gfc_type_letter (a->ts.type), a->ts.kind);
2282 }
2283
2284
2285 void
gfc_resolve_realpart(gfc_expr * f,gfc_expr * a)2286 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2287 {
2288 f->ts.type = BT_REAL;
2289 f->ts.kind = a->ts.kind;
2290 f->value.function.name
2291 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2292 gfc_type_letter (a->ts.type), a->ts.kind);
2293 }
2294
2295
2296 void
gfc_resolve_rename(gfc_expr * f,gfc_expr * p1 ATTRIBUTE_UNUSED,gfc_expr * p2 ATTRIBUTE_UNUSED)2297 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2298 gfc_expr *p2 ATTRIBUTE_UNUSED)
2299 {
2300 f->ts.type = BT_INTEGER;
2301 f->ts.kind = gfc_default_integer_kind;
2302 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2303 }
2304
2305
2306 void
gfc_resolve_repeat(gfc_expr * f,gfc_expr * string,gfc_expr * ncopies)2307 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2308 gfc_expr *ncopies)
2309 {
2310 gfc_expr *tmp;
2311 f->ts.type = BT_CHARACTER;
2312 f->ts.kind = string->ts.kind;
2313 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2314
2315 /* If possible, generate a character length. */
2316 if (f->ts.u.cl == NULL)
2317 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2318
2319 tmp = NULL;
2320 if (string->expr_type == EXPR_CONSTANT)
2321 {
2322 tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
2323 string->value.character.length);
2324 }
2325 else if (string->ts.u.cl && string->ts.u.cl->length)
2326 {
2327 tmp = gfc_copy_expr (string->ts.u.cl->length);
2328 }
2329
2330 if (tmp)
2331 f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2332 }
2333
2334
2335 void
gfc_resolve_reshape(gfc_expr * f,gfc_expr * source,gfc_expr * shape,gfc_expr * pad ATTRIBUTE_UNUSED,gfc_expr * order ATTRIBUTE_UNUSED)2336 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2337 gfc_expr *pad ATTRIBUTE_UNUSED,
2338 gfc_expr *order ATTRIBUTE_UNUSED)
2339 {
2340 mpz_t rank;
2341 int kind;
2342 int i;
2343
2344 if (source->ts.type == BT_CHARACTER && source->ref)
2345 gfc_resolve_substring_charlen (source);
2346
2347 f->ts = source->ts;
2348
2349 gfc_array_size (shape, &rank);
2350 f->rank = mpz_get_si (rank);
2351 mpz_clear (rank);
2352 switch (source->ts.type)
2353 {
2354 case BT_COMPLEX:
2355 case BT_REAL:
2356 case BT_INTEGER:
2357 case BT_LOGICAL:
2358 case BT_CHARACTER:
2359 kind = source->ts.kind;
2360 break;
2361
2362 default:
2363 kind = 0;
2364 break;
2365 }
2366
2367 switch (kind)
2368 {
2369 case 4:
2370 case 8:
2371 case 10:
2372 case 16:
2373 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2374 f->value.function.name
2375 = gfc_get_string (PREFIX ("reshape_%c%d"),
2376 gfc_type_letter (source->ts.type),
2377 source->ts.kind);
2378 else if (source->ts.type == BT_CHARACTER)
2379 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2380 kind);
2381 else
2382 f->value.function.name
2383 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2384 break;
2385
2386 default:
2387 f->value.function.name = (source->ts.type == BT_CHARACTER
2388 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2389 break;
2390 }
2391
2392 if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
2393 {
2394 gfc_constructor *c;
2395 f->shape = gfc_get_shape (f->rank);
2396 c = gfc_constructor_first (shape->value.constructor);
2397 for (i = 0; i < f->rank; i++)
2398 {
2399 mpz_init_set (f->shape[i], c->expr->value.integer);
2400 c = gfc_constructor_next (c);
2401 }
2402 }
2403
2404 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2405 so many runtime variations. */
2406 if (shape->ts.kind != gfc_index_integer_kind)
2407 {
2408 gfc_typespec ts = shape->ts;
2409 ts.kind = gfc_index_integer_kind;
2410 gfc_convert_type_warn (shape, &ts, 2, 0);
2411 }
2412 if (order && order->ts.kind != gfc_index_integer_kind)
2413 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2414 }
2415
2416
2417 void
gfc_resolve_rrspacing(gfc_expr * f,gfc_expr * x)2418 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2419 {
2420 f->ts = x->ts;
2421 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2422 }
2423
2424 void
gfc_resolve_fe_runtime_error(gfc_code * c)2425 gfc_resolve_fe_runtime_error (gfc_code *c)
2426 {
2427 const char *name;
2428 gfc_actual_arglist *a;
2429
2430 name = gfc_get_string (PREFIX ("runtime_error"));
2431
2432 for (a = c->ext.actual->next; a; a = a->next)
2433 a->name = "%VAL";
2434
2435 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2436 /* We set the backend_decl here because runtime_error is a
2437 variadic function and we would use the wrong calling
2438 convention otherwise. */
2439 c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
2440 }
2441
2442 void
gfc_resolve_scale(gfc_expr * f,gfc_expr * x,gfc_expr * i ATTRIBUTE_UNUSED)2443 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2444 {
2445 f->ts = x->ts;
2446 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2447 }
2448
2449
2450 void
gfc_resolve_scan(gfc_expr * f,gfc_expr * string,gfc_expr * set ATTRIBUTE_UNUSED,gfc_expr * back ATTRIBUTE_UNUSED,gfc_expr * kind)2451 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2452 gfc_expr *set ATTRIBUTE_UNUSED,
2453 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2454 {
2455 f->ts.type = BT_INTEGER;
2456 if (kind)
2457 f->ts.kind = mpz_get_si (kind->value.integer);
2458 else
2459 f->ts.kind = gfc_default_integer_kind;
2460 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2461 }
2462
2463
2464 void
gfc_resolve_secnds(gfc_expr * t1,gfc_expr * t0)2465 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2466 {
2467 t1->ts = t0->ts;
2468 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2469 }
2470
2471
2472 void
gfc_resolve_set_exponent(gfc_expr * f,gfc_expr * x,gfc_expr * i ATTRIBUTE_UNUSED)2473 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2474 gfc_expr *i ATTRIBUTE_UNUSED)
2475 {
2476 f->ts = x->ts;
2477 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2478 }
2479
2480
2481 void
gfc_resolve_shape(gfc_expr * f,gfc_expr * array,gfc_expr * kind)2482 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2483 {
2484 f->ts.type = BT_INTEGER;
2485
2486 if (kind)
2487 f->ts.kind = mpz_get_si (kind->value.integer);
2488 else
2489 f->ts.kind = gfc_default_integer_kind;
2490
2491 f->rank = 1;
2492 if (array->rank != -1)
2493 {
2494 f->shape = gfc_get_shape (1);
2495 mpz_init_set_ui (f->shape[0], array->rank);
2496 }
2497
2498 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2499 }
2500
2501
2502 void
gfc_resolve_shift(gfc_expr * f,gfc_expr * i,gfc_expr * shift ATTRIBUTE_UNUSED)2503 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2504 {
2505 f->ts = i->ts;
2506 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2507 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2508 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2509 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2510 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2511 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2512 else
2513 gcc_unreachable ();
2514 }
2515
2516
2517 void
gfc_resolve_sign(gfc_expr * f,gfc_expr * a,gfc_expr * b ATTRIBUTE_UNUSED)2518 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2519 {
2520 f->ts = a->ts;
2521 f->value.function.name
2522 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2523 }
2524
2525
2526 void
gfc_resolve_signal(gfc_expr * f,gfc_expr * number,gfc_expr * handler)2527 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2528 {
2529 f->ts.type = BT_INTEGER;
2530 f->ts.kind = gfc_c_int_kind;
2531
2532 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2533 if (handler->ts.type == BT_INTEGER)
2534 {
2535 if (handler->ts.kind != gfc_c_int_kind)
2536 gfc_convert_type (handler, &f->ts, 2);
2537 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2538 }
2539 else
2540 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2541
2542 if (number->ts.kind != gfc_c_int_kind)
2543 gfc_convert_type (number, &f->ts, 2);
2544 }
2545
2546
2547 void
gfc_resolve_sin(gfc_expr * f,gfc_expr * x)2548 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2549 {
2550 f->ts = x->ts;
2551 f->value.function.name
2552 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2553 }
2554
2555
2556 void
gfc_resolve_sinh(gfc_expr * f,gfc_expr * x)2557 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2558 {
2559 f->ts = x->ts;
2560 f->value.function.name
2561 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2562 }
2563
2564
2565 void
gfc_resolve_size(gfc_expr * f,gfc_expr * array ATTRIBUTE_UNUSED,gfc_expr * dim ATTRIBUTE_UNUSED,gfc_expr * kind)2566 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2567 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2568 {
2569 f->ts.type = BT_INTEGER;
2570 if (kind)
2571 f->ts.kind = mpz_get_si (kind->value.integer);
2572 else
2573 f->ts.kind = gfc_default_integer_kind;
2574 }
2575
2576
2577 void
gfc_resolve_stride(gfc_expr * f,gfc_expr * array ATTRIBUTE_UNUSED,gfc_expr * dim ATTRIBUTE_UNUSED)2578 gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2579 gfc_expr *dim ATTRIBUTE_UNUSED)
2580 {
2581 f->ts.type = BT_INTEGER;
2582 f->ts.kind = gfc_index_integer_kind;
2583 }
2584
2585
2586 void
gfc_resolve_spacing(gfc_expr * f,gfc_expr * x)2587 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2588 {
2589 f->ts = x->ts;
2590 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2591 }
2592
2593
2594 void
gfc_resolve_spread(gfc_expr * f,gfc_expr * source,gfc_expr * dim,gfc_expr * ncopies)2595 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2596 gfc_expr *ncopies)
2597 {
2598 if (source->ts.type == BT_CHARACTER && source->ref)
2599 gfc_resolve_substring_charlen (source);
2600
2601 if (source->ts.type == BT_CHARACTER)
2602 check_charlen_present (source);
2603
2604 f->ts = source->ts;
2605 f->rank = source->rank + 1;
2606 if (source->rank == 0)
2607 {
2608 if (source->ts.type == BT_CHARACTER)
2609 f->value.function.name
2610 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2611 : gfc_get_string
2612 (PREFIX ("spread_char%d_scalar"),
2613 source->ts.kind);
2614 else
2615 f->value.function.name = PREFIX ("spread_scalar");
2616 }
2617 else
2618 {
2619 if (source->ts.type == BT_CHARACTER)
2620 f->value.function.name
2621 = source->ts.kind == 1 ? PREFIX ("spread_char")
2622 : gfc_get_string
2623 (PREFIX ("spread_char%d"),
2624 source->ts.kind);
2625 else
2626 f->value.function.name = PREFIX ("spread");
2627 }
2628
2629 if (dim && gfc_is_constant_expr (dim)
2630 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2631 {
2632 int i, idim;
2633 idim = mpz_get_ui (dim->value.integer);
2634 f->shape = gfc_get_shape (f->rank);
2635 for (i = 0; i < (idim - 1); i++)
2636 mpz_init_set (f->shape[i], source->shape[i]);
2637
2638 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2639
2640 for (i = idim; i < f->rank ; i++)
2641 mpz_init_set (f->shape[i], source->shape[i-1]);
2642 }
2643
2644
2645 gfc_resolve_dim_arg (dim);
2646 gfc_resolve_index (ncopies, 1);
2647 }
2648
2649
2650 void
gfc_resolve_sqrt(gfc_expr * f,gfc_expr * x)2651 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2652 {
2653 f->ts = x->ts;
2654 f->value.function.name
2655 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2656 }
2657
2658
2659 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2660
2661 void
gfc_resolve_stat(gfc_expr * f,gfc_expr * n ATTRIBUTE_UNUSED,gfc_expr * a ATTRIBUTE_UNUSED)2662 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2663 gfc_expr *a ATTRIBUTE_UNUSED)
2664 {
2665 f->ts.type = BT_INTEGER;
2666 f->ts.kind = gfc_default_integer_kind;
2667 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2668 }
2669
2670
2671 void
gfc_resolve_lstat(gfc_expr * f,gfc_expr * n ATTRIBUTE_UNUSED,gfc_expr * a ATTRIBUTE_UNUSED)2672 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2673 gfc_expr *a ATTRIBUTE_UNUSED)
2674 {
2675 f->ts.type = BT_INTEGER;
2676 f->ts.kind = gfc_default_integer_kind;
2677 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2678 }
2679
2680
2681 void
gfc_resolve_fstat(gfc_expr * f,gfc_expr * n,gfc_expr * a ATTRIBUTE_UNUSED)2682 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2683 {
2684 f->ts.type = BT_INTEGER;
2685 f->ts.kind = gfc_default_integer_kind;
2686 if (n->ts.kind != f->ts.kind)
2687 gfc_convert_type (n, &f->ts, 2);
2688
2689 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2690 }
2691
2692
2693 void
gfc_resolve_fgetc(gfc_expr * f,gfc_expr * u,gfc_expr * c ATTRIBUTE_UNUSED)2694 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2695 {
2696 gfc_typespec ts;
2697 gfc_clear_ts (&ts);
2698
2699 f->ts.type = BT_INTEGER;
2700 f->ts.kind = gfc_c_int_kind;
2701 if (u->ts.kind != gfc_c_int_kind)
2702 {
2703 ts.type = BT_INTEGER;
2704 ts.kind = gfc_c_int_kind;
2705 ts.u.derived = NULL;
2706 ts.u.cl = NULL;
2707 gfc_convert_type (u, &ts, 2);
2708 }
2709
2710 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2711 }
2712
2713
2714 void
gfc_resolve_fget(gfc_expr * f,gfc_expr * c ATTRIBUTE_UNUSED)2715 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2716 {
2717 f->ts.type = BT_INTEGER;
2718 f->ts.kind = gfc_c_int_kind;
2719 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2720 }
2721
2722
2723 void
gfc_resolve_fputc(gfc_expr * f,gfc_expr * u,gfc_expr * c ATTRIBUTE_UNUSED)2724 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2725 {
2726 gfc_typespec ts;
2727 gfc_clear_ts (&ts);
2728
2729 f->ts.type = BT_INTEGER;
2730 f->ts.kind = gfc_c_int_kind;
2731 if (u->ts.kind != gfc_c_int_kind)
2732 {
2733 ts.type = BT_INTEGER;
2734 ts.kind = gfc_c_int_kind;
2735 ts.u.derived = NULL;
2736 ts.u.cl = NULL;
2737 gfc_convert_type (u, &ts, 2);
2738 }
2739
2740 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2741 }
2742
2743
2744 void
gfc_resolve_fput(gfc_expr * f,gfc_expr * c ATTRIBUTE_UNUSED)2745 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2746 {
2747 f->ts.type = BT_INTEGER;
2748 f->ts.kind = gfc_c_int_kind;
2749 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2750 }
2751
2752
2753 void
gfc_resolve_ftell(gfc_expr * f,gfc_expr * u)2754 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2755 {
2756 gfc_typespec ts;
2757 gfc_clear_ts (&ts);
2758
2759 f->ts.type = BT_INTEGER;
2760 f->ts.kind = gfc_intio_kind;
2761 if (u->ts.kind != gfc_c_int_kind)
2762 {
2763 ts.type = BT_INTEGER;
2764 ts.kind = gfc_c_int_kind;
2765 ts.u.derived = NULL;
2766 ts.u.cl = NULL;
2767 gfc_convert_type (u, &ts, 2);
2768 }
2769
2770 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2771 }
2772
2773
2774 void
gfc_resolve_storage_size(gfc_expr * f,gfc_expr * a ATTRIBUTE_UNUSED,gfc_expr * kind)2775 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2776 gfc_expr *kind)
2777 {
2778 f->ts.type = BT_INTEGER;
2779 if (kind)
2780 f->ts.kind = mpz_get_si (kind->value.integer);
2781 else
2782 f->ts.kind = gfc_default_integer_kind;
2783 }
2784
2785
2786 void
gfc_resolve_sum(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * mask)2787 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2788 {
2789 resolve_transformational ("sum", f, array, dim, mask);
2790 }
2791
2792
2793 void
gfc_resolve_symlnk(gfc_expr * f,gfc_expr * p1 ATTRIBUTE_UNUSED,gfc_expr * p2 ATTRIBUTE_UNUSED)2794 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2795 gfc_expr *p2 ATTRIBUTE_UNUSED)
2796 {
2797 f->ts.type = BT_INTEGER;
2798 f->ts.kind = gfc_default_integer_kind;
2799 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2800 }
2801
2802
2803 /* Resolve the g77 compatibility function SYSTEM. */
2804
2805 void
gfc_resolve_system(gfc_expr * f,gfc_expr * n ATTRIBUTE_UNUSED)2806 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2807 {
2808 f->ts.type = BT_INTEGER;
2809 f->ts.kind = 4;
2810 f->value.function.name = gfc_get_string (PREFIX ("system"));
2811 }
2812
2813
2814 void
gfc_resolve_tan(gfc_expr * f,gfc_expr * x)2815 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2816 {
2817 f->ts = x->ts;
2818 f->value.function.name
2819 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2820 }
2821
2822
2823 void
gfc_resolve_tanh(gfc_expr * f,gfc_expr * x)2824 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2825 {
2826 f->ts = x->ts;
2827 f->value.function.name
2828 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2829 }
2830
2831
2832 /* Resolve failed_images (team, kind). */
2833
2834 void
gfc_resolve_failed_images(gfc_expr * f,gfc_expr * team ATTRIBUTE_UNUSED,gfc_expr * kind)2835 gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2836 gfc_expr *kind)
2837 {
2838 static char failed_images[] = "_gfortran_caf_failed_images";
2839 f->rank = 1;
2840 f->ts.type = BT_INTEGER;
2841 if (kind == NULL)
2842 f->ts.kind = gfc_default_integer_kind;
2843 else
2844 gfc_extract_int (kind, &f->ts.kind);
2845 f->value.function.name = failed_images;
2846 }
2847
2848
2849 /* Resolve image_status (image, team). */
2850
2851 void
gfc_resolve_image_status(gfc_expr * f,gfc_expr * image ATTRIBUTE_UNUSED,gfc_expr * team ATTRIBUTE_UNUSED)2852 gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2853 gfc_expr *team ATTRIBUTE_UNUSED)
2854 {
2855 static char image_status[] = "_gfortran_caf_image_status";
2856 f->ts.type = BT_INTEGER;
2857 f->ts.kind = gfc_default_integer_kind;
2858 f->value.function.name = image_status;
2859 }
2860
2861
2862 /* Resolve get_team (). */
2863
2864 void
gfc_resolve_get_team(gfc_expr * f,gfc_expr * level ATTRIBUTE_UNUSED)2865 gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
2866 {
2867 static char get_team[] = "_gfortran_caf_get_team";
2868 f->rank = 0;
2869 f->ts.type = BT_INTEGER;
2870 f->ts.kind = gfc_default_integer_kind;
2871 f->value.function.name = get_team;
2872 }
2873
2874
2875 /* Resolve image_index (...). */
2876
2877 void
gfc_resolve_image_index(gfc_expr * f,gfc_expr * array ATTRIBUTE_UNUSED,gfc_expr * sub ATTRIBUTE_UNUSED)2878 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2879 gfc_expr *sub ATTRIBUTE_UNUSED)
2880 {
2881 static char image_index[] = "__image_index";
2882 f->ts.type = BT_INTEGER;
2883 f->ts.kind = gfc_default_integer_kind;
2884 f->value.function.name = image_index;
2885 }
2886
2887
2888 /* Resolve stopped_images (team, kind). */
2889
2890 void
gfc_resolve_stopped_images(gfc_expr * f,gfc_expr * team ATTRIBUTE_UNUSED,gfc_expr * kind)2891 gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2892 gfc_expr *kind)
2893 {
2894 static char stopped_images[] = "_gfortran_caf_stopped_images";
2895 f->rank = 1;
2896 f->ts.type = BT_INTEGER;
2897 if (kind == NULL)
2898 f->ts.kind = gfc_default_integer_kind;
2899 else
2900 gfc_extract_int (kind, &f->ts.kind);
2901 f->value.function.name = stopped_images;
2902 }
2903
2904
2905 /* Resolve team_number (team). */
2906
2907 void
gfc_resolve_team_number(gfc_expr * f,gfc_expr * team ATTRIBUTE_UNUSED)2908 gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
2909 {
2910 static char team_number[] = "_gfortran_caf_team_number";
2911 f->rank = 0;
2912 f->ts.type = BT_INTEGER;
2913 f->ts.kind = gfc_default_integer_kind;
2914 f->value.function.name = team_number;
2915 }
2916
2917
2918 void
gfc_resolve_this_image(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * distance ATTRIBUTE_UNUSED)2919 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2920 gfc_expr *distance ATTRIBUTE_UNUSED)
2921 {
2922 static char this_image[] = "__this_image";
2923 if (array && gfc_is_coarray (array))
2924 resolve_bound (f, array, dim, NULL, "__this_image", true);
2925 else
2926 {
2927 f->ts.type = BT_INTEGER;
2928 f->ts.kind = gfc_default_integer_kind;
2929 f->value.function.name = this_image;
2930 }
2931 }
2932
2933
2934 void
gfc_resolve_time(gfc_expr * f)2935 gfc_resolve_time (gfc_expr *f)
2936 {
2937 f->ts.type = BT_INTEGER;
2938 f->ts.kind = 4;
2939 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2940 }
2941
2942
2943 void
gfc_resolve_time8(gfc_expr * f)2944 gfc_resolve_time8 (gfc_expr *f)
2945 {
2946 f->ts.type = BT_INTEGER;
2947 f->ts.kind = 8;
2948 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2949 }
2950
2951
2952 void
gfc_resolve_transfer(gfc_expr * f,gfc_expr * source ATTRIBUTE_UNUSED,gfc_expr * mold,gfc_expr * size)2953 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2954 gfc_expr *mold, gfc_expr *size)
2955 {
2956 /* TODO: Make this do something meaningful. */
2957 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2958
2959 if (mold->ts.type == BT_CHARACTER
2960 && !mold->ts.u.cl->length
2961 && gfc_is_constant_expr (mold))
2962 {
2963 int len;
2964 if (mold->expr_type == EXPR_CONSTANT)
2965 {
2966 len = mold->value.character.length;
2967 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2968 NULL, len);
2969 }
2970 else
2971 {
2972 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
2973 len = c->expr->value.character.length;
2974 mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
2975 NULL, len);
2976 }
2977 }
2978
2979 f->ts = mold->ts;
2980
2981 if (size == NULL && mold->rank == 0)
2982 {
2983 f->rank = 0;
2984 f->value.function.name = transfer0;
2985 }
2986 else
2987 {
2988 f->rank = 1;
2989 f->value.function.name = transfer1;
2990 if (size && gfc_is_constant_expr (size))
2991 {
2992 f->shape = gfc_get_shape (1);
2993 mpz_init_set (f->shape[0], size->value.integer);
2994 }
2995 }
2996 }
2997
2998
2999 void
gfc_resolve_transpose(gfc_expr * f,gfc_expr * matrix)3000 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3001 {
3002
3003 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3004 gfc_resolve_substring_charlen (matrix);
3005
3006 f->ts = matrix->ts;
3007 f->rank = 2;
3008 if (matrix->shape)
3009 {
3010 f->shape = gfc_get_shape (2);
3011 mpz_init_set (f->shape[0], matrix->shape[1]);
3012 mpz_init_set (f->shape[1], matrix->shape[0]);
3013 }
3014
3015 switch (matrix->ts.kind)
3016 {
3017 case 4:
3018 case 8:
3019 case 10:
3020 case 16:
3021 switch (matrix->ts.type)
3022 {
3023 case BT_REAL:
3024 case BT_COMPLEX:
3025 f->value.function.name
3026 = gfc_get_string (PREFIX ("transpose_%c%d"),
3027 gfc_type_letter (matrix->ts.type),
3028 matrix->ts.kind);
3029 break;
3030
3031 case BT_INTEGER:
3032 case BT_LOGICAL:
3033 /* Use the integer routines for real and logical cases. This
3034 assumes they all have the same alignment requirements. */
3035 f->value.function.name
3036 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3037 break;
3038
3039 default:
3040 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3041 f->value.function.name = PREFIX ("transpose_char4");
3042 else
3043 f->value.function.name = PREFIX ("transpose");
3044 break;
3045 }
3046 break;
3047
3048 default:
3049 f->value.function.name = (matrix->ts.type == BT_CHARACTER
3050 ? PREFIX ("transpose_char")
3051 : PREFIX ("transpose"));
3052 break;
3053 }
3054 }
3055
3056
3057 void
gfc_resolve_trim(gfc_expr * f,gfc_expr * string)3058 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3059 {
3060 f->ts.type = BT_CHARACTER;
3061 f->ts.kind = string->ts.kind;
3062 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3063 }
3064
3065
3066 /* Resolve the degree trignometric functions. This amounts to setting
3067 the function return type-spec from its argument and building a
3068 library function names of the form _gfortran_sind_r4. */
3069
3070 void
gfc_resolve_trigd(gfc_expr * f,gfc_expr * x)3071 gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
3072 {
3073 f->ts = x->ts;
3074 f->value.function.name
3075 = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
3076 gfc_type_letter (x->ts.type), x->ts.kind);
3077 }
3078
3079
3080 void
gfc_resolve_trigd2(gfc_expr * f,gfc_expr * y,gfc_expr * x)3081 gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
3082 {
3083 f->ts = y->ts;
3084 f->value.function.name
3085 = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
3086 x->ts.kind);
3087 }
3088
3089
3090 void
gfc_resolve_ubound(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * kind)3091 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3092 {
3093 resolve_bound (f, array, dim, kind, "__ubound", false);
3094 }
3095
3096
3097 void
gfc_resolve_ucobound(gfc_expr * f,gfc_expr * array,gfc_expr * dim,gfc_expr * kind)3098 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3099 {
3100 resolve_bound (f, array, dim, kind, "__ucobound", true);
3101 }
3102
3103
3104 /* Resolve the g77 compatibility function UMASK. */
3105
3106 void
gfc_resolve_umask(gfc_expr * f,gfc_expr * n)3107 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3108 {
3109 f->ts.type = BT_INTEGER;
3110 f->ts.kind = n->ts.kind;
3111 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3112 }
3113
3114
3115 /* Resolve the g77 compatibility function UNLINK. */
3116
3117 void
gfc_resolve_unlink(gfc_expr * f,gfc_expr * n ATTRIBUTE_UNUSED)3118 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3119 {
3120 f->ts.type = BT_INTEGER;
3121 f->ts.kind = 4;
3122 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3123 }
3124
3125
3126 void
gfc_resolve_ttynam(gfc_expr * f,gfc_expr * unit)3127 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3128 {
3129 gfc_typespec ts;
3130 gfc_clear_ts (&ts);
3131
3132 f->ts.type = BT_CHARACTER;
3133 f->ts.kind = gfc_default_character_kind;
3134
3135 if (unit->ts.kind != gfc_c_int_kind)
3136 {
3137 ts.type = BT_INTEGER;
3138 ts.kind = gfc_c_int_kind;
3139 ts.u.derived = NULL;
3140 ts.u.cl = NULL;
3141 gfc_convert_type (unit, &ts, 2);
3142 }
3143
3144 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3145 }
3146
3147
3148 void
gfc_resolve_unpack(gfc_expr * f,gfc_expr * vector,gfc_expr * mask,gfc_expr * field ATTRIBUTE_UNUSED)3149 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3150 gfc_expr *field ATTRIBUTE_UNUSED)
3151 {
3152 if (vector->ts.type == BT_CHARACTER && vector->ref)
3153 gfc_resolve_substring_charlen (vector);
3154
3155 f->ts = vector->ts;
3156 f->rank = mask->rank;
3157 resolve_mask_arg (mask);
3158
3159 if (vector->ts.type == BT_CHARACTER)
3160 {
3161 if (vector->ts.kind == 1)
3162 f->value.function.name
3163 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3164 else
3165 f->value.function.name
3166 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3167 field->rank > 0 ? 1 : 0, vector->ts.kind);
3168 }
3169 else
3170 f->value.function.name
3171 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3172 }
3173
3174
3175 void
gfc_resolve_verify(gfc_expr * f,gfc_expr * string,gfc_expr * set ATTRIBUTE_UNUSED,gfc_expr * back ATTRIBUTE_UNUSED,gfc_expr * kind)3176 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3177 gfc_expr *set ATTRIBUTE_UNUSED,
3178 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3179 {
3180 f->ts.type = BT_INTEGER;
3181 if (kind)
3182 f->ts.kind = mpz_get_si (kind->value.integer);
3183 else
3184 f->ts.kind = gfc_default_integer_kind;
3185 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3186 }
3187
3188
3189 void
gfc_resolve_xor(gfc_expr * f,gfc_expr * i,gfc_expr * j)3190 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3191 {
3192 f->ts.type = i->ts.type;
3193 f->ts.kind = gfc_kind_max (i, j);
3194
3195 if (i->ts.kind != j->ts.kind)
3196 {
3197 if (i->ts.kind == gfc_kind_max (i, j))
3198 gfc_convert_type (j, &i->ts, 2);
3199 else
3200 gfc_convert_type (i, &j->ts, 2);
3201 }
3202
3203 f->value.function.name
3204 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
3205 }
3206
3207
3208 /* Intrinsic subroutine resolution. */
3209
3210 void
gfc_resolve_alarm_sub(gfc_code * c)3211 gfc_resolve_alarm_sub (gfc_code *c)
3212 {
3213 const char *name;
3214 gfc_expr *seconds, *handler;
3215 gfc_typespec ts;
3216 gfc_clear_ts (&ts);
3217
3218 seconds = c->ext.actual->expr;
3219 handler = c->ext.actual->next->expr;
3220 ts.type = BT_INTEGER;
3221 ts.kind = gfc_c_int_kind;
3222
3223 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3224 In all cases, the status argument is of default integer kind
3225 (enforced in check.c) so that the function suffix is fixed. */
3226 if (handler->ts.type == BT_INTEGER)
3227 {
3228 if (handler->ts.kind != gfc_c_int_kind)
3229 gfc_convert_type (handler, &ts, 2);
3230 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3231 gfc_default_integer_kind);
3232 }
3233 else
3234 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3235 gfc_default_integer_kind);
3236
3237 if (seconds->ts.kind != gfc_c_int_kind)
3238 gfc_convert_type (seconds, &ts, 2);
3239
3240 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3241 }
3242
3243 void
gfc_resolve_cpu_time(gfc_code * c)3244 gfc_resolve_cpu_time (gfc_code *c)
3245 {
3246 const char *name;
3247 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3248 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3249 }
3250
3251
3252 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3253
3254 static gfc_formal_arglist*
create_formal_for_intents(gfc_actual_arglist * actual,const sym_intent * ints)3255 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3256 {
3257 gfc_formal_arglist* head;
3258 gfc_formal_arglist* tail;
3259 int i;
3260
3261 if (!actual)
3262 return NULL;
3263
3264 head = tail = gfc_get_formal_arglist ();
3265 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3266 {
3267 gfc_symbol* sym;
3268
3269 sym = gfc_new_symbol ("dummyarg", NULL);
3270 sym->ts = actual->expr->ts;
3271
3272 sym->attr.intent = ints[i];
3273 tail->sym = sym;
3274
3275 if (actual->next)
3276 tail->next = gfc_get_formal_arglist ();
3277 }
3278
3279 return head;
3280 }
3281
3282
3283 void
gfc_resolve_atomic_def(gfc_code * c)3284 gfc_resolve_atomic_def (gfc_code *c)
3285 {
3286 const char *name = "atomic_define";
3287 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3288 }
3289
3290
3291 void
gfc_resolve_atomic_ref(gfc_code * c)3292 gfc_resolve_atomic_ref (gfc_code *c)
3293 {
3294 const char *name = "atomic_ref";
3295 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3296 }
3297
3298 void
gfc_resolve_event_query(gfc_code * c)3299 gfc_resolve_event_query (gfc_code *c)
3300 {
3301 const char *name = "event_query";
3302 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3303 }
3304
3305 void
gfc_resolve_mvbits(gfc_code * c)3306 gfc_resolve_mvbits (gfc_code *c)
3307 {
3308 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3309 INTENT_INOUT, INTENT_IN};
3310 const char *name;
3311
3312 /* TO and FROM are guaranteed to have the same kind parameter. */
3313 name = gfc_get_string (PREFIX ("mvbits_i%d"),
3314 c->ext.actual->expr->ts.kind);
3315 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3316 /* Mark as elemental subroutine as this does not happen automatically. */
3317 c->resolved_sym->attr.elemental = 1;
3318
3319 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3320 of creating temporaries. */
3321 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3322 }
3323
3324
3325 /* Set up the call to RANDOM_INIT. */
3326
3327 void
gfc_resolve_random_init(gfc_code * c)3328 gfc_resolve_random_init (gfc_code *c)
3329 {
3330 const char *name;
3331 name = gfc_get_string (PREFIX ("random_init"));
3332 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3333 }
3334
3335
3336 void
gfc_resolve_random_number(gfc_code * c)3337 gfc_resolve_random_number (gfc_code *c)
3338 {
3339 const char *name;
3340 int kind;
3341
3342 kind = c->ext.actual->expr->ts.kind;
3343 if (c->ext.actual->expr->rank == 0)
3344 name = gfc_get_string (PREFIX ("random_r%d"), kind);
3345 else
3346 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3347
3348 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3349 }
3350
3351
3352 void
gfc_resolve_random_seed(gfc_code * c)3353 gfc_resolve_random_seed (gfc_code *c)
3354 {
3355 const char *name;
3356
3357 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3358 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3359 }
3360
3361
3362 void
gfc_resolve_rename_sub(gfc_code * c)3363 gfc_resolve_rename_sub (gfc_code *c)
3364 {
3365 const char *name;
3366 int kind;
3367
3368 /* Find the type of status. If not present use default integer kind. */
3369 if (c->ext.actual->next->next->expr != NULL)
3370 kind = c->ext.actual->next->next->expr->ts.kind;
3371 else
3372 kind = gfc_default_integer_kind;
3373
3374 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3375 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3376 }
3377
3378
3379 void
gfc_resolve_link_sub(gfc_code * c)3380 gfc_resolve_link_sub (gfc_code *c)
3381 {
3382 const char *name;
3383 int kind;
3384
3385 if (c->ext.actual->next->next->expr != NULL)
3386 kind = c->ext.actual->next->next->expr->ts.kind;
3387 else
3388 kind = gfc_default_integer_kind;
3389
3390 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3391 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3392 }
3393
3394
3395 void
gfc_resolve_symlnk_sub(gfc_code * c)3396 gfc_resolve_symlnk_sub (gfc_code *c)
3397 {
3398 const char *name;
3399 int kind;
3400
3401 if (c->ext.actual->next->next->expr != NULL)
3402 kind = c->ext.actual->next->next->expr->ts.kind;
3403 else
3404 kind = gfc_default_integer_kind;
3405
3406 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3407 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3408 }
3409
3410
3411 /* G77 compatibility subroutines dtime() and etime(). */
3412
3413 void
gfc_resolve_dtime_sub(gfc_code * c)3414 gfc_resolve_dtime_sub (gfc_code *c)
3415 {
3416 const char *name;
3417 name = gfc_get_string (PREFIX ("dtime_sub"));
3418 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3419 }
3420
3421 void
gfc_resolve_etime_sub(gfc_code * c)3422 gfc_resolve_etime_sub (gfc_code *c)
3423 {
3424 const char *name;
3425 name = gfc_get_string (PREFIX ("etime_sub"));
3426 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3427 }
3428
3429
3430 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3431
3432 void
gfc_resolve_itime(gfc_code * c)3433 gfc_resolve_itime (gfc_code *c)
3434 {
3435 c->resolved_sym
3436 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3437 gfc_default_integer_kind));
3438 }
3439
3440 void
gfc_resolve_idate(gfc_code * c)3441 gfc_resolve_idate (gfc_code *c)
3442 {
3443 c->resolved_sym
3444 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3445 gfc_default_integer_kind));
3446 }
3447
3448 void
gfc_resolve_ltime(gfc_code * c)3449 gfc_resolve_ltime (gfc_code *c)
3450 {
3451 c->resolved_sym
3452 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3453 gfc_default_integer_kind));
3454 }
3455
3456 void
gfc_resolve_gmtime(gfc_code * c)3457 gfc_resolve_gmtime (gfc_code *c)
3458 {
3459 c->resolved_sym
3460 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3461 gfc_default_integer_kind));
3462 }
3463
3464
3465 /* G77 compatibility subroutine second(). */
3466
3467 void
gfc_resolve_second_sub(gfc_code * c)3468 gfc_resolve_second_sub (gfc_code *c)
3469 {
3470 const char *name;
3471 name = gfc_get_string (PREFIX ("second_sub"));
3472 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3473 }
3474
3475
3476 void
gfc_resolve_sleep_sub(gfc_code * c)3477 gfc_resolve_sleep_sub (gfc_code *c)
3478 {
3479 const char *name;
3480 int kind;
3481
3482 if (c->ext.actual->expr != NULL)
3483 kind = c->ext.actual->expr->ts.kind;
3484 else
3485 kind = gfc_default_integer_kind;
3486
3487 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3488 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3489 }
3490
3491
3492 /* G77 compatibility function srand(). */
3493
3494 void
gfc_resolve_srand(gfc_code * c)3495 gfc_resolve_srand (gfc_code *c)
3496 {
3497 const char *name;
3498 name = gfc_get_string (PREFIX ("srand"));
3499 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3500 }
3501
3502
3503 /* Resolve the getarg intrinsic subroutine. */
3504
3505 void
gfc_resolve_getarg(gfc_code * c)3506 gfc_resolve_getarg (gfc_code *c)
3507 {
3508 const char *name;
3509
3510 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3511 {
3512 gfc_typespec ts;
3513 gfc_clear_ts (&ts);
3514
3515 ts.type = BT_INTEGER;
3516 ts.kind = gfc_default_integer_kind;
3517
3518 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3519 }
3520
3521 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3522 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3523 }
3524
3525
3526 /* Resolve the getcwd intrinsic subroutine. */
3527
3528 void
gfc_resolve_getcwd_sub(gfc_code * c)3529 gfc_resolve_getcwd_sub (gfc_code *c)
3530 {
3531 const char *name;
3532 int kind;
3533
3534 if (c->ext.actual->next->expr != NULL)
3535 kind = c->ext.actual->next->expr->ts.kind;
3536 else
3537 kind = gfc_default_integer_kind;
3538
3539 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3540 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3541 }
3542
3543
3544 /* Resolve the get_command intrinsic subroutine. */
3545
3546 void
gfc_resolve_get_command(gfc_code * c)3547 gfc_resolve_get_command (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_i%d"), kind);
3553 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3554 }
3555
3556
3557 /* Resolve the get_command_argument intrinsic subroutine. */
3558
3559 void
gfc_resolve_get_command_argument(gfc_code * c)3560 gfc_resolve_get_command_argument (gfc_code *c)
3561 {
3562 const char *name;
3563 int kind;
3564 kind = gfc_default_integer_kind;
3565 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3566 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3567 }
3568
3569
3570 /* Resolve the get_environment_variable intrinsic subroutine. */
3571
3572 void
gfc_resolve_get_environment_variable(gfc_code * code)3573 gfc_resolve_get_environment_variable (gfc_code *code)
3574 {
3575 const char *name;
3576 int kind;
3577 kind = gfc_default_integer_kind;
3578 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3579 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3580 }
3581
3582
3583 void
gfc_resolve_signal_sub(gfc_code * c)3584 gfc_resolve_signal_sub (gfc_code *c)
3585 {
3586 const char *name;
3587 gfc_expr *number, *handler, *status;
3588 gfc_typespec ts;
3589 gfc_clear_ts (&ts);
3590
3591 number = c->ext.actual->expr;
3592 handler = c->ext.actual->next->expr;
3593 status = c->ext.actual->next->next->expr;
3594 ts.type = BT_INTEGER;
3595 ts.kind = gfc_c_int_kind;
3596
3597 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3598 if (handler->ts.type == BT_INTEGER)
3599 {
3600 if (handler->ts.kind != gfc_c_int_kind)
3601 gfc_convert_type (handler, &ts, 2);
3602 name = gfc_get_string (PREFIX ("signal_sub_int"));
3603 }
3604 else
3605 name = gfc_get_string (PREFIX ("signal_sub"));
3606
3607 if (number->ts.kind != gfc_c_int_kind)
3608 gfc_convert_type (number, &ts, 2);
3609 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3610 gfc_convert_type (status, &ts, 2);
3611
3612 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3613 }
3614
3615
3616 /* Resolve the SYSTEM intrinsic subroutine. */
3617
3618 void
gfc_resolve_system_sub(gfc_code * c)3619 gfc_resolve_system_sub (gfc_code *c)
3620 {
3621 const char *name;
3622 name = gfc_get_string (PREFIX ("system_sub"));
3623 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3624 }
3625
3626
3627 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3628
3629 void
gfc_resolve_system_clock(gfc_code * c)3630 gfc_resolve_system_clock (gfc_code *c)
3631 {
3632 const char *name;
3633 int kind;
3634 gfc_expr *count = c->ext.actual->expr;
3635 gfc_expr *count_max = c->ext.actual->next->next->expr;
3636
3637 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3638 and COUNT_MAX can hold 64-bit values, or are absent. */
3639 if ((!count || count->ts.kind >= 8)
3640 && (!count_max || count_max->ts.kind >= 8))
3641 kind = 8;
3642 else
3643 kind = gfc_default_integer_kind;
3644
3645 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3646 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3647 }
3648
3649
3650 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3651 void
gfc_resolve_execute_command_line(gfc_code * c)3652 gfc_resolve_execute_command_line (gfc_code *c)
3653 {
3654 const char *name;
3655 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3656 gfc_default_integer_kind);
3657 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3658 }
3659
3660
3661 /* Resolve the EXIT intrinsic subroutine. */
3662
3663 void
gfc_resolve_exit(gfc_code * c)3664 gfc_resolve_exit (gfc_code *c)
3665 {
3666 const char *name;
3667 gfc_typespec ts;
3668 gfc_expr *n;
3669 gfc_clear_ts (&ts);
3670
3671 /* The STATUS argument has to be of default kind. If it is not,
3672 we convert it. */
3673 ts.type = BT_INTEGER;
3674 ts.kind = gfc_default_integer_kind;
3675 n = c->ext.actual->expr;
3676 if (n != NULL && n->ts.kind != ts.kind)
3677 gfc_convert_type (n, &ts, 2);
3678
3679 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3680 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3681 }
3682
3683
3684 /* Resolve the FLUSH intrinsic subroutine. */
3685
3686 void
gfc_resolve_flush(gfc_code * c)3687 gfc_resolve_flush (gfc_code *c)
3688 {
3689 const char *name;
3690 gfc_typespec ts;
3691 gfc_expr *n;
3692 gfc_clear_ts (&ts);
3693
3694 ts.type = BT_INTEGER;
3695 ts.kind = gfc_default_integer_kind;
3696 n = c->ext.actual->expr;
3697 if (n != NULL && n->ts.kind != ts.kind)
3698 gfc_convert_type (n, &ts, 2);
3699
3700 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3701 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3702 }
3703
3704
3705 void
gfc_resolve_ctime_sub(gfc_code * c)3706 gfc_resolve_ctime_sub (gfc_code *c)
3707 {
3708 gfc_typespec ts;
3709 gfc_clear_ts (&ts);
3710
3711 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3712 if (c->ext.actual->expr->ts.kind != 8)
3713 {
3714 ts.type = BT_INTEGER;
3715 ts.kind = 8;
3716 ts.u.derived = NULL;
3717 ts.u.cl = NULL;
3718 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3719 }
3720
3721 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3722 }
3723
3724
3725 void
gfc_resolve_fdate_sub(gfc_code * c)3726 gfc_resolve_fdate_sub (gfc_code *c)
3727 {
3728 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3729 }
3730
3731
3732 void
gfc_resolve_gerror(gfc_code * c)3733 gfc_resolve_gerror (gfc_code *c)
3734 {
3735 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3736 }
3737
3738
3739 void
gfc_resolve_getlog(gfc_code * c)3740 gfc_resolve_getlog (gfc_code *c)
3741 {
3742 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3743 }
3744
3745
3746 void
gfc_resolve_hostnm_sub(gfc_code * c)3747 gfc_resolve_hostnm_sub (gfc_code *c)
3748 {
3749 const char *name;
3750 int kind;
3751
3752 if (c->ext.actual->next->expr != NULL)
3753 kind = c->ext.actual->next->expr->ts.kind;
3754 else
3755 kind = gfc_default_integer_kind;
3756
3757 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3758 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3759 }
3760
3761
3762 void
gfc_resolve_perror(gfc_code * c)3763 gfc_resolve_perror (gfc_code *c)
3764 {
3765 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3766 }
3767
3768 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3769
3770 void
gfc_resolve_stat_sub(gfc_code * c)3771 gfc_resolve_stat_sub (gfc_code *c)
3772 {
3773 const char *name;
3774 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3775 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3776 }
3777
3778
3779 void
gfc_resolve_lstat_sub(gfc_code * c)3780 gfc_resolve_lstat_sub (gfc_code *c)
3781 {
3782 const char *name;
3783 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3784 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3785 }
3786
3787
3788 void
gfc_resolve_fstat_sub(gfc_code * c)3789 gfc_resolve_fstat_sub (gfc_code *c)
3790 {
3791 const char *name;
3792 gfc_expr *u;
3793 gfc_typespec *ts;
3794
3795 u = c->ext.actual->expr;
3796 ts = &c->ext.actual->next->expr->ts;
3797 if (u->ts.kind != ts->kind)
3798 gfc_convert_type (u, ts, 2);
3799 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3800 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3801 }
3802
3803
3804 void
gfc_resolve_fgetc_sub(gfc_code * c)3805 gfc_resolve_fgetc_sub (gfc_code *c)
3806 {
3807 const char *name;
3808 gfc_typespec ts;
3809 gfc_expr *u, *st;
3810 gfc_clear_ts (&ts);
3811
3812 u = c->ext.actual->expr;
3813 st = c->ext.actual->next->next->expr;
3814
3815 if (u->ts.kind != gfc_c_int_kind)
3816 {
3817 ts.type = BT_INTEGER;
3818 ts.kind = gfc_c_int_kind;
3819 ts.u.derived = NULL;
3820 ts.u.cl = NULL;
3821 gfc_convert_type (u, &ts, 2);
3822 }
3823
3824 if (st != NULL)
3825 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3826 else
3827 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3828
3829 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3830 }
3831
3832
3833 void
gfc_resolve_fget_sub(gfc_code * c)3834 gfc_resolve_fget_sub (gfc_code *c)
3835 {
3836 const char *name;
3837 gfc_expr *st;
3838
3839 st = c->ext.actual->next->expr;
3840 if (st != NULL)
3841 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3842 else
3843 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3844
3845 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3846 }
3847
3848
3849 void
gfc_resolve_fputc_sub(gfc_code * c)3850 gfc_resolve_fputc_sub (gfc_code *c)
3851 {
3852 const char *name;
3853 gfc_typespec ts;
3854 gfc_expr *u, *st;
3855 gfc_clear_ts (&ts);
3856
3857 u = c->ext.actual->expr;
3858 st = c->ext.actual->next->next->expr;
3859
3860 if (u->ts.kind != gfc_c_int_kind)
3861 {
3862 ts.type = BT_INTEGER;
3863 ts.kind = gfc_c_int_kind;
3864 ts.u.derived = NULL;
3865 ts.u.cl = NULL;
3866 gfc_convert_type (u, &ts, 2);
3867 }
3868
3869 if (st != NULL)
3870 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3871 else
3872 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3873
3874 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3875 }
3876
3877
3878 void
gfc_resolve_fput_sub(gfc_code * c)3879 gfc_resolve_fput_sub (gfc_code *c)
3880 {
3881 const char *name;
3882 gfc_expr *st;
3883
3884 st = c->ext.actual->next->expr;
3885 if (st != NULL)
3886 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3887 else
3888 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3889
3890 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3891 }
3892
3893
3894 void
gfc_resolve_fseek_sub(gfc_code * c)3895 gfc_resolve_fseek_sub (gfc_code *c)
3896 {
3897 gfc_expr *unit;
3898 gfc_expr *offset;
3899 gfc_expr *whence;
3900 gfc_typespec ts;
3901 gfc_clear_ts (&ts);
3902
3903 unit = c->ext.actual->expr;
3904 offset = c->ext.actual->next->expr;
3905 whence = c->ext.actual->next->next->expr;
3906
3907 if (unit->ts.kind != gfc_c_int_kind)
3908 {
3909 ts.type = BT_INTEGER;
3910 ts.kind = gfc_c_int_kind;
3911 ts.u.derived = NULL;
3912 ts.u.cl = NULL;
3913 gfc_convert_type (unit, &ts, 2);
3914 }
3915
3916 if (offset->ts.kind != gfc_intio_kind)
3917 {
3918 ts.type = BT_INTEGER;
3919 ts.kind = gfc_intio_kind;
3920 ts.u.derived = NULL;
3921 ts.u.cl = NULL;
3922 gfc_convert_type (offset, &ts, 2);
3923 }
3924
3925 if (whence->ts.kind != gfc_c_int_kind)
3926 {
3927 ts.type = BT_INTEGER;
3928 ts.kind = gfc_c_int_kind;
3929 ts.u.derived = NULL;
3930 ts.u.cl = NULL;
3931 gfc_convert_type (whence, &ts, 2);
3932 }
3933
3934 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3935 }
3936
3937 void
gfc_resolve_ftell_sub(gfc_code * c)3938 gfc_resolve_ftell_sub (gfc_code *c)
3939 {
3940 const char *name;
3941 gfc_expr *unit;
3942 gfc_expr *offset;
3943 gfc_typespec ts;
3944 gfc_clear_ts (&ts);
3945
3946 unit = c->ext.actual->expr;
3947 offset = c->ext.actual->next->expr;
3948
3949 if (unit->ts.kind != gfc_c_int_kind)
3950 {
3951 ts.type = BT_INTEGER;
3952 ts.kind = gfc_c_int_kind;
3953 ts.u.derived = NULL;
3954 ts.u.cl = NULL;
3955 gfc_convert_type (unit, &ts, 2);
3956 }
3957
3958 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3959 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3960 }
3961
3962
3963 void
gfc_resolve_ttynam_sub(gfc_code * c)3964 gfc_resolve_ttynam_sub (gfc_code *c)
3965 {
3966 gfc_typespec ts;
3967 gfc_clear_ts (&ts);
3968
3969 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3970 {
3971 ts.type = BT_INTEGER;
3972 ts.kind = gfc_c_int_kind;
3973 ts.u.derived = NULL;
3974 ts.u.cl = NULL;
3975 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3976 }
3977
3978 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3979 }
3980
3981
3982 /* Resolve the UMASK intrinsic subroutine. */
3983
3984 void
gfc_resolve_umask_sub(gfc_code * c)3985 gfc_resolve_umask_sub (gfc_code *c)
3986 {
3987 const char *name;
3988 int kind;
3989
3990 if (c->ext.actual->next->expr != NULL)
3991 kind = c->ext.actual->next->expr->ts.kind;
3992 else
3993 kind = gfc_default_integer_kind;
3994
3995 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3996 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3997 }
3998
3999 /* Resolve the UNLINK intrinsic subroutine. */
4000
4001 void
gfc_resolve_unlink_sub(gfc_code * c)4002 gfc_resolve_unlink_sub (gfc_code *c)
4003 {
4004 const char *name;
4005 int kind;
4006
4007 if (c->ext.actual->next->expr != NULL)
4008 kind = c->ext.actual->next->expr->ts.kind;
4009 else
4010 kind = gfc_default_integer_kind;
4011
4012 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4013 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4014 }
4015