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