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