runtime: complete defer handling in CgocallBackDone
[official-gcc.git] / gcc / fortran / iresolve.c
blobb784ac339e9642207b5d281e9c97d3c8437815d0
1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Katherine Holcomb
5 This file is part of GCC.
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.
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.
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/>. */
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. */
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"
39 /* Given printf-like arguments, return a stable version of the result string.
41 We already have a working, optimized string hashing table in the form of
42 the identifier table. Reusing this table is likely not to be wasted,
43 since if the function name makes it to the gimple output of the frontend,
44 we'll have to create the identifier anyway. */
46 const char *
47 gfc_get_string (const char *format, ...)
49 char temp_name[128];
50 const char *str;
51 va_list ap;
52 tree ident;
54 /* Handle common case without vsnprintf and temporary buffer. */
55 if (format[0] == '%' && format[1] == 's' && format[2] == '\0')
57 va_start (ap, format);
58 str = va_arg (ap, const char *);
59 va_end (ap);
61 else
63 va_start (ap, format);
64 vsnprintf (temp_name, sizeof (temp_name), format, ap);
65 va_end (ap);
66 temp_name[sizeof (temp_name) - 1] = 0;
67 str = temp_name;
70 ident = get_identifier (str);
71 return IDENTIFIER_POINTER (ident);
74 /* MERGE and SPREAD need to have source charlen's present for passing
75 to the result expression. */
76 static void
77 check_charlen_present (gfc_expr *source)
79 if (source->ts.u.cl == NULL)
80 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
82 if (source->expr_type == EXPR_CONSTANT)
84 source->ts.u.cl->length
85 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
86 source->value.character.length);
87 source->rank = 0;
89 else if (source->expr_type == EXPR_ARRAY)
91 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
92 source->ts.u.cl->length
93 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
94 c->expr->value.character.length);
98 /* Helper function for resolving the "mask" argument. */
100 static void
101 resolve_mask_arg (gfc_expr *mask)
104 gfc_typespec ts;
105 gfc_clear_ts (&ts);
107 if (mask->rank == 0)
109 /* For the scalar case, coerce the mask to kind=4 unconditionally
110 (because this is the only kind we have a library function
111 for). */
113 if (mask->ts.kind != 4)
115 ts.type = BT_LOGICAL;
116 ts.kind = 4;
117 gfc_convert_type (mask, &ts, 2);
120 else
122 /* In the library, we access the mask with a GFC_LOGICAL_1
123 argument. No need to waste memory if we are about to create
124 a temporary array. */
125 if (mask->expr_type == EXPR_OP && mask->ts.kind != 1)
127 ts.type = BT_LOGICAL;
128 ts.kind = 1;
129 gfc_convert_type_warn (mask, &ts, 2, 0);
135 static void
136 resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
137 const char *name, bool coarray)
139 f->ts.type = BT_INTEGER;
140 if (kind)
141 f->ts.kind = mpz_get_si (kind->value.integer);
142 else
143 f->ts.kind = gfc_default_integer_kind;
145 if (dim == NULL)
147 f->rank = 1;
148 if (array->rank != -1)
150 f->shape = gfc_get_shape (1);
151 mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
152 : array->rank);
156 f->value.function.name = gfc_get_string ("%s", name);
160 static void
161 resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array,
162 gfc_expr *dim, gfc_expr *mask)
164 const char *prefix;
166 f->ts = array->ts;
168 if (mask)
170 if (mask->rank == 0)
171 prefix = "s";
172 else
173 prefix = "m";
175 resolve_mask_arg (mask);
177 else
178 prefix = "";
180 if (dim != NULL)
182 f->rank = array->rank - 1;
183 f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
184 gfc_resolve_dim_arg (dim);
187 f->value.function.name
188 = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name,
189 gfc_type_letter (array->ts.type), array->ts.kind);
193 /********************** Resolution functions **********************/
196 void
197 gfc_resolve_abs (gfc_expr *f, gfc_expr *a)
199 f->ts = a->ts;
200 if (f->ts.type == BT_COMPLEX)
201 f->ts.type = BT_REAL;
203 f->value.function.name
204 = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
208 void
209 gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
210 gfc_expr *mode ATTRIBUTE_UNUSED)
212 f->ts.type = BT_INTEGER;
213 f->ts.kind = gfc_c_int_kind;
214 f->value.function.name = PREFIX ("access_func");
218 void
219 gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string)
221 f->ts.type = BT_CHARACTER;
222 f->ts.kind = string->ts.kind;
223 if (string->ts.u.cl)
224 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
226 f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind);
230 void
231 gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string)
233 f->ts.type = BT_CHARACTER;
234 f->ts.kind = string->ts.kind;
235 if (string->ts.u.cl)
236 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl);
238 f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind);
242 static void
243 gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
244 bool is_achar)
246 f->ts.type = BT_CHARACTER;
247 f->ts.kind = (kind == NULL)
248 ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
249 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
250 f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
252 f->value.function.name
253 = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
254 gfc_type_letter (x->ts.type), x->ts.kind);
258 void
259 gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
261 gfc_resolve_char_achar (f, x, kind, true);
265 void
266 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
268 f->ts = x->ts;
269 f->value.function.name
270 = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
274 void
275 gfc_resolve_acosh (gfc_expr *f, gfc_expr *x)
277 f->ts = x->ts;
278 f->value.function.name
279 = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type),
280 x->ts.kind);
284 void
285 gfc_resolve_aimag (gfc_expr *f, gfc_expr *x)
287 f->ts.type = BT_REAL;
288 f->ts.kind = x->ts.kind;
289 f->value.function.name
290 = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type),
291 x->ts.kind);
295 void
296 gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j)
298 f->ts.type = i->ts.type;
299 f->ts.kind = gfc_kind_max (i, j);
301 if (i->ts.kind != j->ts.kind)
303 if (i->ts.kind == gfc_kind_max (i, j))
304 gfc_convert_type (j, &i->ts, 2);
305 else
306 gfc_convert_type (i, &j->ts, 2);
309 f->value.function.name
310 = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
314 void
315 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
317 gfc_typespec ts;
318 gfc_clear_ts (&ts);
320 f->ts.type = a->ts.type;
321 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
323 if (a->ts.kind != f->ts.kind)
325 ts.type = f->ts.type;
326 ts.kind = f->ts.kind;
327 gfc_convert_type (a, &ts, 2);
329 /* The resolved name is only used for specific intrinsics where
330 the return kind is the same as the arg kind. */
331 f->value.function.name
332 = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
336 void
337 gfc_resolve_dint (gfc_expr *f, gfc_expr *a)
339 gfc_resolve_aint (f, a, NULL);
343 void
344 gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
346 f->ts = mask->ts;
348 if (dim != NULL)
350 gfc_resolve_dim_arg (dim);
351 f->rank = mask->rank - 1;
352 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
355 f->value.function.name
356 = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type),
357 mask->ts.kind);
361 void
362 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
364 gfc_typespec ts;
365 gfc_clear_ts (&ts);
367 f->ts.type = a->ts.type;
368 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
370 if (a->ts.kind != f->ts.kind)
372 ts.type = f->ts.type;
373 ts.kind = f->ts.kind;
374 gfc_convert_type (a, &ts, 2);
377 /* The resolved name is only used for specific intrinsics where
378 the return kind is the same as the arg kind. */
379 f->value.function.name
380 = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type),
381 a->ts.kind);
385 void
386 gfc_resolve_dnint (gfc_expr *f, gfc_expr *a)
388 gfc_resolve_anint (f, a, NULL);
392 void
393 gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
395 f->ts = mask->ts;
397 if (dim != NULL)
399 gfc_resolve_dim_arg (dim);
400 f->rank = mask->rank - 1;
401 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
404 f->value.function.name
405 = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type),
406 mask->ts.kind);
410 void
411 gfc_resolve_asin (gfc_expr *f, gfc_expr *x)
413 f->ts = x->ts;
414 f->value.function.name
415 = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
418 void
419 gfc_resolve_asinh (gfc_expr *f, gfc_expr *x)
421 f->ts = x->ts;
422 f->value.function.name
423 = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type),
424 x->ts.kind);
427 void
428 gfc_resolve_atan (gfc_expr *f, gfc_expr *x)
430 f->ts = x->ts;
431 f->value.function.name
432 = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
435 void
436 gfc_resolve_atanh (gfc_expr *f, gfc_expr *x)
438 f->ts = x->ts;
439 f->value.function.name
440 = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type),
441 x->ts.kind);
444 void
445 gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
447 f->ts = x->ts;
448 f->value.function.name
449 = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type),
450 x->ts.kind);
454 /* Resolve the BESYN and BESJN intrinsics. */
456 void
457 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
459 gfc_typespec ts;
460 gfc_clear_ts (&ts);
462 f->ts = x->ts;
463 if (n->ts.kind != gfc_c_int_kind)
465 ts.type = BT_INTEGER;
466 ts.kind = gfc_c_int_kind;
467 gfc_convert_type (n, &ts, 2);
469 f->value.function.name = gfc_get_string ("<intrinsic>");
473 void
474 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
476 gfc_typespec ts;
477 gfc_clear_ts (&ts);
479 f->ts = x->ts;
480 f->rank = 1;
481 if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
483 f->shape = gfc_get_shape (1);
484 mpz_init (f->shape[0]);
485 mpz_sub (f->shape[0], n2->value.integer, n1->value.integer);
486 mpz_add_ui (f->shape[0], f->shape[0], 1);
489 if (n1->ts.kind != gfc_c_int_kind)
491 ts.type = BT_INTEGER;
492 ts.kind = gfc_c_int_kind;
493 gfc_convert_type (n1, &ts, 2);
496 if (n2->ts.kind != gfc_c_int_kind)
498 ts.type = BT_INTEGER;
499 ts.kind = gfc_c_int_kind;
500 gfc_convert_type (n2, &ts, 2);
503 if (f->value.function.isym->id == GFC_ISYM_JN2)
504 f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"),
505 f->ts.kind);
506 else
507 f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"),
508 f->ts.kind);
512 void
513 gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
515 f->ts.type = BT_LOGICAL;
516 f->ts.kind = gfc_default_logical_kind;
517 f->value.function.name
518 = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind);
522 void
523 gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
525 f->ts = f->value.function.isym->ts;
529 void
530 gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
532 f->ts = f->value.function.isym->ts;
536 void
537 gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
539 f->ts.type = BT_INTEGER;
540 f->ts.kind = (kind == NULL)
541 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
542 f->value.function.name
543 = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind,
544 gfc_type_letter (a->ts.type), a->ts.kind);
548 void
549 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
551 gfc_resolve_char_achar (f, a, kind, false);
555 void
556 gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED)
558 f->ts.type = BT_INTEGER;
559 f->ts.kind = gfc_default_integer_kind;
560 f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind);
564 void
565 gfc_resolve_chdir_sub (gfc_code *c)
567 const char *name;
568 int kind;
570 if (c->ext.actual->next->expr != NULL)
571 kind = c->ext.actual->next->expr->ts.kind;
572 else
573 kind = gfc_default_integer_kind;
575 name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
576 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
580 void
581 gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
582 gfc_expr *mode ATTRIBUTE_UNUSED)
584 f->ts.type = BT_INTEGER;
585 f->ts.kind = gfc_c_int_kind;
586 f->value.function.name = PREFIX ("chmod_func");
590 void
591 gfc_resolve_chmod_sub (gfc_code *c)
593 const char *name;
594 int kind;
596 if (c->ext.actual->next->next->expr != NULL)
597 kind = c->ext.actual->next->next->expr->ts.kind;
598 else
599 kind = gfc_default_integer_kind;
601 name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
602 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
606 void
607 gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
609 f->ts.type = BT_COMPLEX;
610 f->ts.kind = (kind == NULL)
611 ? gfc_default_real_kind : mpz_get_si (kind->value.integer);
613 if (y == NULL)
614 f->value.function.name
615 = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind,
616 gfc_type_letter (x->ts.type), x->ts.kind);
617 else
618 f->value.function.name
619 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
620 gfc_type_letter (x->ts.type), x->ts.kind,
621 gfc_type_letter (y->ts.type), y->ts.kind);
625 void
626 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
628 gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
629 gfc_default_double_kind));
633 void
634 gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y)
636 int kind;
638 if (x->ts.type == BT_INTEGER)
640 if (y->ts.type == BT_INTEGER)
641 kind = gfc_default_real_kind;
642 else
643 kind = y->ts.kind;
645 else
647 if (y->ts.type == BT_REAL)
648 kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
649 else
650 kind = x->ts.kind;
653 f->ts.type = BT_COMPLEX;
654 f->ts.kind = kind;
655 f->value.function.name
656 = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
657 gfc_type_letter (x->ts.type), x->ts.kind,
658 gfc_type_letter (y->ts.type), y->ts.kind);
662 void
663 gfc_resolve_conjg (gfc_expr *f, gfc_expr *x)
665 f->ts = x->ts;
666 f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind);
670 void
671 gfc_resolve_cos (gfc_expr *f, gfc_expr *x)
673 f->ts = x->ts;
674 f->value.function.name
675 = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
679 void
680 gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
682 f->ts = x->ts;
683 f->value.function.name
684 = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
688 /* Our replacement of elements of a trig call with an EXPR_OP (e.g.
689 multiplying the result or operands by a factor to convert to/from degrees)
690 will cause the resolve_* function to be invoked again when resolving the
691 freshly created EXPR_OP. See gfc_resolve_trigd, gfc_resolve_atrigd,
692 gfc_resolve_cotan. We must observe this and avoid recursively creating
693 layers of nested EXPR_OP expressions. */
695 static bool
696 is_trig_resolved (gfc_expr *f)
698 /* We know we've already resolved the function if we see the lib call
699 starting with '__'. */
700 return (f->value.function.name != NULL
701 && strncmp ("__", f->value.function.name, 2) == 0);
704 /* Return a shallow copy of the function expression f. The original expression
705 has its pointers cleared so that it may be freed without affecting the
706 shallow copy. This is similar to gfc_copy_expr, but doesn't perform a deep
707 copy of the argument list, allowing it to be reused somewhere else,
708 setting the expression up nicely for gfc_replace_expr. */
710 static gfc_expr *
711 copy_replace_function_shallow (gfc_expr *f)
713 gfc_expr *fcopy;
714 gfc_actual_arglist *args;
716 /* The only thing deep-copied in gfc_copy_expr is args. */
717 args = f->value.function.actual;
718 f->value.function.actual = NULL;
719 fcopy = gfc_copy_expr (f);
720 fcopy->value.function.actual = args;
722 /* Clear the old function so the shallow copy is not affected if the old
723 expression is freed. */
724 f->value.function.name = NULL;
725 f->value.function.isym = NULL;
726 f->value.function.actual = NULL;
727 f->value.function.esym = NULL;
728 f->shape = NULL;
729 f->ref = NULL;
731 return fcopy;
735 /* Resolve cotan = cos / sin. */
737 void
738 gfc_resolve_cotan (gfc_expr *f, gfc_expr *x)
740 gfc_expr *result, *fcopy, *sin;
741 gfc_actual_arglist *sin_args;
743 if (is_trig_resolved (f))
744 return;
746 /* Compute cotan (x) = cos (x) / sin (x). */
747 f->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_COS);
748 gfc_resolve_cos (f, x);
750 sin_args = gfc_get_actual_arglist ();
751 sin_args->expr = gfc_copy_expr (x);
753 sin = gfc_get_expr ();
754 sin->ts = f->ts;
755 sin->where = f->where;
756 sin->expr_type = EXPR_FUNCTION;
757 sin->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SIN);
758 sin->value.function.actual = sin_args;
759 gfc_resolve_sin (sin, sin_args->expr);
761 /* Replace f with cos/sin - we do this in place in f for the caller. */
762 fcopy = copy_replace_function_shallow (f);
763 result = gfc_divide (fcopy, sin);
764 gfc_replace_expr (f, result);
768 void
769 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
771 f->ts.type = BT_INTEGER;
772 if (kind)
773 f->ts.kind = mpz_get_si (kind->value.integer);
774 else
775 f->ts.kind = gfc_default_integer_kind;
777 if (dim != NULL)
779 f->rank = mask->rank - 1;
780 gfc_resolve_dim_arg (dim);
781 f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
784 resolve_mask_arg (mask);
786 f->value.function.name
787 = gfc_get_string (PREFIX ("count_%d_%c"), f->ts.kind,
788 gfc_type_letter (mask->ts.type));
792 void
793 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
794 gfc_expr *dim)
796 int n, m;
798 if (array->ts.type == BT_CHARACTER && array->ref)
799 gfc_resolve_substring_charlen (array);
801 f->ts = array->ts;
802 f->rank = array->rank;
803 f->shape = gfc_copy_shape (array->shape, array->rank);
805 if (shift->rank > 0)
806 n = 1;
807 else
808 n = 0;
810 /* If dim kind is greater than default integer we need to use the larger. */
811 m = gfc_default_integer_kind;
812 if (dim != NULL)
813 m = m < dim->ts.kind ? dim->ts.kind : m;
815 /* Convert shift to at least m, so we don't need
816 kind=1 and kind=2 versions of the library functions. */
817 if (shift->ts.kind < m)
819 gfc_typespec ts;
820 gfc_clear_ts (&ts);
821 ts.type = BT_INTEGER;
822 ts.kind = m;
823 gfc_convert_type_warn (shift, &ts, 2, 0);
826 if (dim != NULL)
828 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
829 && dim->symtree->n.sym->attr.optional)
831 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
832 dim->representation.length = shift->ts.kind;
834 else
836 gfc_resolve_dim_arg (dim);
837 /* Convert dim to shift's kind to reduce variations. */
838 if (dim->ts.kind != shift->ts.kind)
839 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
843 if (array->ts.type == BT_CHARACTER)
845 if (array->ts.kind == gfc_default_character_kind)
846 f->value.function.name
847 = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind);
848 else
849 f->value.function.name
850 = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind,
851 array->ts.kind);
853 else
854 f->value.function.name
855 = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind);
859 void
860 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
862 gfc_typespec ts;
863 gfc_clear_ts (&ts);
865 f->ts.type = BT_CHARACTER;
866 f->ts.kind = gfc_default_character_kind;
868 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
869 if (time->ts.kind != 8)
871 ts.type = BT_INTEGER;
872 ts.kind = 8;
873 ts.u.derived = NULL;
874 ts.u.cl = NULL;
875 gfc_convert_type (time, &ts, 2);
878 f->value.function.name = gfc_get_string (PREFIX ("ctime"));
882 void
883 gfc_resolve_dble (gfc_expr *f, gfc_expr *a)
885 f->ts.type = BT_REAL;
886 f->ts.kind = gfc_default_double_kind;
887 f->value.function.name
888 = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
892 void
893 gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p)
895 f->ts.type = a->ts.type;
896 if (p != NULL)
897 f->ts.kind = gfc_kind_max (a,p);
898 else
899 f->ts.kind = a->ts.kind;
901 if (p != NULL && a->ts.kind != p->ts.kind)
903 if (a->ts.kind == gfc_kind_max (a,p))
904 gfc_convert_type (p, &a->ts, 2);
905 else
906 gfc_convert_type (a, &p->ts, 2);
909 f->value.function.name
910 = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
914 void
915 gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b)
917 gfc_expr temp;
919 temp.expr_type = EXPR_OP;
920 gfc_clear_ts (&temp.ts);
921 temp.value.op.op = INTRINSIC_NONE;
922 temp.value.op.op1 = a;
923 temp.value.op.op2 = b;
924 gfc_type_convert_binary (&temp, 1);
925 f->ts = temp.ts;
926 f->value.function.name
927 = gfc_get_string (PREFIX ("dot_product_%c%d"),
928 gfc_type_letter (f->ts.type), f->ts.kind);
932 void
933 gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
934 gfc_expr *b ATTRIBUTE_UNUSED)
936 f->ts.kind = gfc_default_double_kind;
937 f->ts.type = BT_REAL;
938 f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind);
942 void
943 gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
944 gfc_expr *shift ATTRIBUTE_UNUSED)
946 f->ts = i->ts;
947 if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
948 f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
949 else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
950 f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
951 else
952 gcc_unreachable ();
956 void
957 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
958 gfc_expr *boundary, gfc_expr *dim)
960 int n, m;
962 if (array->ts.type == BT_CHARACTER && array->ref)
963 gfc_resolve_substring_charlen (array);
965 f->ts = array->ts;
966 f->rank = array->rank;
967 f->shape = gfc_copy_shape (array->shape, array->rank);
969 n = 0;
970 if (shift->rank > 0)
971 n = n | 1;
972 if (boundary && boundary->rank > 0)
973 n = n | 2;
975 /* If dim kind is greater than default integer we need to use the larger. */
976 m = gfc_default_integer_kind;
977 if (dim != NULL)
978 m = m < dim->ts.kind ? dim->ts.kind : m;
980 /* Convert shift to at least m, so we don't need
981 kind=1 and kind=2 versions of the library functions. */
982 if (shift->ts.kind < m)
984 gfc_typespec ts;
985 gfc_clear_ts (&ts);
986 ts.type = BT_INTEGER;
987 ts.kind = m;
988 gfc_convert_type_warn (shift, &ts, 2, 0);
991 if (dim != NULL)
993 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
994 && dim->symtree->n.sym->attr.optional)
996 /* Mark this for later setting the type in gfc_conv_missing_dummy. */
997 dim->representation.length = shift->ts.kind;
999 else
1001 gfc_resolve_dim_arg (dim);
1002 /* Convert dim to shift's kind to reduce variations. */
1003 if (dim->ts.kind != shift->ts.kind)
1004 gfc_convert_type_warn (dim, &shift->ts, 2, 0);
1008 if (array->ts.type == BT_CHARACTER)
1010 if (array->ts.kind == gfc_default_character_kind)
1011 f->value.function.name
1012 = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind);
1013 else
1014 f->value.function.name
1015 = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind,
1016 array->ts.kind);
1018 else
1019 f->value.function.name
1020 = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind);
1024 void
1025 gfc_resolve_exp (gfc_expr *f, gfc_expr *x)
1027 f->ts = x->ts;
1028 f->value.function.name
1029 = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
1033 void
1034 gfc_resolve_exponent (gfc_expr *f, gfc_expr *x)
1036 f->ts.type = BT_INTEGER;
1037 f->ts.kind = gfc_default_integer_kind;
1038 f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind);
1042 /* Resolve the EXTENDS_TYPE_OF intrinsic function. */
1044 void
1045 gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
1047 gfc_symbol *vtab;
1048 gfc_symtree *st;
1050 /* Prevent double resolution. */
1051 if (f->ts.type == BT_LOGICAL)
1052 return;
1054 /* Replace the first argument with the corresponding vtab. */
1055 if (a->ts.type == BT_CLASS)
1056 gfc_add_vptr_component (a);
1057 else if (a->ts.type == BT_DERIVED)
1059 locus where;
1061 vtab = gfc_find_derived_vtab (a->ts.u.derived);
1062 /* Clear the old expr. */
1063 gfc_free_ref_list (a->ref);
1064 where = a->where;
1065 memset (a, '\0', sizeof (gfc_expr));
1066 /* Construct a new one. */
1067 a->expr_type = EXPR_VARIABLE;
1068 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1069 a->symtree = st;
1070 a->ts = vtab->ts;
1071 a->where = where;
1074 /* Replace the second argument with the corresponding vtab. */
1075 if (mo->ts.type == BT_CLASS)
1076 gfc_add_vptr_component (mo);
1077 else if (mo->ts.type == BT_DERIVED)
1079 locus where;
1081 vtab = gfc_find_derived_vtab (mo->ts.u.derived);
1082 /* Clear the old expr. */
1083 where = mo->where;
1084 gfc_free_ref_list (mo->ref);
1085 memset (mo, '\0', sizeof (gfc_expr));
1086 /* Construct a new one. */
1087 mo->expr_type = EXPR_VARIABLE;
1088 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
1089 mo->symtree = st;
1090 mo->ts = vtab->ts;
1091 mo->where = where;
1094 f->ts.type = BT_LOGICAL;
1095 f->ts.kind = 4;
1097 f->value.function.isym->formal->ts = a->ts;
1098 f->value.function.isym->formal->next->ts = mo->ts;
1100 /* Call library function. */
1101 f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
1105 void
1106 gfc_resolve_fdate (gfc_expr *f)
1108 f->ts.type = BT_CHARACTER;
1109 f->ts.kind = gfc_default_character_kind;
1110 f->value.function.name = gfc_get_string (PREFIX ("fdate"));
1114 void
1115 gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1117 f->ts.type = BT_INTEGER;
1118 f->ts.kind = (kind == NULL)
1119 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1120 f->value.function.name
1121 = gfc_get_string ("__floor%d_%c%d", f->ts.kind,
1122 gfc_type_letter (a->ts.type), a->ts.kind);
1126 void
1127 gfc_resolve_fnum (gfc_expr *f, gfc_expr *n)
1129 f->ts.type = BT_INTEGER;
1130 f->ts.kind = gfc_default_integer_kind;
1131 if (n->ts.kind != f->ts.kind)
1132 gfc_convert_type (n, &f->ts, 2);
1133 f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind);
1137 void
1138 gfc_resolve_fraction (gfc_expr *f, gfc_expr *x)
1140 f->ts = x->ts;
1141 f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind);
1145 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
1147 void
1148 gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
1150 f->ts = x->ts;
1151 f->value.function.name = gfc_get_string ("<intrinsic>");
1155 void
1156 gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
1158 f->ts = x->ts;
1159 f->value.function.name
1160 = gfc_get_string ("__tgamma_%d", x->ts.kind);
1164 void
1165 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1167 f->ts.type = BT_INTEGER;
1168 f->ts.kind = 4;
1169 f->value.function.name = gfc_get_string (PREFIX ("getcwd"));
1173 void
1174 gfc_resolve_getgid (gfc_expr *f)
1176 f->ts.type = BT_INTEGER;
1177 f->ts.kind = 4;
1178 f->value.function.name = gfc_get_string (PREFIX ("getgid"));
1182 void
1183 gfc_resolve_getpid (gfc_expr *f)
1185 f->ts.type = BT_INTEGER;
1186 f->ts.kind = 4;
1187 f->value.function.name = gfc_get_string (PREFIX ("getpid"));
1191 void
1192 gfc_resolve_getuid (gfc_expr *f)
1194 f->ts.type = BT_INTEGER;
1195 f->ts.kind = 4;
1196 f->value.function.name = gfc_get_string (PREFIX ("getuid"));
1200 void
1201 gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
1203 f->ts.type = BT_INTEGER;
1204 f->ts.kind = 4;
1205 f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
1209 void
1210 gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
1212 f->ts = x->ts;
1213 f->value.function.name = gfc_get_string ("__hypot_r%d", x->ts.kind);
1217 void
1218 gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1220 resolve_transformational ("iall", f, array, dim, mask);
1224 void
1225 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1227 /* If the kind of i and j are different, then g77 cross-promoted the
1228 kinds to the largest value. The Fortran 95 standard requires the
1229 kinds to match. */
1230 if (i->ts.kind != j->ts.kind)
1232 if (i->ts.kind == gfc_kind_max (i, j))
1233 gfc_convert_type (j, &i->ts, 2);
1234 else
1235 gfc_convert_type (i, &j->ts, 2);
1238 f->ts = i->ts;
1239 f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind);
1243 void
1244 gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1246 resolve_transformational ("iany", f, array, dim, mask);
1250 void
1251 gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1253 f->ts = i->ts;
1254 f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind);
1258 void
1259 gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED,
1260 gfc_expr *len ATTRIBUTE_UNUSED)
1262 f->ts = i->ts;
1263 f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind);
1267 void
1268 gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
1270 f->ts = i->ts;
1271 f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind);
1275 void
1276 gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1278 f->ts.type = BT_INTEGER;
1279 if (kind)
1280 f->ts.kind = mpz_get_si (kind->value.integer);
1281 else
1282 f->ts.kind = gfc_default_integer_kind;
1283 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1287 void
1288 gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
1290 f->ts.type = BT_INTEGER;
1291 if (kind)
1292 f->ts.kind = mpz_get_si (kind->value.integer);
1293 else
1294 f->ts.kind = gfc_default_integer_kind;
1295 f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
1299 void
1300 gfc_resolve_idnint (gfc_expr *f, gfc_expr *a)
1302 gfc_resolve_nint (f, a, NULL);
1306 void
1307 gfc_resolve_ierrno (gfc_expr *f)
1309 f->ts.type = BT_INTEGER;
1310 f->ts.kind = gfc_default_integer_kind;
1311 f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind);
1315 void
1316 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1318 /* If the kind of i and j are different, then g77 cross-promoted the
1319 kinds to the largest value. The Fortran 95 standard requires the
1320 kinds to match. */
1321 if (i->ts.kind != j->ts.kind)
1323 if (i->ts.kind == gfc_kind_max (i, j))
1324 gfc_convert_type (j, &i->ts, 2);
1325 else
1326 gfc_convert_type (i, &j->ts, 2);
1329 f->ts = i->ts;
1330 f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind);
1334 void
1335 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
1337 /* If the kind of i and j are different, then g77 cross-promoted the
1338 kinds to the largest value. The Fortran 95 standard requires the
1339 kinds to match. */
1340 if (i->ts.kind != j->ts.kind)
1342 if (i->ts.kind == gfc_kind_max (i, j))
1343 gfc_convert_type (j, &i->ts, 2);
1344 else
1345 gfc_convert_type (i, &j->ts, 2);
1348 f->ts = i->ts;
1349 f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);
1353 void
1354 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
1355 gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
1356 gfc_expr *kind)
1358 gfc_typespec ts;
1359 gfc_clear_ts (&ts);
1361 f->ts.type = BT_INTEGER;
1362 if (kind)
1363 f->ts.kind = mpz_get_si (kind->value.integer);
1364 else
1365 f->ts.kind = gfc_default_integer_kind;
1367 if (back && back->ts.kind != gfc_default_integer_kind)
1369 ts.type = BT_LOGICAL;
1370 ts.kind = gfc_default_integer_kind;
1371 ts.u.derived = NULL;
1372 ts.u.cl = NULL;
1373 gfc_convert_type (back, &ts, 2);
1376 f->value.function.name
1377 = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind);
1381 void
1382 gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
1384 f->ts.type = BT_INTEGER;
1385 f->ts.kind = (kind == NULL)
1386 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
1387 f->value.function.name
1388 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1389 gfc_type_letter (a->ts.type), a->ts.kind);
1393 void
1394 gfc_resolve_int2 (gfc_expr *f, gfc_expr *a)
1396 f->ts.type = BT_INTEGER;
1397 f->ts.kind = 2;
1398 f->value.function.name
1399 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1400 gfc_type_letter (a->ts.type), a->ts.kind);
1404 void
1405 gfc_resolve_int8 (gfc_expr *f, gfc_expr *a)
1407 f->ts.type = BT_INTEGER;
1408 f->ts.kind = 8;
1409 f->value.function.name
1410 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1411 gfc_type_letter (a->ts.type), a->ts.kind);
1415 void
1416 gfc_resolve_long (gfc_expr *f, gfc_expr *a)
1418 f->ts.type = BT_INTEGER;
1419 f->ts.kind = 4;
1420 f->value.function.name
1421 = gfc_get_string ("__int_%d_%c%d", f->ts.kind,
1422 gfc_type_letter (a->ts.type), a->ts.kind);
1426 void
1427 gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
1429 resolve_transformational ("iparity", f, array, dim, mask);
1433 void
1434 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
1436 gfc_typespec ts;
1437 gfc_clear_ts (&ts);
1439 f->ts.type = BT_LOGICAL;
1440 f->ts.kind = gfc_default_integer_kind;
1441 if (u->ts.kind != gfc_c_int_kind)
1443 ts.type = BT_INTEGER;
1444 ts.kind = gfc_c_int_kind;
1445 ts.u.derived = NULL;
1446 ts.u.cl = NULL;
1447 gfc_convert_type (u, &ts, 2);
1450 f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind);
1454 void
1455 gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1457 f->ts = i->ts;
1458 f->value.function.name
1459 = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind);
1463 void
1464 gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1466 f->ts = i->ts;
1467 f->value.function.name
1468 = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind);
1472 void
1473 gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift)
1475 f->ts = i->ts;
1476 f->value.function.name
1477 = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind);
1481 void
1482 gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
1484 int s_kind;
1486 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
1488 f->ts = i->ts;
1489 f->value.function.name
1490 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
1494 void
1495 gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
1496 gfc_expr *s ATTRIBUTE_UNUSED)
1498 f->ts.type = BT_INTEGER;
1499 f->ts.kind = gfc_default_integer_kind;
1500 f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
1504 void
1505 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1507 resolve_bound (f, array, dim, kind, "__lbound", false);
1511 void
1512 gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
1514 resolve_bound (f, array, dim, kind, "__lcobound", true);
1518 void
1519 gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
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);
1532 void
1533 gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
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);
1544 void
1545 gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
1547 f->ts = x->ts;
1548 f->value.function.name
1549 = gfc_get_string ("__lgamma_%d", x->ts.kind);
1553 void
1554 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
1555 gfc_expr *p2 ATTRIBUTE_UNUSED)
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);
1563 void
1564 gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
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);
1572 void
1573 gfc_resolve_log (gfc_expr *f, gfc_expr *x)
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);
1581 void
1582 gfc_resolve_log10 (gfc_expr *f, gfc_expr *x)
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);
1591 void
1592 gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
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;
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);
1605 void
1606 gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
1608 gfc_expr temp;
1610 if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
1612 f->ts.type = BT_LOGICAL;
1613 f->ts.kind = gfc_default_logical_kind;
1615 else
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;
1626 f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1;
1628 if (a->rank == 2 && b->rank == 2)
1630 if (a->shape && b->shape)
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]);
1637 else if (a->rank == 1)
1639 if (b->shape)
1641 f->shape = gfc_get_shape (f->rank);
1642 mpz_init_set (f->shape[0], b->shape[1]);
1645 else
1647 /* b->rank == 1 and a->rank == 2 here, all other cases have
1648 been caught in check.c. */
1649 if (a->shape)
1651 f->shape = gfc_get_shape (f->rank);
1652 mpz_init_set (f->shape[0], a->shape[0]);
1656 f->value.function.name
1657 = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
1658 f->ts.kind);
1662 static void
1663 gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args)
1665 gfc_actual_arglist *a;
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)
1672 if (a->expr->ts.kind > f->ts.kind)
1673 f->ts.kind = a->expr->ts.kind;
1676 /* Convert all parameters to the required kind. */
1677 for (a = args; a; a = a->next)
1679 if (a->expr->ts.kind != f->ts.kind)
1680 gfc_convert_type (a->expr, &f->ts, 2);
1683 f->value.function.name
1684 = gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind);
1688 void
1689 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
1691 gfc_resolve_minmax ("__max_%c%d", f, args);
1695 void
1696 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1697 gfc_expr *mask)
1699 const char *name;
1700 int i, j, idim;
1702 f->ts.type = BT_INTEGER;
1703 f->ts.kind = gfc_default_integer_kind;
1705 if (dim == NULL)
1707 f->rank = 1;
1708 f->shape = gfc_get_shape (1);
1709 mpz_init_set_si (f->shape[0], array->rank);
1711 else
1713 f->rank = array->rank - 1;
1714 gfc_resolve_dim_arg (dim);
1715 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1717 idim = (int) mpz_get_si (dim->value.integer);
1718 f->shape = gfc_get_shape (f->rank);
1719 for (i = 0, j = 0; i < f->rank; i++, j++)
1721 if (i == (idim - 1))
1722 j++;
1723 mpz_init_set (f->shape[i], array->shape[j]);
1728 if (mask)
1730 if (mask->rank == 0)
1731 name = "smaxloc";
1732 else
1733 name = "mmaxloc";
1735 resolve_mask_arg (mask);
1737 else
1738 name = "maxloc";
1740 f->value.function.name
1741 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1742 gfc_type_letter (array->ts.type), array->ts.kind);
1746 void
1747 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1748 gfc_expr *mask)
1750 const char *name;
1751 int i, j, idim;
1753 f->ts = array->ts;
1755 if (dim != NULL)
1757 f->rank = array->rank - 1;
1758 gfc_resolve_dim_arg (dim);
1760 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1762 idim = (int) mpz_get_si (dim->value.integer);
1763 f->shape = gfc_get_shape (f->rank);
1764 for (i = 0, j = 0; i < f->rank; i++, j++)
1766 if (i == (idim - 1))
1767 j++;
1768 mpz_init_set (f->shape[i], array->shape[j]);
1773 if (mask)
1775 if (mask->rank == 0)
1776 name = "smaxval";
1777 else
1778 name = "mmaxval";
1780 resolve_mask_arg (mask);
1782 else
1783 name = "maxval";
1785 f->value.function.name
1786 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1787 gfc_type_letter (array->ts.type), array->ts.kind);
1791 void
1792 gfc_resolve_mclock (gfc_expr *f)
1794 f->ts.type = BT_INTEGER;
1795 f->ts.kind = 4;
1796 f->value.function.name = PREFIX ("mclock");
1800 void
1801 gfc_resolve_mclock8 (gfc_expr *f)
1803 f->ts.type = BT_INTEGER;
1804 f->ts.kind = 8;
1805 f->value.function.name = PREFIX ("mclock8");
1809 void
1810 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1811 gfc_expr *kind)
1813 f->ts.type = BT_INTEGER;
1814 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1815 : gfc_default_integer_kind;
1817 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1818 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1819 else
1820 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1824 void
1825 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1826 gfc_expr *fsource ATTRIBUTE_UNUSED,
1827 gfc_expr *mask ATTRIBUTE_UNUSED)
1829 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1830 gfc_resolve_substring_charlen (tsource);
1832 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1833 gfc_resolve_substring_charlen (fsource);
1835 if (tsource->ts.type == BT_CHARACTER)
1836 check_charlen_present (tsource);
1838 f->ts = tsource->ts;
1839 f->value.function.name
1840 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1841 tsource->ts.kind);
1845 void
1846 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1847 gfc_expr *j ATTRIBUTE_UNUSED,
1848 gfc_expr *mask ATTRIBUTE_UNUSED)
1850 f->ts = i->ts;
1851 f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
1855 void
1856 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1858 gfc_resolve_minmax ("__min_%c%d", f, args);
1862 void
1863 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1864 gfc_expr *mask)
1866 const char *name;
1867 int i, j, idim;
1869 f->ts.type = BT_INTEGER;
1870 f->ts.kind = gfc_default_integer_kind;
1872 if (dim == NULL)
1874 f->rank = 1;
1875 f->shape = gfc_get_shape (1);
1876 mpz_init_set_si (f->shape[0], array->rank);
1878 else
1880 f->rank = array->rank - 1;
1881 gfc_resolve_dim_arg (dim);
1882 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1884 idim = (int) mpz_get_si (dim->value.integer);
1885 f->shape = gfc_get_shape (f->rank);
1886 for (i = 0, j = 0; i < f->rank; i++, j++)
1888 if (i == (idim - 1))
1889 j++;
1890 mpz_init_set (f->shape[i], array->shape[j]);
1895 if (mask)
1897 if (mask->rank == 0)
1898 name = "sminloc";
1899 else
1900 name = "mminloc";
1902 resolve_mask_arg (mask);
1904 else
1905 name = "minloc";
1907 f->value.function.name
1908 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
1909 gfc_type_letter (array->ts.type), array->ts.kind);
1913 void
1914 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1915 gfc_expr *mask)
1917 const char *name;
1918 int i, j, idim;
1920 f->ts = array->ts;
1922 if (dim != NULL)
1924 f->rank = array->rank - 1;
1925 gfc_resolve_dim_arg (dim);
1927 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1929 idim = (int) mpz_get_si (dim->value.integer);
1930 f->shape = gfc_get_shape (f->rank);
1931 for (i = 0, j = 0; i < f->rank; i++, j++)
1933 if (i == (idim - 1))
1934 j++;
1935 mpz_init_set (f->shape[i], array->shape[j]);
1940 if (mask)
1942 if (mask->rank == 0)
1943 name = "sminval";
1944 else
1945 name = "mminval";
1947 resolve_mask_arg (mask);
1949 else
1950 name = "minval";
1952 f->value.function.name
1953 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1954 gfc_type_letter (array->ts.type), array->ts.kind);
1958 void
1959 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1961 f->ts.type = a->ts.type;
1962 if (p != NULL)
1963 f->ts.kind = gfc_kind_max (a,p);
1964 else
1965 f->ts.kind = a->ts.kind;
1967 if (p != NULL && a->ts.kind != p->ts.kind)
1969 if (a->ts.kind == gfc_kind_max (a,p))
1970 gfc_convert_type (p, &a->ts, 2);
1971 else
1972 gfc_convert_type (a, &p->ts, 2);
1975 f->value.function.name
1976 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
1980 void
1981 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
1983 f->ts.type = a->ts.type;
1984 if (p != NULL)
1985 f->ts.kind = gfc_kind_max (a,p);
1986 else
1987 f->ts.kind = a->ts.kind;
1989 if (p != NULL && a->ts.kind != p->ts.kind)
1991 if (a->ts.kind == gfc_kind_max (a,p))
1992 gfc_convert_type (p, &a->ts, 2);
1993 else
1994 gfc_convert_type (a, &p->ts, 2);
1997 f->value.function.name
1998 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
1999 f->ts.kind);
2002 void
2003 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2005 if (p->ts.kind != a->ts.kind)
2006 gfc_convert_type (p, &a->ts, 2);
2008 f->ts = a->ts;
2009 f->value.function.name
2010 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2011 a->ts.kind);
2014 void
2015 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2017 f->ts.type = BT_INTEGER;
2018 f->ts.kind = (kind == NULL)
2019 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2020 f->value.function.name
2021 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2025 void
2026 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2028 resolve_transformational ("norm2", f, array, dim, NULL);
2032 void
2033 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2035 f->ts = i->ts;
2036 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
2040 void
2041 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2043 f->ts.type = i->ts.type;
2044 f->ts.kind = gfc_kind_max (i, j);
2046 if (i->ts.kind != j->ts.kind)
2048 if (i->ts.kind == gfc_kind_max (i, j))
2049 gfc_convert_type (j, &i->ts, 2);
2050 else
2051 gfc_convert_type (i, &j->ts, 2);
2054 f->value.function.name
2055 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2059 void
2060 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2061 gfc_expr *vector ATTRIBUTE_UNUSED)
2063 if (array->ts.type == BT_CHARACTER && array->ref)
2064 gfc_resolve_substring_charlen (array);
2066 f->ts = array->ts;
2067 f->rank = 1;
2069 resolve_mask_arg (mask);
2071 if (mask->rank != 0)
2073 if (array->ts.type == BT_CHARACTER)
2074 f->value.function.name
2075 = array->ts.kind == 1 ? PREFIX ("pack_char")
2076 : gfc_get_string
2077 (PREFIX ("pack_char%d"),
2078 array->ts.kind);
2079 else
2080 f->value.function.name = PREFIX ("pack");
2082 else
2084 if (array->ts.type == BT_CHARACTER)
2085 f->value.function.name
2086 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2087 : gfc_get_string
2088 (PREFIX ("pack_s_char%d"),
2089 array->ts.kind);
2090 else
2091 f->value.function.name = PREFIX ("pack_s");
2096 void
2097 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2099 resolve_transformational ("parity", f, array, dim, NULL);
2103 void
2104 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2105 gfc_expr *mask)
2107 resolve_transformational ("product", f, array, dim, mask);
2111 void
2112 gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2114 f->ts.type = BT_INTEGER;
2115 f->ts.kind = gfc_default_integer_kind;
2116 f->value.function.name = gfc_get_string ("__rank");
2120 void
2121 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2123 f->ts.type = BT_REAL;
2125 if (kind != NULL)
2126 f->ts.kind = mpz_get_si (kind->value.integer);
2127 else
2128 f->ts.kind = (a->ts.type == BT_COMPLEX)
2129 ? a->ts.kind : gfc_default_real_kind;
2131 f->value.function.name
2132 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2133 gfc_type_letter (a->ts.type), a->ts.kind);
2137 void
2138 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2140 f->ts.type = BT_REAL;
2141 f->ts.kind = a->ts.kind;
2142 f->value.function.name
2143 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2144 gfc_type_letter (a->ts.type), a->ts.kind);
2148 void
2149 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2150 gfc_expr *p2 ATTRIBUTE_UNUSED)
2152 f->ts.type = BT_INTEGER;
2153 f->ts.kind = gfc_default_integer_kind;
2154 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2158 void
2159 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2160 gfc_expr *ncopies)
2162 int len;
2163 gfc_expr *tmp;
2164 f->ts.type = BT_CHARACTER;
2165 f->ts.kind = string->ts.kind;
2166 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2168 /* If possible, generate a character length. */
2169 if (f->ts.u.cl == NULL)
2170 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2172 tmp = NULL;
2173 if (string->expr_type == EXPR_CONSTANT)
2175 len = string->value.character.length;
2176 tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
2178 else if (string->ts.u.cl && string->ts.u.cl->length)
2180 tmp = gfc_copy_expr (string->ts.u.cl->length);
2183 if (tmp)
2184 f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2188 void
2189 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2190 gfc_expr *pad ATTRIBUTE_UNUSED,
2191 gfc_expr *order ATTRIBUTE_UNUSED)
2193 mpz_t rank;
2194 int kind;
2195 int i;
2197 if (source->ts.type == BT_CHARACTER && source->ref)
2198 gfc_resolve_substring_charlen (source);
2200 f->ts = source->ts;
2202 gfc_array_size (shape, &rank);
2203 f->rank = mpz_get_si (rank);
2204 mpz_clear (rank);
2205 switch (source->ts.type)
2207 case BT_COMPLEX:
2208 case BT_REAL:
2209 case BT_INTEGER:
2210 case BT_LOGICAL:
2211 case BT_CHARACTER:
2212 kind = source->ts.kind;
2213 break;
2215 default:
2216 kind = 0;
2217 break;
2220 switch (kind)
2222 case 4:
2223 case 8:
2224 case 10:
2225 case 16:
2226 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2227 f->value.function.name
2228 = gfc_get_string (PREFIX ("reshape_%c%d"),
2229 gfc_type_letter (source->ts.type),
2230 source->ts.kind);
2231 else if (source->ts.type == BT_CHARACTER)
2232 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2233 kind);
2234 else
2235 f->value.function.name
2236 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2237 break;
2239 default:
2240 f->value.function.name = (source->ts.type == BT_CHARACTER
2241 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2242 break;
2245 if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
2247 gfc_constructor *c;
2248 f->shape = gfc_get_shape (f->rank);
2249 c = gfc_constructor_first (shape->value.constructor);
2250 for (i = 0; i < f->rank; i++)
2252 mpz_init_set (f->shape[i], c->expr->value.integer);
2253 c = gfc_constructor_next (c);
2257 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2258 so many runtime variations. */
2259 if (shape->ts.kind != gfc_index_integer_kind)
2261 gfc_typespec ts = shape->ts;
2262 ts.kind = gfc_index_integer_kind;
2263 gfc_convert_type_warn (shape, &ts, 2, 0);
2265 if (order && order->ts.kind != gfc_index_integer_kind)
2266 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2270 void
2271 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2273 f->ts = x->ts;
2274 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2277 void
2278 gfc_resolve_fe_runtime_error (gfc_code *c)
2280 const char *name;
2281 gfc_actual_arglist *a;
2283 name = gfc_get_string (PREFIX ("runtime_error"));
2285 for (a = c->ext.actual->next; a; a = a->next)
2286 a->name = "%VAL";
2288 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2291 void
2292 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2294 f->ts = x->ts;
2295 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2299 void
2300 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2301 gfc_expr *set ATTRIBUTE_UNUSED,
2302 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2304 f->ts.type = BT_INTEGER;
2305 if (kind)
2306 f->ts.kind = mpz_get_si (kind->value.integer);
2307 else
2308 f->ts.kind = gfc_default_integer_kind;
2309 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2313 void
2314 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2316 t1->ts = t0->ts;
2317 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2321 void
2322 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2323 gfc_expr *i ATTRIBUTE_UNUSED)
2325 f->ts = x->ts;
2326 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2330 void
2331 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2333 f->ts.type = BT_INTEGER;
2335 if (kind)
2336 f->ts.kind = mpz_get_si (kind->value.integer);
2337 else
2338 f->ts.kind = gfc_default_integer_kind;
2340 f->rank = 1;
2341 if (array->rank != -1)
2343 f->shape = gfc_get_shape (1);
2344 mpz_init_set_ui (f->shape[0], array->rank);
2347 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2351 void
2352 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2354 f->ts = i->ts;
2355 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2356 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2357 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2358 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2359 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2360 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2361 else
2362 gcc_unreachable ();
2366 void
2367 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2369 f->ts = a->ts;
2370 f->value.function.name
2371 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2375 void
2376 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2378 f->ts.type = BT_INTEGER;
2379 f->ts.kind = gfc_c_int_kind;
2381 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2382 if (handler->ts.type == BT_INTEGER)
2384 if (handler->ts.kind != gfc_c_int_kind)
2385 gfc_convert_type (handler, &f->ts, 2);
2386 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2388 else
2389 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2391 if (number->ts.kind != gfc_c_int_kind)
2392 gfc_convert_type (number, &f->ts, 2);
2396 void
2397 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2399 f->ts = x->ts;
2400 f->value.function.name
2401 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2405 void
2406 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2408 f->ts = x->ts;
2409 f->value.function.name
2410 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2414 void
2415 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2416 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2418 f->ts.type = BT_INTEGER;
2419 if (kind)
2420 f->ts.kind = mpz_get_si (kind->value.integer);
2421 else
2422 f->ts.kind = gfc_default_integer_kind;
2426 void
2427 gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2428 gfc_expr *dim ATTRIBUTE_UNUSED)
2430 f->ts.type = BT_INTEGER;
2431 f->ts.kind = gfc_index_integer_kind;
2435 void
2436 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2438 f->ts = x->ts;
2439 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2443 void
2444 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2445 gfc_expr *ncopies)
2447 if (source->ts.type == BT_CHARACTER && source->ref)
2448 gfc_resolve_substring_charlen (source);
2450 if (source->ts.type == BT_CHARACTER)
2451 check_charlen_present (source);
2453 f->ts = source->ts;
2454 f->rank = source->rank + 1;
2455 if (source->rank == 0)
2457 if (source->ts.type == BT_CHARACTER)
2458 f->value.function.name
2459 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2460 : gfc_get_string
2461 (PREFIX ("spread_char%d_scalar"),
2462 source->ts.kind);
2463 else
2464 f->value.function.name = PREFIX ("spread_scalar");
2466 else
2468 if (source->ts.type == BT_CHARACTER)
2469 f->value.function.name
2470 = source->ts.kind == 1 ? PREFIX ("spread_char")
2471 : gfc_get_string
2472 (PREFIX ("spread_char%d"),
2473 source->ts.kind);
2474 else
2475 f->value.function.name = PREFIX ("spread");
2478 if (dim && gfc_is_constant_expr (dim)
2479 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2481 int i, idim;
2482 idim = mpz_get_ui (dim->value.integer);
2483 f->shape = gfc_get_shape (f->rank);
2484 for (i = 0; i < (idim - 1); i++)
2485 mpz_init_set (f->shape[i], source->shape[i]);
2487 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2489 for (i = idim; i < f->rank ; i++)
2490 mpz_init_set (f->shape[i], source->shape[i-1]);
2494 gfc_resolve_dim_arg (dim);
2495 gfc_resolve_index (ncopies, 1);
2499 void
2500 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2502 f->ts = x->ts;
2503 f->value.function.name
2504 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2508 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2510 void
2511 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2512 gfc_expr *a ATTRIBUTE_UNUSED)
2514 f->ts.type = BT_INTEGER;
2515 f->ts.kind = gfc_default_integer_kind;
2516 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2520 void
2521 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2522 gfc_expr *a ATTRIBUTE_UNUSED)
2524 f->ts.type = BT_INTEGER;
2525 f->ts.kind = gfc_default_integer_kind;
2526 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2530 void
2531 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2533 f->ts.type = BT_INTEGER;
2534 f->ts.kind = gfc_default_integer_kind;
2535 if (n->ts.kind != f->ts.kind)
2536 gfc_convert_type (n, &f->ts, 2);
2538 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2542 void
2543 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2545 gfc_typespec ts;
2546 gfc_clear_ts (&ts);
2548 f->ts.type = BT_INTEGER;
2549 f->ts.kind = gfc_c_int_kind;
2550 if (u->ts.kind != gfc_c_int_kind)
2552 ts.type = BT_INTEGER;
2553 ts.kind = gfc_c_int_kind;
2554 ts.u.derived = NULL;
2555 ts.u.cl = NULL;
2556 gfc_convert_type (u, &ts, 2);
2559 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2563 void
2564 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2566 f->ts.type = BT_INTEGER;
2567 f->ts.kind = gfc_c_int_kind;
2568 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2572 void
2573 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2575 gfc_typespec ts;
2576 gfc_clear_ts (&ts);
2578 f->ts.type = BT_INTEGER;
2579 f->ts.kind = gfc_c_int_kind;
2580 if (u->ts.kind != gfc_c_int_kind)
2582 ts.type = BT_INTEGER;
2583 ts.kind = gfc_c_int_kind;
2584 ts.u.derived = NULL;
2585 ts.u.cl = NULL;
2586 gfc_convert_type (u, &ts, 2);
2589 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2593 void
2594 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2596 f->ts.type = BT_INTEGER;
2597 f->ts.kind = gfc_c_int_kind;
2598 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2602 void
2603 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2605 gfc_typespec ts;
2606 gfc_clear_ts (&ts);
2608 f->ts.type = BT_INTEGER;
2609 f->ts.kind = gfc_intio_kind;
2610 if (u->ts.kind != gfc_c_int_kind)
2612 ts.type = BT_INTEGER;
2613 ts.kind = gfc_c_int_kind;
2614 ts.u.derived = NULL;
2615 ts.u.cl = NULL;
2616 gfc_convert_type (u, &ts, 2);
2619 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2623 void
2624 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2625 gfc_expr *kind)
2627 f->ts.type = BT_INTEGER;
2628 if (kind)
2629 f->ts.kind = mpz_get_si (kind->value.integer);
2630 else
2631 f->ts.kind = gfc_default_integer_kind;
2635 void
2636 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2638 resolve_transformational ("sum", f, array, dim, mask);
2642 void
2643 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2644 gfc_expr *p2 ATTRIBUTE_UNUSED)
2646 f->ts.type = BT_INTEGER;
2647 f->ts.kind = gfc_default_integer_kind;
2648 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2652 /* Resolve the g77 compatibility function SYSTEM. */
2654 void
2655 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2657 f->ts.type = BT_INTEGER;
2658 f->ts.kind = 4;
2659 f->value.function.name = gfc_get_string (PREFIX ("system"));
2663 void
2664 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2666 f->ts = x->ts;
2667 f->value.function.name
2668 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2672 void
2673 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2675 f->ts = x->ts;
2676 f->value.function.name
2677 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2681 /* Build an expression for converting degrees to radians. */
2683 static gfc_expr *
2684 get_radians (gfc_expr *deg)
2686 gfc_expr *result, *factor;
2687 gfc_actual_arglist *mod_args;
2689 gcc_assert (deg->ts.type == BT_REAL);
2691 /* Set deg = deg % 360 to avoid offsets from large angles. */
2692 factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
2693 mpfr_set_d (factor->value.real, 360.0, GFC_RND_MODE);
2695 mod_args = gfc_get_actual_arglist ();
2696 mod_args->expr = deg;
2697 mod_args->next = gfc_get_actual_arglist ();
2698 mod_args->next->expr = factor;
2700 result = gfc_get_expr ();
2701 result->ts = deg->ts;
2702 result->where = deg->where;
2703 result->expr_type = EXPR_FUNCTION;
2704 result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
2705 result->value.function.actual = mod_args;
2707 /* Set factor = pi / 180. */
2708 factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
2709 mpfr_const_pi (factor->value.real, GFC_RND_MODE);
2710 mpfr_div_ui (factor->value.real, factor->value.real, 180, GFC_RND_MODE);
2712 /* Result is rad = (deg % 360) * (pi / 180). */
2713 result = gfc_multiply (result, factor);
2714 return result;
2718 /* Build an expression for converting radians to degrees. */
2720 static gfc_expr *
2721 get_degrees (gfc_expr *rad)
2723 gfc_expr *result, *factor;
2724 gfc_actual_arglist *mod_args;
2725 mpfr_t tmp;
2727 gcc_assert (rad->ts.type == BT_REAL);
2729 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2730 factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
2731 mpfr_const_pi (factor->value.real, GFC_RND_MODE);
2732 mpfr_mul_ui (factor->value.real, factor->value.real, 2, GFC_RND_MODE);
2734 mod_args = gfc_get_actual_arglist ();
2735 mod_args->expr = rad;
2736 mod_args->next = gfc_get_actual_arglist ();
2737 mod_args->next->expr = factor;
2739 result = gfc_get_expr ();
2740 result->ts = rad->ts;
2741 result->where = rad->where;
2742 result->expr_type = EXPR_FUNCTION;
2743 result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
2744 result->value.function.actual = mod_args;
2746 /* Set factor = 180 / pi. */
2747 factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
2748 mpfr_set_ui (factor->value.real, 180, GFC_RND_MODE);
2749 mpfr_init (tmp);
2750 mpfr_const_pi (tmp, GFC_RND_MODE);
2751 mpfr_div (factor->value.real, factor->value.real, tmp, GFC_RND_MODE);
2752 mpfr_clear (tmp);
2754 /* Result is deg = (rad % 2pi) * (180 / pi). */
2755 result = gfc_multiply (result, factor);
2756 return result;
2760 /* Resolve a call to a trig function. */
2762 static void
2763 resolve_trig_call (gfc_expr *f, gfc_expr *x)
2765 switch (f->value.function.isym->id)
2767 case GFC_ISYM_ACOS:
2768 return gfc_resolve_acos (f, x);
2769 case GFC_ISYM_ASIN:
2770 return gfc_resolve_asin (f, x);
2771 case GFC_ISYM_ATAN:
2772 return gfc_resolve_atan (f, x);
2773 case GFC_ISYM_ATAN2:
2774 /* NB. arg3 is unused for atan2 */
2775 return gfc_resolve_atan2 (f, x, NULL);
2776 case GFC_ISYM_COS:
2777 return gfc_resolve_cos (f, x);
2778 case GFC_ISYM_COTAN:
2779 return gfc_resolve_cotan (f, x);
2780 case GFC_ISYM_SIN:
2781 return gfc_resolve_sin (f, x);
2782 case GFC_ISYM_TAN:
2783 return gfc_resolve_tan (f, x);
2784 default:
2785 gcc_unreachable ();
2789 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2791 void
2792 gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
2794 if (is_trig_resolved (f))
2795 return;
2797 x = get_radians (x);
2798 f->value.function.actual->expr = x;
2800 resolve_trig_call (f, x);
2804 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2806 void
2807 gfc_resolve_atrigd (gfc_expr *f, gfc_expr *x)
2809 gfc_expr *result, *fcopy;
2811 if (is_trig_resolved (f))
2812 return;
2814 resolve_trig_call (f, x);
2816 fcopy = copy_replace_function_shallow (f);
2817 result = get_degrees (fcopy);
2818 gfc_replace_expr (f, result);
2822 /* Resolve atan2d(x) = degrees(atan2(x)). */
2824 void
2825 gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
2827 /* Note that we lose the second arg here - that's okay because it is
2828 unused in gfc_resolve_atan2 anyway. */
2829 gfc_resolve_atrigd (f, x);
2833 /* Resolve failed_images (team, kind). */
2835 void
2836 gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2837 gfc_expr *kind)
2839 static char failed_images[] = "_gfortran_caf_failed_images";
2840 f->rank = 1;
2841 f->ts.type = BT_INTEGER;
2842 if (kind == NULL)
2843 f->ts.kind = gfc_default_integer_kind;
2844 else
2845 gfc_extract_int (kind, &f->ts.kind);
2846 f->value.function.name = failed_images;
2850 /* Resolve image_status (image, team). */
2852 void
2853 gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2854 gfc_expr *team ATTRIBUTE_UNUSED)
2856 static char image_status[] = "_gfortran_caf_image_status";
2857 f->ts.type = BT_INTEGER;
2858 f->ts.kind = gfc_default_integer_kind;
2859 f->value.function.name = image_status;
2863 /* Resolve image_index (...). */
2865 void
2866 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2867 gfc_expr *sub ATTRIBUTE_UNUSED)
2869 static char image_index[] = "__image_index";
2870 f->ts.type = BT_INTEGER;
2871 f->ts.kind = gfc_default_integer_kind;
2872 f->value.function.name = image_index;
2876 /* Resolve stopped_images (team, kind). */
2878 void
2879 gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2880 gfc_expr *kind)
2882 static char stopped_images[] = "_gfortran_caf_stopped_images";
2883 f->rank = 1;
2884 f->ts.type = BT_INTEGER;
2885 if (kind == NULL)
2886 f->ts.kind = gfc_default_integer_kind;
2887 else
2888 gfc_extract_int (kind, &f->ts.kind);
2889 f->value.function.name = stopped_images;
2893 void
2894 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2895 gfc_expr *distance ATTRIBUTE_UNUSED)
2897 static char this_image[] = "__this_image";
2898 if (array && gfc_is_coarray (array))
2899 resolve_bound (f, array, dim, NULL, "__this_image", true);
2900 else
2902 f->ts.type = BT_INTEGER;
2903 f->ts.kind = gfc_default_integer_kind;
2904 f->value.function.name = this_image;
2909 void
2910 gfc_resolve_time (gfc_expr *f)
2912 f->ts.type = BT_INTEGER;
2913 f->ts.kind = 4;
2914 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2918 void
2919 gfc_resolve_time8 (gfc_expr *f)
2921 f->ts.type = BT_INTEGER;
2922 f->ts.kind = 8;
2923 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
2927 void
2928 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
2929 gfc_expr *mold, gfc_expr *size)
2931 /* TODO: Make this do something meaningful. */
2932 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
2934 if (mold->ts.type == BT_CHARACTER
2935 && !mold->ts.u.cl->length
2936 && gfc_is_constant_expr (mold))
2938 int len;
2939 if (mold->expr_type == EXPR_CONSTANT)
2941 len = mold->value.character.length;
2942 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2943 NULL, len);
2945 else
2947 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
2948 len = c->expr->value.character.length;
2949 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2950 NULL, len);
2954 f->ts = mold->ts;
2956 if (size == NULL && mold->rank == 0)
2958 f->rank = 0;
2959 f->value.function.name = transfer0;
2961 else
2963 f->rank = 1;
2964 f->value.function.name = transfer1;
2965 if (size && gfc_is_constant_expr (size))
2967 f->shape = gfc_get_shape (1);
2968 mpz_init_set (f->shape[0], size->value.integer);
2974 void
2975 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
2978 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
2979 gfc_resolve_substring_charlen (matrix);
2981 f->ts = matrix->ts;
2982 f->rank = 2;
2983 if (matrix->shape)
2985 f->shape = gfc_get_shape (2);
2986 mpz_init_set (f->shape[0], matrix->shape[1]);
2987 mpz_init_set (f->shape[1], matrix->shape[0]);
2990 switch (matrix->ts.kind)
2992 case 4:
2993 case 8:
2994 case 10:
2995 case 16:
2996 switch (matrix->ts.type)
2998 case BT_REAL:
2999 case BT_COMPLEX:
3000 f->value.function.name
3001 = gfc_get_string (PREFIX ("transpose_%c%d"),
3002 gfc_type_letter (matrix->ts.type),
3003 matrix->ts.kind);
3004 break;
3006 case BT_INTEGER:
3007 case BT_LOGICAL:
3008 /* Use the integer routines for real and logical cases. This
3009 assumes they all have the same alignment requirements. */
3010 f->value.function.name
3011 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3012 break;
3014 default:
3015 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3016 f->value.function.name = PREFIX ("transpose_char4");
3017 else
3018 f->value.function.name = PREFIX ("transpose");
3019 break;
3021 break;
3023 default:
3024 f->value.function.name = (matrix->ts.type == BT_CHARACTER
3025 ? PREFIX ("transpose_char")
3026 : PREFIX ("transpose"));
3027 break;
3032 void
3033 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3035 f->ts.type = BT_CHARACTER;
3036 f->ts.kind = string->ts.kind;
3037 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3041 void
3042 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3044 resolve_bound (f, array, dim, kind, "__ubound", false);
3048 void
3049 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3051 resolve_bound (f, array, dim, kind, "__ucobound", true);
3055 /* Resolve the g77 compatibility function UMASK. */
3057 void
3058 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3060 f->ts.type = BT_INTEGER;
3061 f->ts.kind = n->ts.kind;
3062 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3066 /* Resolve the g77 compatibility function UNLINK. */
3068 void
3069 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3071 f->ts.type = BT_INTEGER;
3072 f->ts.kind = 4;
3073 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3077 void
3078 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3080 gfc_typespec ts;
3081 gfc_clear_ts (&ts);
3083 f->ts.type = BT_CHARACTER;
3084 f->ts.kind = gfc_default_character_kind;
3086 if (unit->ts.kind != gfc_c_int_kind)
3088 ts.type = BT_INTEGER;
3089 ts.kind = gfc_c_int_kind;
3090 ts.u.derived = NULL;
3091 ts.u.cl = NULL;
3092 gfc_convert_type (unit, &ts, 2);
3095 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3099 void
3100 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3101 gfc_expr *field ATTRIBUTE_UNUSED)
3103 if (vector->ts.type == BT_CHARACTER && vector->ref)
3104 gfc_resolve_substring_charlen (vector);
3106 f->ts = vector->ts;
3107 f->rank = mask->rank;
3108 resolve_mask_arg (mask);
3110 if (vector->ts.type == BT_CHARACTER)
3112 if (vector->ts.kind == 1)
3113 f->value.function.name
3114 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3115 else
3116 f->value.function.name
3117 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3118 field->rank > 0 ? 1 : 0, vector->ts.kind);
3120 else
3121 f->value.function.name
3122 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3126 void
3127 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3128 gfc_expr *set ATTRIBUTE_UNUSED,
3129 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3131 f->ts.type = BT_INTEGER;
3132 if (kind)
3133 f->ts.kind = mpz_get_si (kind->value.integer);
3134 else
3135 f->ts.kind = gfc_default_integer_kind;
3136 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3140 void
3141 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3143 f->ts.type = i->ts.type;
3144 f->ts.kind = gfc_kind_max (i, j);
3146 if (i->ts.kind != j->ts.kind)
3148 if (i->ts.kind == gfc_kind_max (i, j))
3149 gfc_convert_type (j, &i->ts, 2);
3150 else
3151 gfc_convert_type (i, &j->ts, 2);
3154 f->value.function.name
3155 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
3159 /* Intrinsic subroutine resolution. */
3161 void
3162 gfc_resolve_alarm_sub (gfc_code *c)
3164 const char *name;
3165 gfc_expr *seconds, *handler;
3166 gfc_typespec ts;
3167 gfc_clear_ts (&ts);
3169 seconds = c->ext.actual->expr;
3170 handler = c->ext.actual->next->expr;
3171 ts.type = BT_INTEGER;
3172 ts.kind = gfc_c_int_kind;
3174 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3175 In all cases, the status argument is of default integer kind
3176 (enforced in check.c) so that the function suffix is fixed. */
3177 if (handler->ts.type == BT_INTEGER)
3179 if (handler->ts.kind != gfc_c_int_kind)
3180 gfc_convert_type (handler, &ts, 2);
3181 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3182 gfc_default_integer_kind);
3184 else
3185 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3186 gfc_default_integer_kind);
3188 if (seconds->ts.kind != gfc_c_int_kind)
3189 gfc_convert_type (seconds, &ts, 2);
3191 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3194 void
3195 gfc_resolve_cpu_time (gfc_code *c)
3197 const char *name;
3198 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3199 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3203 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3205 static gfc_formal_arglist*
3206 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3208 gfc_formal_arglist* head;
3209 gfc_formal_arglist* tail;
3210 int i;
3212 if (!actual)
3213 return NULL;
3215 head = tail = gfc_get_formal_arglist ();
3216 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3218 gfc_symbol* sym;
3220 sym = gfc_new_symbol ("dummyarg", NULL);
3221 sym->ts = actual->expr->ts;
3223 sym->attr.intent = ints[i];
3224 tail->sym = sym;
3226 if (actual->next)
3227 tail->next = gfc_get_formal_arglist ();
3230 return head;
3234 void
3235 gfc_resolve_atomic_def (gfc_code *c)
3237 const char *name = "atomic_define";
3238 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3242 void
3243 gfc_resolve_atomic_ref (gfc_code *c)
3245 const char *name = "atomic_ref";
3246 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3249 void
3250 gfc_resolve_event_query (gfc_code *c)
3252 const char *name = "event_query";
3253 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3256 void
3257 gfc_resolve_mvbits (gfc_code *c)
3259 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3260 INTENT_INOUT, INTENT_IN};
3262 const char *name;
3263 gfc_typespec ts;
3264 gfc_clear_ts (&ts);
3266 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3267 they will be converted so that they fit into a C int. */
3268 ts.type = BT_INTEGER;
3269 ts.kind = gfc_c_int_kind;
3270 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
3271 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
3272 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
3273 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
3274 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
3275 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
3277 /* TO and FROM are guaranteed to have the same kind parameter. */
3278 name = gfc_get_string (PREFIX ("mvbits_i%d"),
3279 c->ext.actual->expr->ts.kind);
3280 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3281 /* Mark as elemental subroutine as this does not happen automatically. */
3282 c->resolved_sym->attr.elemental = 1;
3284 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3285 of creating temporaries. */
3286 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3290 void
3291 gfc_resolve_random_number (gfc_code *c)
3293 const char *name;
3294 int kind;
3296 kind = c->ext.actual->expr->ts.kind;
3297 if (c->ext.actual->expr->rank == 0)
3298 name = gfc_get_string (PREFIX ("random_r%d"), kind);
3299 else
3300 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3302 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3306 void
3307 gfc_resolve_random_seed (gfc_code *c)
3309 const char *name;
3311 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3312 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3316 void
3317 gfc_resolve_rename_sub (gfc_code *c)
3319 const char *name;
3320 int kind;
3322 if (c->ext.actual->next->next->expr != NULL)
3323 kind = c->ext.actual->next->next->expr->ts.kind;
3324 else
3325 kind = gfc_default_integer_kind;
3327 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3328 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3332 void
3333 gfc_resolve_kill_sub (gfc_code *c)
3335 const char *name;
3336 int kind;
3338 if (c->ext.actual->next->next->expr != NULL)
3339 kind = c->ext.actual->next->next->expr->ts.kind;
3340 else
3341 kind = gfc_default_integer_kind;
3343 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
3344 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3348 void
3349 gfc_resolve_link_sub (gfc_code *c)
3351 const char *name;
3352 int kind;
3354 if (c->ext.actual->next->next->expr != NULL)
3355 kind = c->ext.actual->next->next->expr->ts.kind;
3356 else
3357 kind = gfc_default_integer_kind;
3359 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3360 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3364 void
3365 gfc_resolve_symlnk_sub (gfc_code *c)
3367 const char *name;
3368 int kind;
3370 if (c->ext.actual->next->next->expr != NULL)
3371 kind = c->ext.actual->next->next->expr->ts.kind;
3372 else
3373 kind = gfc_default_integer_kind;
3375 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3376 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3380 /* G77 compatibility subroutines dtime() and etime(). */
3382 void
3383 gfc_resolve_dtime_sub (gfc_code *c)
3385 const char *name;
3386 name = gfc_get_string (PREFIX ("dtime_sub"));
3387 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3390 void
3391 gfc_resolve_etime_sub (gfc_code *c)
3393 const char *name;
3394 name = gfc_get_string (PREFIX ("etime_sub"));
3395 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3399 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3401 void
3402 gfc_resolve_itime (gfc_code *c)
3404 c->resolved_sym
3405 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3406 gfc_default_integer_kind));
3409 void
3410 gfc_resolve_idate (gfc_code *c)
3412 c->resolved_sym
3413 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3414 gfc_default_integer_kind));
3417 void
3418 gfc_resolve_ltime (gfc_code *c)
3420 c->resolved_sym
3421 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3422 gfc_default_integer_kind));
3425 void
3426 gfc_resolve_gmtime (gfc_code *c)
3428 c->resolved_sym
3429 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3430 gfc_default_integer_kind));
3434 /* G77 compatibility subroutine second(). */
3436 void
3437 gfc_resolve_second_sub (gfc_code *c)
3439 const char *name;
3440 name = gfc_get_string (PREFIX ("second_sub"));
3441 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3445 void
3446 gfc_resolve_sleep_sub (gfc_code *c)
3448 const char *name;
3449 int kind;
3451 if (c->ext.actual->expr != NULL)
3452 kind = c->ext.actual->expr->ts.kind;
3453 else
3454 kind = gfc_default_integer_kind;
3456 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3457 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3461 /* G77 compatibility function srand(). */
3463 void
3464 gfc_resolve_srand (gfc_code *c)
3466 const char *name;
3467 name = gfc_get_string (PREFIX ("srand"));
3468 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3472 /* Resolve the getarg intrinsic subroutine. */
3474 void
3475 gfc_resolve_getarg (gfc_code *c)
3477 const char *name;
3479 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3481 gfc_typespec ts;
3482 gfc_clear_ts (&ts);
3484 ts.type = BT_INTEGER;
3485 ts.kind = gfc_default_integer_kind;
3487 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3490 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3491 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3495 /* Resolve the getcwd intrinsic subroutine. */
3497 void
3498 gfc_resolve_getcwd_sub (gfc_code *c)
3500 const char *name;
3501 int kind;
3503 if (c->ext.actual->next->expr != NULL)
3504 kind = c->ext.actual->next->expr->ts.kind;
3505 else
3506 kind = gfc_default_integer_kind;
3508 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3509 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3513 /* Resolve the get_command intrinsic subroutine. */
3515 void
3516 gfc_resolve_get_command (gfc_code *c)
3518 const char *name;
3519 int kind;
3520 kind = gfc_default_integer_kind;
3521 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3522 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3526 /* Resolve the get_command_argument intrinsic subroutine. */
3528 void
3529 gfc_resolve_get_command_argument (gfc_code *c)
3531 const char *name;
3532 int kind;
3533 kind = gfc_default_integer_kind;
3534 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3535 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3539 /* Resolve the get_environment_variable intrinsic subroutine. */
3541 void
3542 gfc_resolve_get_environment_variable (gfc_code *code)
3544 const char *name;
3545 int kind;
3546 kind = gfc_default_integer_kind;
3547 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3548 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3552 void
3553 gfc_resolve_signal_sub (gfc_code *c)
3555 const char *name;
3556 gfc_expr *number, *handler, *status;
3557 gfc_typespec ts;
3558 gfc_clear_ts (&ts);
3560 number = c->ext.actual->expr;
3561 handler = c->ext.actual->next->expr;
3562 status = c->ext.actual->next->next->expr;
3563 ts.type = BT_INTEGER;
3564 ts.kind = gfc_c_int_kind;
3566 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3567 if (handler->ts.type == BT_INTEGER)
3569 if (handler->ts.kind != gfc_c_int_kind)
3570 gfc_convert_type (handler, &ts, 2);
3571 name = gfc_get_string (PREFIX ("signal_sub_int"));
3573 else
3574 name = gfc_get_string (PREFIX ("signal_sub"));
3576 if (number->ts.kind != gfc_c_int_kind)
3577 gfc_convert_type (number, &ts, 2);
3578 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3579 gfc_convert_type (status, &ts, 2);
3581 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3585 /* Resolve the SYSTEM intrinsic subroutine. */
3587 void
3588 gfc_resolve_system_sub (gfc_code *c)
3590 const char *name;
3591 name = gfc_get_string (PREFIX ("system_sub"));
3592 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3596 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3598 void
3599 gfc_resolve_system_clock (gfc_code *c)
3601 const char *name;
3602 int kind;
3603 gfc_expr *count = c->ext.actual->expr;
3604 gfc_expr *count_max = c->ext.actual->next->next->expr;
3606 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3607 and COUNT_MAX can hold 64-bit values, or are absent. */
3608 if ((!count || count->ts.kind >= 8)
3609 && (!count_max || count_max->ts.kind >= 8))
3610 kind = 8;
3611 else
3612 kind = gfc_default_integer_kind;
3614 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3615 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3619 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3620 void
3621 gfc_resolve_execute_command_line (gfc_code *c)
3623 const char *name;
3624 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3625 gfc_default_integer_kind);
3626 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3630 /* Resolve the EXIT intrinsic subroutine. */
3632 void
3633 gfc_resolve_exit (gfc_code *c)
3635 const char *name;
3636 gfc_typespec ts;
3637 gfc_expr *n;
3638 gfc_clear_ts (&ts);
3640 /* The STATUS argument has to be of default kind. If it is not,
3641 we convert it. */
3642 ts.type = BT_INTEGER;
3643 ts.kind = gfc_default_integer_kind;
3644 n = c->ext.actual->expr;
3645 if (n != NULL && n->ts.kind != ts.kind)
3646 gfc_convert_type (n, &ts, 2);
3648 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3649 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3653 /* Resolve the FLUSH intrinsic subroutine. */
3655 void
3656 gfc_resolve_flush (gfc_code *c)
3658 const char *name;
3659 gfc_typespec ts;
3660 gfc_expr *n;
3661 gfc_clear_ts (&ts);
3663 ts.type = BT_INTEGER;
3664 ts.kind = gfc_default_integer_kind;
3665 n = c->ext.actual->expr;
3666 if (n != NULL && n->ts.kind != ts.kind)
3667 gfc_convert_type (n, &ts, 2);
3669 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3670 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3674 void
3675 gfc_resolve_ctime_sub (gfc_code *c)
3677 gfc_typespec ts;
3678 gfc_clear_ts (&ts);
3680 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3681 if (c->ext.actual->expr->ts.kind != 8)
3683 ts.type = BT_INTEGER;
3684 ts.kind = 8;
3685 ts.u.derived = NULL;
3686 ts.u.cl = NULL;
3687 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3690 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3694 void
3695 gfc_resolve_fdate_sub (gfc_code *c)
3697 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3701 void
3702 gfc_resolve_gerror (gfc_code *c)
3704 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3708 void
3709 gfc_resolve_getlog (gfc_code *c)
3711 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3715 void
3716 gfc_resolve_hostnm_sub (gfc_code *c)
3718 const char *name;
3719 int kind;
3721 if (c->ext.actual->next->expr != NULL)
3722 kind = c->ext.actual->next->expr->ts.kind;
3723 else
3724 kind = gfc_default_integer_kind;
3726 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3727 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3731 void
3732 gfc_resolve_perror (gfc_code *c)
3734 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3737 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3739 void
3740 gfc_resolve_stat_sub (gfc_code *c)
3742 const char *name;
3743 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3744 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3748 void
3749 gfc_resolve_lstat_sub (gfc_code *c)
3751 const char *name;
3752 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3753 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3757 void
3758 gfc_resolve_fstat_sub (gfc_code *c)
3760 const char *name;
3761 gfc_expr *u;
3762 gfc_typespec *ts;
3764 u = c->ext.actual->expr;
3765 ts = &c->ext.actual->next->expr->ts;
3766 if (u->ts.kind != ts->kind)
3767 gfc_convert_type (u, ts, 2);
3768 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3769 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3773 void
3774 gfc_resolve_fgetc_sub (gfc_code *c)
3776 const char *name;
3777 gfc_typespec ts;
3778 gfc_expr *u, *st;
3779 gfc_clear_ts (&ts);
3781 u = c->ext.actual->expr;
3782 st = c->ext.actual->next->next->expr;
3784 if (u->ts.kind != gfc_c_int_kind)
3786 ts.type = BT_INTEGER;
3787 ts.kind = gfc_c_int_kind;
3788 ts.u.derived = NULL;
3789 ts.u.cl = NULL;
3790 gfc_convert_type (u, &ts, 2);
3793 if (st != NULL)
3794 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3795 else
3796 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3798 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3802 void
3803 gfc_resolve_fget_sub (gfc_code *c)
3805 const char *name;
3806 gfc_expr *st;
3808 st = c->ext.actual->next->expr;
3809 if (st != NULL)
3810 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3811 else
3812 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3814 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3818 void
3819 gfc_resolve_fputc_sub (gfc_code *c)
3821 const char *name;
3822 gfc_typespec ts;
3823 gfc_expr *u, *st;
3824 gfc_clear_ts (&ts);
3826 u = c->ext.actual->expr;
3827 st = c->ext.actual->next->next->expr;
3829 if (u->ts.kind != gfc_c_int_kind)
3831 ts.type = BT_INTEGER;
3832 ts.kind = gfc_c_int_kind;
3833 ts.u.derived = NULL;
3834 ts.u.cl = NULL;
3835 gfc_convert_type (u, &ts, 2);
3838 if (st != NULL)
3839 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3840 else
3841 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3843 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3847 void
3848 gfc_resolve_fput_sub (gfc_code *c)
3850 const char *name;
3851 gfc_expr *st;
3853 st = c->ext.actual->next->expr;
3854 if (st != NULL)
3855 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3856 else
3857 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3859 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3863 void
3864 gfc_resolve_fseek_sub (gfc_code *c)
3866 gfc_expr *unit;
3867 gfc_expr *offset;
3868 gfc_expr *whence;
3869 gfc_typespec ts;
3870 gfc_clear_ts (&ts);
3872 unit = c->ext.actual->expr;
3873 offset = c->ext.actual->next->expr;
3874 whence = c->ext.actual->next->next->expr;
3876 if (unit->ts.kind != gfc_c_int_kind)
3878 ts.type = BT_INTEGER;
3879 ts.kind = gfc_c_int_kind;
3880 ts.u.derived = NULL;
3881 ts.u.cl = NULL;
3882 gfc_convert_type (unit, &ts, 2);
3885 if (offset->ts.kind != gfc_intio_kind)
3887 ts.type = BT_INTEGER;
3888 ts.kind = gfc_intio_kind;
3889 ts.u.derived = NULL;
3890 ts.u.cl = NULL;
3891 gfc_convert_type (offset, &ts, 2);
3894 if (whence->ts.kind != gfc_c_int_kind)
3896 ts.type = BT_INTEGER;
3897 ts.kind = gfc_c_int_kind;
3898 ts.u.derived = NULL;
3899 ts.u.cl = NULL;
3900 gfc_convert_type (whence, &ts, 2);
3903 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3906 void
3907 gfc_resolve_ftell_sub (gfc_code *c)
3909 const char *name;
3910 gfc_expr *unit;
3911 gfc_expr *offset;
3912 gfc_typespec ts;
3913 gfc_clear_ts (&ts);
3915 unit = c->ext.actual->expr;
3916 offset = c->ext.actual->next->expr;
3918 if (unit->ts.kind != gfc_c_int_kind)
3920 ts.type = BT_INTEGER;
3921 ts.kind = gfc_c_int_kind;
3922 ts.u.derived = NULL;
3923 ts.u.cl = NULL;
3924 gfc_convert_type (unit, &ts, 2);
3927 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
3928 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3932 void
3933 gfc_resolve_ttynam_sub (gfc_code *c)
3935 gfc_typespec ts;
3936 gfc_clear_ts (&ts);
3938 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
3940 ts.type = BT_INTEGER;
3941 ts.kind = gfc_c_int_kind;
3942 ts.u.derived = NULL;
3943 ts.u.cl = NULL;
3944 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3947 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
3951 /* Resolve the UMASK intrinsic subroutine. */
3953 void
3954 gfc_resolve_umask_sub (gfc_code *c)
3956 const char *name;
3957 int kind;
3959 if (c->ext.actual->next->expr != NULL)
3960 kind = c->ext.actual->next->expr->ts.kind;
3961 else
3962 kind = gfc_default_integer_kind;
3964 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
3965 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3968 /* Resolve the UNLINK intrinsic subroutine. */
3970 void
3971 gfc_resolve_unlink_sub (gfc_code *c)
3973 const char *name;
3974 int kind;
3976 if (c->ext.actual->next->expr != NULL)
3977 kind = c->ext.actual->next->expr->ts.kind;
3978 else
3979 kind = gfc_default_integer_kind;
3981 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
3982 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);