?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR c++/83490
[official-gcc.git] / gcc / fortran / iresolve.c
blob3226a88832d44c0246e6c9adce5f1e8be24dc9c7
1 /* Intrinsic function resolution.
2 Copyright (C) 2000-2017 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_default_integer_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_default_integer_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_default_integer_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)
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
1786
1787 void
1788 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1789 gfc_expr *mask)
1790 {
1791 const char *name;
1792 int i, j, idim;
1793
1794 f->ts = array->ts;
1795
1796 if (dim != NULL)
1797 {
1798 f->rank = array->rank - 1;
1799 gfc_resolve_dim_arg (dim);
1800
1801 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
1802 {
1803 idim = (int) mpz_get_si (dim->value.integer);
1804 f->shape = gfc_get_shape (f->rank);
1805 for (i = 0, j = 0; i < f->rank; i++, j++)
1806 {
1807 if (i == (idim - 1))
1808 j++;
1809 mpz_init_set (f->shape[i], array->shape[j]);
1810 }
1811 }
1812 }
1813
1814 if (mask)
1815 {
1816 if (mask->rank == 0)
1817 name = "smaxval";
1818 else
1819 name = "mmaxval";
1820
1821 resolve_mask_arg (mask);
1822 }
1823 else
1824 name = "maxval";
1825
1826 if (array->ts.type != BT_CHARACTER)
1827 f->value.function.name
1828 = gfc_get_string (PREFIX ("%s_%c%d"), name,
1829 gfc_type_letter (array->ts.type), array->ts.kind);
1830 else
1831 f->value.function.name
1832 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
1833 gfc_type_letter (array->ts.type), array->ts.kind);
1834 }
1835
1836
1837 void
1838 gfc_resolve_mclock (gfc_expr *f)
1839 {
1840 f->ts.type = BT_INTEGER;
1841 f->ts.kind = 4;
1842 f->value.function.name = PREFIX ("mclock");
1843 }
1844
1845
1846 void
1847 gfc_resolve_mclock8 (gfc_expr *f)
1848 {
1849 f->ts.type = BT_INTEGER;
1850 f->ts.kind = 8;
1851 f->value.function.name = PREFIX ("mclock8");
1852 }
1853
1854
1855 void
1856 gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
1857 gfc_expr *kind)
1858 {
1859 f->ts.type = BT_INTEGER;
1860 f->ts.kind = kind ? mpz_get_si (kind->value.integer)
1861 : gfc_default_integer_kind;
1862
1863 if (f->value.function.isym->id == GFC_ISYM_MASKL)
1864 f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
1865 else
1866 f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
1867 }
1868
1869
1870 void
1871 gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
1872 gfc_expr *fsource ATTRIBUTE_UNUSED,
1873 gfc_expr *mask ATTRIBUTE_UNUSED)
1874 {
1875 if (tsource->ts.type == BT_CHARACTER && tsource->ref)
1876 gfc_resolve_substring_charlen (tsource);
1877
1878 if (fsource->ts.type == BT_CHARACTER && fsource->ref)
1879 gfc_resolve_substring_charlen (fsource);
1880
1881 if (tsource->ts.type == BT_CHARACTER)
1882 check_charlen_present (tsource);
1883
1884 f->ts = tsource->ts;
1885 f->value.function.name
1886 = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
1887 tsource->ts.kind);
1888 }
1889
1890
1891 void
1892 gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
1893 gfc_expr *j ATTRIBUTE_UNUSED,
1894 gfc_expr *mask ATTRIBUTE_UNUSED)
1895 {
1896 f->ts = i->ts;
1897 f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
1898 }
1899
1900
1901 void
1902 gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
1903 {
1904 gfc_resolve_minmax ("__min_%c%d", f, args);
1905 }
1906
1907
1908 void
1909 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1910 gfc_expr *mask, gfc_expr *kind)
1911 {
1912 const char *name;
1913 int i, j, idim;
1914 int fkind;
1915 int d_num;
1916
1917 f->ts.type = BT_INTEGER;
1918
1919 /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
1920 we do a type conversion further down. */
1921 if (kind)
1922 fkind = mpz_get_si (kind->value.integer);
1923 else
1924 fkind = gfc_default_integer_kind;
1925
1926 if (fkind < MINMAXLOC_MIN_KIND)
1927 f->ts.kind = MINMAXLOC_MIN_KIND;
1928 else
1929 f->ts.kind = fkind;
1930
1931 if (dim == NULL)
1932 {
1933 f->rank = 1;
1934 f->shape = gfc_get_shape (1);
1935 mpz_init_set_si (f->shape[0], array->rank);
1936 }
1937 else
1938 {
1939 f->rank = array->rank - 1;
1940 gfc_resolve_dim_arg (dim);
1941 if (array->shape && dim->expr_type == EXPR_CONSTANT)
1942 {
1943 idim = (int) mpz_get_si (dim->value.integer);
1944 f->shape = gfc_get_shape (f->rank);
1945 for (i = 0, j = 0; i < f->rank; i++, j++)
1946 {
1947 if (i == (idim - 1))
1948 j++;
1949 mpz_init_set (f->shape[i], array->shape[j]);
1950 }
1951 }
1952 }
1953
1954 if (mask)
1955 {
1956 if (mask->rank == 0)
1957 name = "sminloc";
1958 else
1959 name = "mminloc";
1960
1961 resolve_mask_arg (mask);
1962 }
1963 else
1964 name = "minloc";
1965
1966 if (dim)
1967 {
1968 if (array->ts.type != BT_CHARACTER || f->rank != 0)
1969 d_num = 1;
1970 else
1971 d_num = 2;
1972 }
1973 else
1974 d_num = 0;
1975
1976 f->value.function.name
1977 = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
1978 gfc_type_letter (array->ts.type), array->ts.kind);
1979
1980 if (fkind != f->ts.kind)
1981 {
1982 gfc_typespec ts;
1983 gfc_clear_ts (&ts);
1984
1985 ts.type = BT_INTEGER;
1986 ts.kind = fkind;
1987 gfc_convert_type_warn (f, &ts, 2, 0);
1988 }
1989 }
1990
1991
1992 void
1993 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
1994 gfc_expr *mask)
1995 {
1996 const char *name;
1997 int i, j, idim;
1998
1999 f->ts = array->ts;
2000
2001 if (dim != NULL)
2002 {
2003 f->rank = array->rank - 1;
2004 gfc_resolve_dim_arg (dim);
2005
2006 if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
2007 {
2008 idim = (int) mpz_get_si (dim->value.integer);
2009 f->shape = gfc_get_shape (f->rank);
2010 for (i = 0, j = 0; i < f->rank; i++, j++)
2011 {
2012 if (i == (idim - 1))
2013 j++;
2014 mpz_init_set (f->shape[i], array->shape[j]);
2015 }
2016 }
2017 }
2018
2019 if (mask)
2020 {
2021 if (mask->rank == 0)
2022 name = "sminval";
2023 else
2024 name = "mminval";
2025
2026 resolve_mask_arg (mask);
2027 }
2028 else
2029 name = "minval";
2030
2031 if (array->ts.type != BT_CHARACTER)
2032 f->value.function.name
2033 = gfc_get_string (PREFIX ("%s_%c%d"), name,
2034 gfc_type_letter (array->ts.type), array->ts.kind);
2035 else
2036 f->value.function.name
2037 = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
2038 gfc_type_letter (array->ts.type), array->ts.kind);
2039 }
2040
2041
2042 void
2043 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2044 {
2045 f->ts.type = a->ts.type;
2046 if (p != NULL)
2047 f->ts.kind = gfc_kind_max (a,p);
2048 else
2049 f->ts.kind = a->ts.kind;
2050
2051 if (p != NULL && a->ts.kind != p->ts.kind)
2052 {
2053 if (a->ts.kind == gfc_kind_max (a,p))
2054 gfc_convert_type (p, &a->ts, 2);
2055 else
2056 gfc_convert_type (a, &p->ts, 2);
2057 }
2058
2059 f->value.function.name
2060 = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind);
2061 }
2062
2063
2064 void
2065 gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2066 {
2067 f->ts.type = a->ts.type;
2068 if (p != NULL)
2069 f->ts.kind = gfc_kind_max (a,p);
2070 else
2071 f->ts.kind = a->ts.kind;
2072
2073 if (p != NULL && a->ts.kind != p->ts.kind)
2074 {
2075 if (a->ts.kind == gfc_kind_max (a,p))
2076 gfc_convert_type (p, &a->ts, 2);
2077 else
2078 gfc_convert_type (a, &p->ts, 2);
2079 }
2080
2081 f->value.function.name
2082 = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type),
2083 f->ts.kind);
2084 }
2085
2086 void
2087 gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
2088 {
2089 if (p->ts.kind != a->ts.kind)
2090 gfc_convert_type (p, &a->ts, 2);
2091
2092 f->ts = a->ts;
2093 f->value.function.name
2094 = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
2095 a->ts.kind);
2096 }
2097
2098 void
2099 gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2100 {
2101 f->ts.type = BT_INTEGER;
2102 f->ts.kind = (kind == NULL)
2103 ? gfc_default_integer_kind : mpz_get_si (kind->value.integer);
2104 f->value.function.name
2105 = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind);
2106 }
2107
2108
2109 void
2110 gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2111 {
2112 resolve_transformational ("norm2", f, array, dim, NULL);
2113 }
2114
2115
2116 void
2117 gfc_resolve_not (gfc_expr *f, gfc_expr *i)
2118 {
2119 f->ts = i->ts;
2120 f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind);
2121 }
2122
2123
2124 void
2125 gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j)
2126 {
2127 f->ts.type = i->ts.type;
2128 f->ts.kind = gfc_kind_max (i, j);
2129
2130 if (i->ts.kind != j->ts.kind)
2131 {
2132 if (i->ts.kind == gfc_kind_max (i, j))
2133 gfc_convert_type (j, &i->ts, 2);
2134 else
2135 gfc_convert_type (i, &j->ts, 2);
2136 }
2137
2138 f->value.function.name
2139 = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
2140 }
2141
2142
2143 void
2144 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
2145 gfc_expr *vector ATTRIBUTE_UNUSED)
2146 {
2147 if (array->ts.type == BT_CHARACTER && array->ref)
2148 gfc_resolve_substring_charlen (array);
2149
2150 f->ts = array->ts;
2151 f->rank = 1;
2152
2153 resolve_mask_arg (mask);
2154
2155 if (mask->rank != 0)
2156 {
2157 if (array->ts.type == BT_CHARACTER)
2158 f->value.function.name
2159 = array->ts.kind == 1 ? PREFIX ("pack_char")
2160 : gfc_get_string
2161 (PREFIX ("pack_char%d"),
2162 array->ts.kind);
2163 else
2164 f->value.function.name = PREFIX ("pack");
2165 }
2166 else
2167 {
2168 if (array->ts.type == BT_CHARACTER)
2169 f->value.function.name
2170 = array->ts.kind == 1 ? PREFIX ("pack_s_char")
2171 : gfc_get_string
2172 (PREFIX ("pack_s_char%d"),
2173 array->ts.kind);
2174 else
2175 f->value.function.name = PREFIX ("pack_s");
2176 }
2177 }
2178
2179
2180 void
2181 gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
2182 {
2183 resolve_transformational ("parity", f, array, dim, NULL);
2184 }
2185
2186
2187 void
2188 gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2189 gfc_expr *mask)
2190 {
2191 resolve_transformational ("product", f, array, dim, mask);
2192 }
2193
2194
2195 void
2196 gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
2197 {
2198 f->ts.type = BT_INTEGER;
2199 f->ts.kind = gfc_default_integer_kind;
2200 f->value.function.name = gfc_get_string ("__rank");
2201 }
2202
2203
2204 void
2205 gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
2206 {
2207 f->ts.type = BT_REAL;
2208
2209 if (kind != NULL)
2210 f->ts.kind = mpz_get_si (kind->value.integer);
2211 else
2212 f->ts.kind = (a->ts.type == BT_COMPLEX)
2213 ? a->ts.kind : gfc_default_real_kind;
2214
2215 f->value.function.name
2216 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2217 gfc_type_letter (a->ts.type), a->ts.kind);
2218 }
2219
2220
2221 void
2222 gfc_resolve_realpart (gfc_expr *f, gfc_expr *a)
2223 {
2224 f->ts.type = BT_REAL;
2225 f->ts.kind = a->ts.kind;
2226 f->value.function.name
2227 = gfc_get_string ("__real_%d_%c%d", f->ts.kind,
2228 gfc_type_letter (a->ts.type), a->ts.kind);
2229 }
2230
2231
2232 void
2233 gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2234 gfc_expr *p2 ATTRIBUTE_UNUSED)
2235 {
2236 f->ts.type = BT_INTEGER;
2237 f->ts.kind = gfc_default_integer_kind;
2238 f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind);
2239 }
2240
2241
2242 void
2243 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
2244 gfc_expr *ncopies)
2245 {
2246 int len;
2247 gfc_expr *tmp;
2248 f->ts.type = BT_CHARACTER;
2249 f->ts.kind = string->ts.kind;
2250 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
2251
2252 /* If possible, generate a character length. */
2253 if (f->ts.u.cl == NULL)
2254 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2255
2256 tmp = NULL;
2257 if (string->expr_type == EXPR_CONSTANT)
2258 {
2259 len = string->value.character.length;
2260 tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
2261 }
2262 else if (string->ts.u.cl && string->ts.u.cl->length)
2263 {
2264 tmp = gfc_copy_expr (string->ts.u.cl->length);
2265 }
2266
2267 if (tmp)
2268 f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
2269 }
2270
2271
2272 void
2273 gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
2274 gfc_expr *pad ATTRIBUTE_UNUSED,
2275 gfc_expr *order ATTRIBUTE_UNUSED)
2276 {
2277 mpz_t rank;
2278 int kind;
2279 int i;
2280
2281 if (source->ts.type == BT_CHARACTER && source->ref)
2282 gfc_resolve_substring_charlen (source);
2283
2284 f->ts = source->ts;
2285
2286 gfc_array_size (shape, &rank);
2287 f->rank = mpz_get_si (rank);
2288 mpz_clear (rank);
2289 switch (source->ts.type)
2290 {
2291 case BT_COMPLEX:
2292 case BT_REAL:
2293 case BT_INTEGER:
2294 case BT_LOGICAL:
2295 case BT_CHARACTER:
2296 kind = source->ts.kind;
2297 break;
2298
2299 default:
2300 kind = 0;
2301 break;
2302 }
2303
2304 switch (kind)
2305 {
2306 case 4:
2307 case 8:
2308 case 10:
2309 case 16:
2310 if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL)
2311 f->value.function.name
2312 = gfc_get_string (PREFIX ("reshape_%c%d"),
2313 gfc_type_letter (source->ts.type),
2314 source->ts.kind);
2315 else if (source->ts.type == BT_CHARACTER)
2316 f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"),
2317 kind);
2318 else
2319 f->value.function.name
2320 = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind);
2321 break;
2322
2323 default:
2324 f->value.function.name = (source->ts.type == BT_CHARACTER
2325 ? PREFIX ("reshape_char") : PREFIX ("reshape"));
2326 break;
2327 }
2328
2329 if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
2330 {
2331 gfc_constructor *c;
2332 f->shape = gfc_get_shape (f->rank);
2333 c = gfc_constructor_first (shape->value.constructor);
2334 for (i = 0; i < f->rank; i++)
2335 {
2336 mpz_init_set (f->shape[i], c->expr->value.integer);
2337 c = gfc_constructor_next (c);
2338 }
2339 }
2340
2341 /* Force-convert both SHAPE and ORDER to index_kind so that we don't need
2342 so many runtime variations. */
2343 if (shape->ts.kind != gfc_index_integer_kind)
2344 {
2345 gfc_typespec ts = shape->ts;
2346 ts.kind = gfc_index_integer_kind;
2347 gfc_convert_type_warn (shape, &ts, 2, 0);
2348 }
2349 if (order && order->ts.kind != gfc_index_integer_kind)
2350 gfc_convert_type_warn (order, &shape->ts, 2, 0);
2351 }
2352
2353
2354 void
2355 gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x)
2356 {
2357 f->ts = x->ts;
2358 f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind);
2359 }
2360
2361 void
2362 gfc_resolve_fe_runtime_error (gfc_code *c)
2363 {
2364 const char *name;
2365 gfc_actual_arglist *a;
2366
2367 name = gfc_get_string (PREFIX ("runtime_error"));
2368
2369 for (a = c->ext.actual->next; a; a = a->next)
2370 a->name = "%VAL";
2371
2372 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
2373 }
2374
2375 void
2376 gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED)
2377 {
2378 f->ts = x->ts;
2379 f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind);
2380 }
2381
2382
2383 void
2384 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
2385 gfc_expr *set ATTRIBUTE_UNUSED,
2386 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
2387 {
2388 f->ts.type = BT_INTEGER;
2389 if (kind)
2390 f->ts.kind = mpz_get_si (kind->value.integer);
2391 else
2392 f->ts.kind = gfc_default_integer_kind;
2393 f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
2394 }
2395
2396
2397 void
2398 gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0)
2399 {
2400 t1->ts = t0->ts;
2401 t1->value.function.name = gfc_get_string (PREFIX ("secnds"));
2402 }
2403
2404
2405 void
2406 gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x,
2407 gfc_expr *i ATTRIBUTE_UNUSED)
2408 {
2409 f->ts = x->ts;
2410 f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind);
2411 }
2412
2413
2414 void
2415 gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind)
2416 {
2417 f->ts.type = BT_INTEGER;
2418
2419 if (kind)
2420 f->ts.kind = mpz_get_si (kind->value.integer);
2421 else
2422 f->ts.kind = gfc_default_integer_kind;
2423
2424 f->rank = 1;
2425 if (array->rank != -1)
2426 {
2427 f->shape = gfc_get_shape (1);
2428 mpz_init_set_ui (f->shape[0], array->rank);
2429 }
2430
2431 f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
2432 }
2433
2434
2435 void
2436 gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
2437 {
2438 f->ts = i->ts;
2439 if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
2440 f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
2441 else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
2442 f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
2443 else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
2444 f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
2445 else
2446 gcc_unreachable ();
2447 }
2448
2449
2450 void
2451 gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
2452 {
2453 f->ts = a->ts;
2454 f->value.function.name
2455 = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind);
2456 }
2457
2458
2459 void
2460 gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler)
2461 {
2462 f->ts.type = BT_INTEGER;
2463 f->ts.kind = gfc_c_int_kind;
2464
2465 /* handler can be either BT_INTEGER or BT_PROCEDURE */
2466 if (handler->ts.type == BT_INTEGER)
2467 {
2468 if (handler->ts.kind != gfc_c_int_kind)
2469 gfc_convert_type (handler, &f->ts, 2);
2470 f->value.function.name = gfc_get_string (PREFIX ("signal_func_int"));
2471 }
2472 else
2473 f->value.function.name = gfc_get_string (PREFIX ("signal_func"));
2474
2475 if (number->ts.kind != gfc_c_int_kind)
2476 gfc_convert_type (number, &f->ts, 2);
2477 }
2478
2479
2480 void
2481 gfc_resolve_sin (gfc_expr *f, gfc_expr *x)
2482 {
2483 f->ts = x->ts;
2484 f->value.function.name
2485 = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2486 }
2487
2488
2489 void
2490 gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
2491 {
2492 f->ts = x->ts;
2493 f->value.function.name
2494 = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2495 }
2496
2497
2498 void
2499 gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2500 gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
2501 {
2502 f->ts.type = BT_INTEGER;
2503 if (kind)
2504 f->ts.kind = mpz_get_si (kind->value.integer);
2505 else
2506 f->ts.kind = gfc_default_integer_kind;
2507 }
2508
2509
2510 void
2511 gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2512 gfc_expr *dim ATTRIBUTE_UNUSED)
2513 {
2514 f->ts.type = BT_INTEGER;
2515 f->ts.kind = gfc_index_integer_kind;
2516 }
2517
2518
2519 void
2520 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
2521 {
2522 f->ts = x->ts;
2523 f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind);
2524 }
2525
2526
2527 void
2528 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
2529 gfc_expr *ncopies)
2530 {
2531 if (source->ts.type == BT_CHARACTER && source->ref)
2532 gfc_resolve_substring_charlen (source);
2533
2534 if (source->ts.type == BT_CHARACTER)
2535 check_charlen_present (source);
2536
2537 f->ts = source->ts;
2538 f->rank = source->rank + 1;
2539 if (source->rank == 0)
2540 {
2541 if (source->ts.type == BT_CHARACTER)
2542 f->value.function.name
2543 = source->ts.kind == 1 ? PREFIX ("spread_char_scalar")
2544 : gfc_get_string
2545 (PREFIX ("spread_char%d_scalar"),
2546 source->ts.kind);
2547 else
2548 f->value.function.name = PREFIX ("spread_scalar");
2549 }
2550 else
2551 {
2552 if (source->ts.type == BT_CHARACTER)
2553 f->value.function.name
2554 = source->ts.kind == 1 ? PREFIX ("spread_char")
2555 : gfc_get_string
2556 (PREFIX ("spread_char%d"),
2557 source->ts.kind);
2558 else
2559 f->value.function.name = PREFIX ("spread");
2560 }
2561
2562 if (dim && gfc_is_constant_expr (dim)
2563 && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0])
2564 {
2565 int i, idim;
2566 idim = mpz_get_ui (dim->value.integer);
2567 f->shape = gfc_get_shape (f->rank);
2568 for (i = 0; i < (idim - 1); i++)
2569 mpz_init_set (f->shape[i], source->shape[i]);
2570
2571 mpz_init_set (f->shape[idim - 1], ncopies->value.integer);
2572
2573 for (i = idim; i < f->rank ; i++)
2574 mpz_init_set (f->shape[i], source->shape[i-1]);
2575 }
2576
2577
2578 gfc_resolve_dim_arg (dim);
2579 gfc_resolve_index (ncopies, 1);
2580 }
2581
2582
2583 void
2584 gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x)
2585 {
2586 f->ts = x->ts;
2587 f->value.function.name
2588 = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2589 }
2590
2591
2592 /* Resolve the g77 compatibility function STAT AND FSTAT. */
2593
2594 void
2595 gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2596 gfc_expr *a ATTRIBUTE_UNUSED)
2597 {
2598 f->ts.type = BT_INTEGER;
2599 f->ts.kind = gfc_default_integer_kind;
2600 f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind);
2601 }
2602
2603
2604 void
2605 gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED,
2606 gfc_expr *a ATTRIBUTE_UNUSED)
2607 {
2608 f->ts.type = BT_INTEGER;
2609 f->ts.kind = gfc_default_integer_kind;
2610 f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind);
2611 }
2612
2613
2614 void
2615 gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED)
2616 {
2617 f->ts.type = BT_INTEGER;
2618 f->ts.kind = gfc_default_integer_kind;
2619 if (n->ts.kind != f->ts.kind)
2620 gfc_convert_type (n, &f->ts, 2);
2621
2622 f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind);
2623 }
2624
2625
2626 void
2627 gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2628 {
2629 gfc_typespec ts;
2630 gfc_clear_ts (&ts);
2631
2632 f->ts.type = BT_INTEGER;
2633 f->ts.kind = gfc_c_int_kind;
2634 if (u->ts.kind != gfc_c_int_kind)
2635 {
2636 ts.type = BT_INTEGER;
2637 ts.kind = gfc_c_int_kind;
2638 ts.u.derived = NULL;
2639 ts.u.cl = NULL;
2640 gfc_convert_type (u, &ts, 2);
2641 }
2642
2643 f->value.function.name = gfc_get_string (PREFIX ("fgetc"));
2644 }
2645
2646
2647 void
2648 gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2649 {
2650 f->ts.type = BT_INTEGER;
2651 f->ts.kind = gfc_c_int_kind;
2652 f->value.function.name = gfc_get_string (PREFIX ("fget"));
2653 }
2654
2655
2656 void
2657 gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED)
2658 {
2659 gfc_typespec ts;
2660 gfc_clear_ts (&ts);
2661
2662 f->ts.type = BT_INTEGER;
2663 f->ts.kind = gfc_c_int_kind;
2664 if (u->ts.kind != gfc_c_int_kind)
2665 {
2666 ts.type = BT_INTEGER;
2667 ts.kind = gfc_c_int_kind;
2668 ts.u.derived = NULL;
2669 ts.u.cl = NULL;
2670 gfc_convert_type (u, &ts, 2);
2671 }
2672
2673 f->value.function.name = gfc_get_string (PREFIX ("fputc"));
2674 }
2675
2676
2677 void
2678 gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED)
2679 {
2680 f->ts.type = BT_INTEGER;
2681 f->ts.kind = gfc_c_int_kind;
2682 f->value.function.name = gfc_get_string (PREFIX ("fput"));
2683 }
2684
2685
2686 void
2687 gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
2688 {
2689 gfc_typespec ts;
2690 gfc_clear_ts (&ts);
2691
2692 f->ts.type = BT_INTEGER;
2693 f->ts.kind = gfc_intio_kind;
2694 if (u->ts.kind != gfc_c_int_kind)
2695 {
2696 ts.type = BT_INTEGER;
2697 ts.kind = gfc_c_int_kind;
2698 ts.u.derived = NULL;
2699 ts.u.cl = NULL;
2700 gfc_convert_type (u, &ts, 2);
2701 }
2702
2703 f->value.function.name = gfc_get_string (PREFIX ("ftell"));
2704 }
2705
2706
2707 void
2708 gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
2709 gfc_expr *kind)
2710 {
2711 f->ts.type = BT_INTEGER;
2712 if (kind)
2713 f->ts.kind = mpz_get_si (kind->value.integer);
2714 else
2715 f->ts.kind = gfc_default_integer_kind;
2716 }
2717
2718
2719 void
2720 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
2721 {
2722 resolve_transformational ("sum", f, array, dim, mask);
2723 }
2724
2725
2726 void
2727 gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
2728 gfc_expr *p2 ATTRIBUTE_UNUSED)
2729 {
2730 f->ts.type = BT_INTEGER;
2731 f->ts.kind = gfc_default_integer_kind;
2732 f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind);
2733 }
2734
2735
2736 /* Resolve the g77 compatibility function SYSTEM. */
2737
2738 void
2739 gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
2740 {
2741 f->ts.type = BT_INTEGER;
2742 f->ts.kind = 4;
2743 f->value.function.name = gfc_get_string (PREFIX ("system"));
2744 }
2745
2746
2747 void
2748 gfc_resolve_tan (gfc_expr *f, gfc_expr *x)
2749 {
2750 f->ts = x->ts;
2751 f->value.function.name
2752 = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2753 }
2754
2755
2756 void
2757 gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
2758 {
2759 f->ts = x->ts;
2760 f->value.function.name
2761 = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
2762 }
2763
2764
2765 /* Build an expression for converting degrees to radians. */
2766
2767 static gfc_expr *
2768 get_radians (gfc_expr *deg)
2769 {
2770 gfc_expr *result, *factor;
2771 gfc_actual_arglist *mod_args;
2772
2773 gcc_assert (deg->ts.type == BT_REAL);
2774
2775 /* Set deg = deg % 360 to avoid offsets from large angles. */
2776 factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
2777 mpfr_set_d (factor->value.real, 360.0, GFC_RND_MODE);
2778
2779 mod_args = gfc_get_actual_arglist ();
2780 mod_args->expr = deg;
2781 mod_args->next = gfc_get_actual_arglist ();
2782 mod_args->next->expr = factor;
2783
2784 result = gfc_get_expr ();
2785 result->ts = deg->ts;
2786 result->where = deg->where;
2787 result->expr_type = EXPR_FUNCTION;
2788 result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
2789 result->value.function.actual = mod_args;
2790
2791 /* Set factor = pi / 180. */
2792 factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
2793 mpfr_const_pi (factor->value.real, GFC_RND_MODE);
2794 mpfr_div_ui (factor->value.real, factor->value.real, 180, GFC_RND_MODE);
2795
2796 /* Result is rad = (deg % 360) * (pi / 180). */
2797 result = gfc_multiply (result, factor);
2798 return result;
2799 }
2800
2801
2802 /* Build an expression for converting radians to degrees. */
2803
2804 static gfc_expr *
2805 get_degrees (gfc_expr *rad)
2806 {
2807 gfc_expr *result, *factor;
2808 gfc_actual_arglist *mod_args;
2809 mpfr_t tmp;
2810
2811 gcc_assert (rad->ts.type == BT_REAL);
2812
2813 /* Set rad = rad % 2pi to avoid offsets from large angles. */
2814 factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
2815 mpfr_const_pi (factor->value.real, GFC_RND_MODE);
2816 mpfr_mul_ui (factor->value.real, factor->value.real, 2, GFC_RND_MODE);
2817
2818 mod_args = gfc_get_actual_arglist ();
2819 mod_args->expr = rad;
2820 mod_args->next = gfc_get_actual_arglist ();
2821 mod_args->next->expr = factor;
2822
2823 result = gfc_get_expr ();
2824 result->ts = rad->ts;
2825 result->where = rad->where;
2826 result->expr_type = EXPR_FUNCTION;
2827 result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
2828 result->value.function.actual = mod_args;
2829
2830 /* Set factor = 180 / pi. */
2831 factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
2832 mpfr_set_ui (factor->value.real, 180, GFC_RND_MODE);
2833 mpfr_init (tmp);
2834 mpfr_const_pi (tmp, GFC_RND_MODE);
2835 mpfr_div (factor->value.real, factor->value.real, tmp, GFC_RND_MODE);
2836 mpfr_clear (tmp);
2837
2838 /* Result is deg = (rad % 2pi) * (180 / pi). */
2839 result = gfc_multiply (result, factor);
2840 return result;
2841 }
2842
2843
2844 /* Resolve a call to a trig function. */
2845
2846 static void
2847 resolve_trig_call (gfc_expr *f, gfc_expr *x)
2848 {
2849 switch (f->value.function.isym->id)
2850 {
2851 case GFC_ISYM_ACOS:
2852 return gfc_resolve_acos (f, x);
2853 case GFC_ISYM_ASIN:
2854 return gfc_resolve_asin (f, x);
2855 case GFC_ISYM_ATAN:
2856 return gfc_resolve_atan (f, x);
2857 case GFC_ISYM_ATAN2:
2858 /* NB. arg3 is unused for atan2 */
2859 return gfc_resolve_atan2 (f, x, NULL);
2860 case GFC_ISYM_COS:
2861 return gfc_resolve_cos (f, x);
2862 case GFC_ISYM_COTAN:
2863 return gfc_resolve_cotan (f, x);
2864 case GFC_ISYM_SIN:
2865 return gfc_resolve_sin (f, x);
2866 case GFC_ISYM_TAN:
2867 return gfc_resolve_tan (f, x);
2868 default:
2869 gcc_unreachable ();
2870 }
2871 }
2872
2873 /* Resolve degree trig function as trigd (x) = trig (radians (x)). */
2874
2875 void
2876 gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
2877 {
2878 if (is_trig_resolved (f))
2879 return;
2880
2881 x = get_radians (x);
2882 f->value.function.actual->expr = x;
2883
2884 resolve_trig_call (f, x);
2885 }
2886
2887
2888 /* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
2889
2890 void
2891 gfc_resolve_atrigd (gfc_expr *f, gfc_expr *x)
2892 {
2893 gfc_expr *result, *fcopy;
2894
2895 if (is_trig_resolved (f))
2896 return;
2897
2898 resolve_trig_call (f, x);
2899
2900 fcopy = copy_replace_function_shallow (f);
2901 result = get_degrees (fcopy);
2902 gfc_replace_expr (f, result);
2903 }
2904
2905
2906 /* Resolve atan2d(x) = degrees(atan2(x)). */
2907
2908 void
2909 gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
2910 {
2911 /* Note that we lose the second arg here - that's okay because it is
2912 unused in gfc_resolve_atan2 anyway. */
2913 gfc_resolve_atrigd (f, x);
2914 }
2915
2916
2917 /* Resolve failed_images (team, kind). */
2918
2919 void
2920 gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2921 gfc_expr *kind)
2922 {
2923 static char failed_images[] = "_gfortran_caf_failed_images";
2924 f->rank = 1;
2925 f->ts.type = BT_INTEGER;
2926 if (kind == NULL)
2927 f->ts.kind = gfc_default_integer_kind;
2928 else
2929 gfc_extract_int (kind, &f->ts.kind);
2930 f->value.function.name = failed_images;
2931 }
2932
2933
2934 /* Resolve image_status (image, team). */
2935
2936 void
2937 gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
2938 gfc_expr *team ATTRIBUTE_UNUSED)
2939 {
2940 static char image_status[] = "_gfortran_caf_image_status";
2941 f->ts.type = BT_INTEGER;
2942 f->ts.kind = gfc_default_integer_kind;
2943 f->value.function.name = image_status;
2944 }
2945
2946
2947 /* Resolve image_index (...). */
2948
2949 void
2950 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
2951 gfc_expr *sub ATTRIBUTE_UNUSED)
2952 {
2953 static char image_index[] = "__image_index";
2954 f->ts.type = BT_INTEGER;
2955 f->ts.kind = gfc_default_integer_kind;
2956 f->value.function.name = image_index;
2957 }
2958
2959
2960 /* Resolve stopped_images (team, kind). */
2961
2962 void
2963 gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
2964 gfc_expr *kind)
2965 {
2966 static char stopped_images[] = "_gfortran_caf_stopped_images";
2967 f->rank = 1;
2968 f->ts.type = BT_INTEGER;
2969 if (kind == NULL)
2970 f->ts.kind = gfc_default_integer_kind;
2971 else
2972 gfc_extract_int (kind, &f->ts.kind);
2973 f->value.function.name = stopped_images;
2974 }
2975
2976
2977 void
2978 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
2979 gfc_expr *distance ATTRIBUTE_UNUSED)
2980 {
2981 static char this_image[] = "__this_image";
2982 if (array && gfc_is_coarray (array))
2983 resolve_bound (f, array, dim, NULL, "__this_image", true);
2984 else
2985 {
2986 f->ts.type = BT_INTEGER;
2987 f->ts.kind = gfc_default_integer_kind;
2988 f->value.function.name = this_image;
2989 }
2990 }
2991
2992
2993 void
2994 gfc_resolve_time (gfc_expr *f)
2995 {
2996 f->ts.type = BT_INTEGER;
2997 f->ts.kind = 4;
2998 f->value.function.name = gfc_get_string (PREFIX ("time_func"));
2999 }
3000
3001
3002 void
3003 gfc_resolve_time8 (gfc_expr *f)
3004 {
3005 f->ts.type = BT_INTEGER;
3006 f->ts.kind = 8;
3007 f->value.function.name = gfc_get_string (PREFIX ("time8_func"));
3008 }
3009
3010
3011 void
3012 gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
3013 gfc_expr *mold, gfc_expr *size)
3014 {
3015 /* TODO: Make this do something meaningful. */
3016 static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
3017
3018 if (mold->ts.type == BT_CHARACTER
3019 && !mold->ts.u.cl->length
3020 && gfc_is_constant_expr (mold))
3021 {
3022 int len;
3023 if (mold->expr_type == EXPR_CONSTANT)
3024 {
3025 len = mold->value.character.length;
3026 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
3027 NULL, len);
3028 }
3029 else
3030 {
3031 gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
3032 len = c->expr->value.character.length;
3033 mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
3034 NULL, len);
3035 }
3036 }
3037
3038 f->ts = mold->ts;
3039
3040 if (size == NULL && mold->rank == 0)
3041 {
3042 f->rank = 0;
3043 f->value.function.name = transfer0;
3044 }
3045 else
3046 {
3047 f->rank = 1;
3048 f->value.function.name = transfer1;
3049 if (size && gfc_is_constant_expr (size))
3050 {
3051 f->shape = gfc_get_shape (1);
3052 mpz_init_set (f->shape[0], size->value.integer);
3053 }
3054 }
3055 }
3056
3057
3058 void
3059 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
3060 {
3061
3062 if (matrix->ts.type == BT_CHARACTER && matrix->ref)
3063 gfc_resolve_substring_charlen (matrix);
3064
3065 f->ts = matrix->ts;
3066 f->rank = 2;
3067 if (matrix->shape)
3068 {
3069 f->shape = gfc_get_shape (2);
3070 mpz_init_set (f->shape[0], matrix->shape[1]);
3071 mpz_init_set (f->shape[1], matrix->shape[0]);
3072 }
3073
3074 switch (matrix->ts.kind)
3075 {
3076 case 4:
3077 case 8:
3078 case 10:
3079 case 16:
3080 switch (matrix->ts.type)
3081 {
3082 case BT_REAL:
3083 case BT_COMPLEX:
3084 f->value.function.name
3085 = gfc_get_string (PREFIX ("transpose_%c%d"),
3086 gfc_type_letter (matrix->ts.type),
3087 matrix->ts.kind);
3088 break;
3089
3090 case BT_INTEGER:
3091 case BT_LOGICAL:
3092 /* Use the integer routines for real and logical cases. This
3093 assumes they all have the same alignment requirements. */
3094 f->value.function.name
3095 = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind);
3096 break;
3097
3098 default:
3099 if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4)
3100 f->value.function.name = PREFIX ("transpose_char4");
3101 else
3102 f->value.function.name = PREFIX ("transpose");
3103 break;
3104 }
3105 break;
3106
3107 default:
3108 f->value.function.name = (matrix->ts.type == BT_CHARACTER
3109 ? PREFIX ("transpose_char")
3110 : PREFIX ("transpose"));
3111 break;
3112 }
3113 }
3114
3115
3116 void
3117 gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
3118 {
3119 f->ts.type = BT_CHARACTER;
3120 f->ts.kind = string->ts.kind;
3121 f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
3122 }
3123
3124
3125 void
3126 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3127 {
3128 resolve_bound (f, array, dim, kind, "__ubound", false);
3129 }
3130
3131
3132 void
3133 gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
3134 {
3135 resolve_bound (f, array, dim, kind, "__ucobound", true);
3136 }
3137
3138
3139 /* Resolve the g77 compatibility function UMASK. */
3140
3141 void
3142 gfc_resolve_umask (gfc_expr *f, gfc_expr *n)
3143 {
3144 f->ts.type = BT_INTEGER;
3145 f->ts.kind = n->ts.kind;
3146 f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind);
3147 }
3148
3149
3150 /* Resolve the g77 compatibility function UNLINK. */
3151
3152 void
3153 gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
3154 {
3155 f->ts.type = BT_INTEGER;
3156 f->ts.kind = 4;
3157 f->value.function.name = gfc_get_string (PREFIX ("unlink"));
3158 }
3159
3160
3161 void
3162 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
3163 {
3164 gfc_typespec ts;
3165 gfc_clear_ts (&ts);
3166
3167 f->ts.type = BT_CHARACTER;
3168 f->ts.kind = gfc_default_character_kind;
3169
3170 if (unit->ts.kind != gfc_c_int_kind)
3171 {
3172 ts.type = BT_INTEGER;
3173 ts.kind = gfc_c_int_kind;
3174 ts.u.derived = NULL;
3175 ts.u.cl = NULL;
3176 gfc_convert_type (unit, &ts, 2);
3177 }
3178
3179 f->value.function.name = gfc_get_string (PREFIX ("ttynam"));
3180 }
3181
3182
3183 void
3184 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
3185 gfc_expr *field ATTRIBUTE_UNUSED)
3186 {
3187 if (vector->ts.type == BT_CHARACTER && vector->ref)
3188 gfc_resolve_substring_charlen (vector);
3189
3190 f->ts = vector->ts;
3191 f->rank = mask->rank;
3192 resolve_mask_arg (mask);
3193
3194 if (vector->ts.type == BT_CHARACTER)
3195 {
3196 if (vector->ts.kind == 1)
3197 f->value.function.name
3198 = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0);
3199 else
3200 f->value.function.name
3201 = gfc_get_string (PREFIX ("unpack%d_char%d"),
3202 field->rank > 0 ? 1 : 0, vector->ts.kind);
3203 }
3204 else
3205 f->value.function.name
3206 = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0);
3207 }
3208
3209
3210 void
3211 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
3212 gfc_expr *set ATTRIBUTE_UNUSED,
3213 gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
3214 {
3215 f->ts.type = BT_INTEGER;
3216 if (kind)
3217 f->ts.kind = mpz_get_si (kind->value.integer);
3218 else
3219 f->ts.kind = gfc_default_integer_kind;
3220 f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
3221 }
3222
3223
3224 void
3225 gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
3226 {
3227 f->ts.type = i->ts.type;
3228 f->ts.kind = gfc_kind_max (i, j);
3229
3230 if (i->ts.kind != j->ts.kind)
3231 {
3232 if (i->ts.kind == gfc_kind_max (i, j))
3233 gfc_convert_type (j, &i->ts, 2);
3234 else
3235 gfc_convert_type (i, &j->ts, 2);
3236 }
3237
3238 f->value.function.name
3239 = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), f->ts.kind);
3240 }
3241
3242
3243 /* Intrinsic subroutine resolution. */
3244
3245 void
3246 gfc_resolve_alarm_sub (gfc_code *c)
3247 {
3248 const char *name;
3249 gfc_expr *seconds, *handler;
3250 gfc_typespec ts;
3251 gfc_clear_ts (&ts);
3252
3253 seconds = c->ext.actual->expr;
3254 handler = c->ext.actual->next->expr;
3255 ts.type = BT_INTEGER;
3256 ts.kind = gfc_c_int_kind;
3257
3258 /* handler can be either BT_INTEGER or BT_PROCEDURE.
3259 In all cases, the status argument is of default integer kind
3260 (enforced in check.c) so that the function suffix is fixed. */
3261 if (handler->ts.type == BT_INTEGER)
3262 {
3263 if (handler->ts.kind != gfc_c_int_kind)
3264 gfc_convert_type (handler, &ts, 2);
3265 name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"),
3266 gfc_default_integer_kind);
3267 }
3268 else
3269 name = gfc_get_string (PREFIX ("alarm_sub_i%d"),
3270 gfc_default_integer_kind);
3271
3272 if (seconds->ts.kind != gfc_c_int_kind)
3273 gfc_convert_type (seconds, &ts, 2);
3274
3275 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3276 }
3277
3278 void
3279 gfc_resolve_cpu_time (gfc_code *c)
3280 {
3281 const char *name;
3282 name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
3283 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3284 }
3285
3286
3287 /* Create a formal arglist based on an actual one and set the INTENTs given. */
3288
3289 static gfc_formal_arglist*
3290 create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
3291 {
3292 gfc_formal_arglist* head;
3293 gfc_formal_arglist* tail;
3294 int i;
3295
3296 if (!actual)
3297 return NULL;
3298
3299 head = tail = gfc_get_formal_arglist ();
3300 for (i = 0; actual; actual = actual->next, tail = tail->next, ++i)
3301 {
3302 gfc_symbol* sym;
3303
3304 sym = gfc_new_symbol ("dummyarg", NULL);
3305 sym->ts = actual->expr->ts;
3306
3307 sym->attr.intent = ints[i];
3308 tail->sym = sym;
3309
3310 if (actual->next)
3311 tail->next = gfc_get_formal_arglist ();
3312 }
3313
3314 return head;
3315 }
3316
3317
3318 void
3319 gfc_resolve_atomic_def (gfc_code *c)
3320 {
3321 const char *name = "atomic_define";
3322 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3323 }
3324
3325
3326 void
3327 gfc_resolve_atomic_ref (gfc_code *c)
3328 {
3329 const char *name = "atomic_ref";
3330 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3331 }
3332
3333 void
3334 gfc_resolve_event_query (gfc_code *c)
3335 {
3336 const char *name = "event_query";
3337 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3338 }
3339
3340 void
3341 gfc_resolve_mvbits (gfc_code *c)
3342 {
3343 static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
3344 INTENT_INOUT, INTENT_IN};
3345
3346 const char *name;
3347 gfc_typespec ts;
3348 gfc_clear_ts (&ts);
3349
3350 /* FROMPOS, LEN and TOPOS are restricted to small values. As such,
3351 they will be converted so that they fit into a C int. */
3352 ts.type = BT_INTEGER;
3353 ts.kind = gfc_c_int_kind;
3354 if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind)
3355 gfc_convert_type (c->ext.actual->next->expr, &ts, 2);
3356 if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind)
3357 gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2);
3358 if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind)
3359 gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2);
3360
3361 /* TO and FROM are guaranteed to have the same kind parameter. */
3362 name = gfc_get_string (PREFIX ("mvbits_i%d"),
3363 c->ext.actual->expr->ts.kind);
3364 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3365 /* Mark as elemental subroutine as this does not happen automatically. */
3366 c->resolved_sym->attr.elemental = 1;
3367
3368 /* Create a dummy formal arglist so the INTENTs are known later for purpose
3369 of creating temporaries. */
3370 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
3371 }
3372
3373
3374 void
3375 gfc_resolve_random_number (gfc_code *c)
3376 {
3377 const char *name;
3378 int kind;
3379
3380 kind = c->ext.actual->expr->ts.kind;
3381 if (c->ext.actual->expr->rank == 0)
3382 name = gfc_get_string (PREFIX ("random_r%d"), kind);
3383 else
3384 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
3385
3386 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3387 }
3388
3389
3390 void
3391 gfc_resolve_random_seed (gfc_code *c)
3392 {
3393 const char *name;
3394
3395 name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
3396 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3397 }
3398
3399
3400 void
3401 gfc_resolve_rename_sub (gfc_code *c)
3402 {
3403 const char *name;
3404 int kind;
3405
3406 if (c->ext.actual->next->next->expr != NULL)
3407 kind = c->ext.actual->next->next->expr->ts.kind;
3408 else
3409 kind = gfc_default_integer_kind;
3410
3411 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
3412 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3413 }
3414
3415
3416 void
3417 gfc_resolve_kill_sub (gfc_code *c)
3418 {
3419 const char *name;
3420 int kind;
3421
3422 if (c->ext.actual->next->next->expr != NULL)
3423 kind = c->ext.actual->next->next->expr->ts.kind;
3424 else
3425 kind = gfc_default_integer_kind;
3426
3427 name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
3428 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3429 }
3430
3431
3432 void
3433 gfc_resolve_link_sub (gfc_code *c)
3434 {
3435 const char *name;
3436 int kind;
3437
3438 if (c->ext.actual->next->next->expr != NULL)
3439 kind = c->ext.actual->next->next->expr->ts.kind;
3440 else
3441 kind = gfc_default_integer_kind;
3442
3443 name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
3444 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3445 }
3446
3447
3448 void
3449 gfc_resolve_symlnk_sub (gfc_code *c)
3450 {
3451 const char *name;
3452 int kind;
3453
3454 if (c->ext.actual->next->next->expr != NULL)
3455 kind = c->ext.actual->next->next->expr->ts.kind;
3456 else
3457 kind = gfc_default_integer_kind;
3458
3459 name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
3460 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3461 }
3462
3463
3464 /* G77 compatibility subroutines dtime() and etime(). */
3465
3466 void
3467 gfc_resolve_dtime_sub (gfc_code *c)
3468 {
3469 const char *name;
3470 name = gfc_get_string (PREFIX ("dtime_sub"));
3471 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3472 }
3473
3474 void
3475 gfc_resolve_etime_sub (gfc_code *c)
3476 {
3477 const char *name;
3478 name = gfc_get_string (PREFIX ("etime_sub"));
3479 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3480 }
3481
3482
3483 /* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */
3484
3485 void
3486 gfc_resolve_itime (gfc_code *c)
3487 {
3488 c->resolved_sym
3489 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
3490 gfc_default_integer_kind));
3491 }
3492
3493 void
3494 gfc_resolve_idate (gfc_code *c)
3495 {
3496 c->resolved_sym
3497 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
3498 gfc_default_integer_kind));
3499 }
3500
3501 void
3502 gfc_resolve_ltime (gfc_code *c)
3503 {
3504 c->resolved_sym
3505 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
3506 gfc_default_integer_kind));
3507 }
3508
3509 void
3510 gfc_resolve_gmtime (gfc_code *c)
3511 {
3512 c->resolved_sym
3513 = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
3514 gfc_default_integer_kind));
3515 }
3516
3517
3518 /* G77 compatibility subroutine second(). */
3519
3520 void
3521 gfc_resolve_second_sub (gfc_code *c)
3522 {
3523 const char *name;
3524 name = gfc_get_string (PREFIX ("second_sub"));
3525 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3526 }
3527
3528
3529 void
3530 gfc_resolve_sleep_sub (gfc_code *c)
3531 {
3532 const char *name;
3533 int kind;
3534
3535 if (c->ext.actual->expr != NULL)
3536 kind = c->ext.actual->expr->ts.kind;
3537 else
3538 kind = gfc_default_integer_kind;
3539
3540 name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
3541 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3542 }
3543
3544
3545 /* G77 compatibility function srand(). */
3546
3547 void
3548 gfc_resolve_srand (gfc_code *c)
3549 {
3550 const char *name;
3551 name = gfc_get_string (PREFIX ("srand"));
3552 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3553 }
3554
3555
3556 /* Resolve the getarg intrinsic subroutine. */
3557
3558 void
3559 gfc_resolve_getarg (gfc_code *c)
3560 {
3561 const char *name;
3562
3563 if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
3564 {
3565 gfc_typespec ts;
3566 gfc_clear_ts (&ts);
3567
3568 ts.type = BT_INTEGER;
3569 ts.kind = gfc_default_integer_kind;
3570
3571 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3572 }
3573
3574 name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
3575 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3576 }
3577
3578
3579 /* Resolve the getcwd intrinsic subroutine. */
3580
3581 void
3582 gfc_resolve_getcwd_sub (gfc_code *c)
3583 {
3584 const char *name;
3585 int kind;
3586
3587 if (c->ext.actual->next->expr != NULL)
3588 kind = c->ext.actual->next->expr->ts.kind;
3589 else
3590 kind = gfc_default_integer_kind;
3591
3592 name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
3593 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3594 }
3595
3596
3597 /* Resolve the get_command intrinsic subroutine. */
3598
3599 void
3600 gfc_resolve_get_command (gfc_code *c)
3601 {
3602 const char *name;
3603 int kind;
3604 kind = gfc_default_integer_kind;
3605 name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
3606 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3607 }
3608
3609
3610 /* Resolve the get_command_argument intrinsic subroutine. */
3611
3612 void
3613 gfc_resolve_get_command_argument (gfc_code *c)
3614 {
3615 const char *name;
3616 int kind;
3617 kind = gfc_default_integer_kind;
3618 name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
3619 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3620 }
3621
3622
3623 /* Resolve the get_environment_variable intrinsic subroutine. */
3624
3625 void
3626 gfc_resolve_get_environment_variable (gfc_code *code)
3627 {
3628 const char *name;
3629 int kind;
3630 kind = gfc_default_integer_kind;
3631 name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
3632 code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3633 }
3634
3635
3636 void
3637 gfc_resolve_signal_sub (gfc_code *c)
3638 {
3639 const char *name;
3640 gfc_expr *number, *handler, *status;
3641 gfc_typespec ts;
3642 gfc_clear_ts (&ts);
3643
3644 number = c->ext.actual->expr;
3645 handler = c->ext.actual->next->expr;
3646 status = c->ext.actual->next->next->expr;
3647 ts.type = BT_INTEGER;
3648 ts.kind = gfc_c_int_kind;
3649
3650 /* handler can be either BT_INTEGER or BT_PROCEDURE */
3651 if (handler->ts.type == BT_INTEGER)
3652 {
3653 if (handler->ts.kind != gfc_c_int_kind)
3654 gfc_convert_type (handler, &ts, 2);
3655 name = gfc_get_string (PREFIX ("signal_sub_int"));
3656 }
3657 else
3658 name = gfc_get_string (PREFIX ("signal_sub"));
3659
3660 if (number->ts.kind != gfc_c_int_kind)
3661 gfc_convert_type (number, &ts, 2);
3662 if (status != NULL && status->ts.kind != gfc_c_int_kind)
3663 gfc_convert_type (status, &ts, 2);
3664
3665 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3666 }
3667
3668
3669 /* Resolve the SYSTEM intrinsic subroutine. */
3670
3671 void
3672 gfc_resolve_system_sub (gfc_code *c)
3673 {
3674 const char *name;
3675 name = gfc_get_string (PREFIX ("system_sub"));
3676 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3677 }
3678
3679
3680 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
3681
3682 void
3683 gfc_resolve_system_clock (gfc_code *c)
3684 {
3685 const char *name;
3686 int kind;
3687 gfc_expr *count = c->ext.actual->expr;
3688 gfc_expr *count_max = c->ext.actual->next->next->expr;
3689
3690 /* The INTEGER(8) version has higher precision, it is used if both COUNT
3691 and COUNT_MAX can hold 64-bit values, or are absent. */
3692 if ((!count || count->ts.kind >= 8)
3693 && (!count_max || count_max->ts.kind >= 8))
3694 kind = 8;
3695 else
3696 kind = gfc_default_integer_kind;
3697
3698 name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
3699 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3700 }
3701
3702
3703 /* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */
3704 void
3705 gfc_resolve_execute_command_line (gfc_code *c)
3706 {
3707 const char *name;
3708 name = gfc_get_string (PREFIX ("execute_command_line_i%d"),
3709 gfc_default_integer_kind);
3710 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3711 }
3712
3713
3714 /* Resolve the EXIT intrinsic subroutine. */
3715
3716 void
3717 gfc_resolve_exit (gfc_code *c)
3718 {
3719 const char *name;
3720 gfc_typespec ts;
3721 gfc_expr *n;
3722 gfc_clear_ts (&ts);
3723
3724 /* The STATUS argument has to be of default kind. If it is not,
3725 we convert it. */
3726 ts.type = BT_INTEGER;
3727 ts.kind = gfc_default_integer_kind;
3728 n = c->ext.actual->expr;
3729 if (n != NULL && n->ts.kind != ts.kind)
3730 gfc_convert_type (n, &ts, 2);
3731
3732 name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
3733 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3734 }
3735
3736
3737 /* Resolve the FLUSH intrinsic subroutine. */
3738
3739 void
3740 gfc_resolve_flush (gfc_code *c)
3741 {
3742 const char *name;
3743 gfc_typespec ts;
3744 gfc_expr *n;
3745 gfc_clear_ts (&ts);
3746
3747 ts.type = BT_INTEGER;
3748 ts.kind = gfc_default_integer_kind;
3749 n = c->ext.actual->expr;
3750 if (n != NULL && n->ts.kind != ts.kind)
3751 gfc_convert_type (n, &ts, 2);
3752
3753 name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
3754 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3755 }
3756
3757
3758 void
3759 gfc_resolve_ctime_sub (gfc_code *c)
3760 {
3761 gfc_typespec ts;
3762 gfc_clear_ts (&ts);
3763
3764 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
3765 if (c->ext.actual->expr->ts.kind != 8)
3766 {
3767 ts.type = BT_INTEGER;
3768 ts.kind = 8;
3769 ts.u.derived = NULL;
3770 ts.u.cl = NULL;
3771 gfc_convert_type (c->ext.actual->expr, &ts, 2);
3772 }
3773
3774 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
3775 }
3776
3777
3778 void
3779 gfc_resolve_fdate_sub (gfc_code *c)
3780 {
3781 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
3782 }
3783
3784
3785 void
3786 gfc_resolve_gerror (gfc_code *c)
3787 {
3788 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
3789 }
3790
3791
3792 void
3793 gfc_resolve_getlog (gfc_code *c)
3794 {
3795 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
3796 }
3797
3798
3799 void
3800 gfc_resolve_hostnm_sub (gfc_code *c)
3801 {
3802 const char *name;
3803 int kind;
3804
3805 if (c->ext.actual->next->expr != NULL)
3806 kind = c->ext.actual->next->expr->ts.kind;
3807 else
3808 kind = gfc_default_integer_kind;
3809
3810 name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
3811 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3812 }
3813
3814
3815 void
3816 gfc_resolve_perror (gfc_code *c)
3817 {
3818 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
3819 }
3820
3821 /* Resolve the STAT and FSTAT intrinsic subroutines. */
3822
3823 void
3824 gfc_resolve_stat_sub (gfc_code *c)
3825 {
3826 const char *name;
3827 name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
3828 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3829 }
3830
3831
3832 void
3833 gfc_resolve_lstat_sub (gfc_code *c)
3834 {
3835 const char *name;
3836 name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
3837 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3838 }
3839
3840
3841 void
3842 gfc_resolve_fstat_sub (gfc_code *c)
3843 {
3844 const char *name;
3845 gfc_expr *u;
3846 gfc_typespec *ts;
3847
3848 u = c->ext.actual->expr;
3849 ts = &c->ext.actual->next->expr->ts;
3850 if (u->ts.kind != ts->kind)
3851 gfc_convert_type (u, ts, 2);
3852 name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
3853 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3854 }
3855
3856
3857 void
3858 gfc_resolve_fgetc_sub (gfc_code *c)
3859 {
3860 const char *name;
3861 gfc_typespec ts;
3862 gfc_expr *u, *st;
3863 gfc_clear_ts (&ts);
3864
3865 u = c->ext.actual->expr;
3866 st = c->ext.actual->next->next->expr;
3867
3868 if (u->ts.kind != gfc_c_int_kind)
3869 {
3870 ts.type = BT_INTEGER;
3871 ts.kind = gfc_c_int_kind;
3872 ts.u.derived = NULL;
3873 ts.u.cl = NULL;
3874 gfc_convert_type (u, &ts, 2);
3875 }
3876
3877 if (st != NULL)
3878 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind);
3879 else
3880 name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
3881
3882 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3883 }
3884
3885
3886 void
3887 gfc_resolve_fget_sub (gfc_code *c)
3888 {
3889 const char *name;
3890 gfc_expr *st;
3891
3892 st = c->ext.actual->next->expr;
3893 if (st != NULL)
3894 name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind);
3895 else
3896 name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
3897
3898 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3899 }
3900
3901
3902 void
3903 gfc_resolve_fputc_sub (gfc_code *c)
3904 {
3905 const char *name;
3906 gfc_typespec ts;
3907 gfc_expr *u, *st;
3908 gfc_clear_ts (&ts);
3909
3910 u = c->ext.actual->expr;
3911 st = c->ext.actual->next->next->expr;
3912
3913 if (u->ts.kind != gfc_c_int_kind)
3914 {
3915 ts.type = BT_INTEGER;
3916 ts.kind = gfc_c_int_kind;
3917 ts.u.derived = NULL;
3918 ts.u.cl = NULL;
3919 gfc_convert_type (u, &ts, 2);
3920 }
3921
3922 if (st != NULL)
3923 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind);
3924 else
3925 name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
3926
3927 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3928 }
3929
3930
3931 void
3932 gfc_resolve_fput_sub (gfc_code *c)
3933 {
3934 const char *name;
3935 gfc_expr *st;
3936
3937 st = c->ext.actual->next->expr;
3938 if (st != NULL)
3939 name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind);
3940 else
3941 name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
3942
3943 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
3944 }
3945
3946
3947 void
3948 gfc_resolve_fseek_sub (gfc_code *c)
3949 {
3950 gfc_expr *unit;
3951 gfc_expr *offset;
3952 gfc_expr *whence;
3953 gfc_typespec ts;
3954 gfc_clear_ts (&ts);
3955
3956 unit = c->ext.actual->expr;
3957 offset = c->ext.actual->next->expr;
3958 whence = c->ext.actual->next->next->expr;
3959
3960 if (unit->ts.kind != gfc_c_int_kind)
3961 {
3962 ts.type = BT_INTEGER;
3963 ts.kind = gfc_c_int_kind;
3964 ts.u.derived = NULL;
3965 ts.u.cl = NULL;
3966 gfc_convert_type (unit, &ts, 2);
3967 }
3968
3969 if (offset->ts.kind != gfc_intio_kind)
3970 {
3971 ts.type = BT_INTEGER;
3972 ts.kind = gfc_intio_kind;
3973 ts.u.derived = NULL;
3974 ts.u.cl = NULL;
3975 gfc_convert_type (offset, &ts, 2);
3976 }
3977
3978 if (whence->ts.kind != gfc_c_int_kind)
3979 {
3980 ts.type = BT_INTEGER;
3981 ts.kind = gfc_c_int_kind;
3982 ts.u.derived = NULL;
3983 ts.u.cl = NULL;
3984 gfc_convert_type (whence, &ts, 2);
3985 }
3986
3987 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
3988 }
3989
3990 void
3991 gfc_resolve_ftell_sub (gfc_code *c)
3992 {
3993 const char *name;
3994 gfc_expr *unit;
3995 gfc_expr *offset;
3996 gfc_typespec ts;
3997 gfc_clear_ts (&ts);
3998
3999 unit = c->ext.actual->expr;
4000 offset = c->ext.actual->next->expr;
4001
4002 if (unit->ts.kind != gfc_c_int_kind)
4003 {
4004 ts.type = BT_INTEGER;
4005 ts.kind = gfc_c_int_kind;
4006 ts.u.derived = NULL;
4007 ts.u.cl = NULL;
4008 gfc_convert_type (unit, &ts, 2);
4009 }
4010
4011 name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
4012 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4013 }
4014
4015
4016 void
4017 gfc_resolve_ttynam_sub (gfc_code *c)
4018 {
4019 gfc_typespec ts;
4020 gfc_clear_ts (&ts);
4021
4022 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
4023 {
4024 ts.type = BT_INTEGER;
4025 ts.kind = gfc_c_int_kind;
4026 ts.u.derived = NULL;
4027 ts.u.cl = NULL;
4028 gfc_convert_type (c->ext.actual->expr, &ts, 2);
4029 }
4030
4031 c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
4032 }
4033
4034
4035 /* Resolve the UMASK intrinsic subroutine. */
4036
4037 void
4038 gfc_resolve_umask_sub (gfc_code *c)
4039 {
4040 const char *name;
4041 int kind;
4042
4043 if (c->ext.actual->next->expr != NULL)
4044 kind = c->ext.actual->next->expr->ts.kind;
4045 else
4046 kind = gfc_default_integer_kind;
4047
4048 name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
4049 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4050 }
4051
4052 /* Resolve the UNLINK intrinsic subroutine. */
4053
4054 void
4055 gfc_resolve_unlink_sub (gfc_code *c)
4056 {
4057 const char *name;
4058 int kind;
4059
4060 if (c->ext.actual->next->expr != NULL)
4061 kind = c->ext.actual->next->expr->ts.kind;
4062 else
4063 kind = gfc_default_integer_kind;
4064
4065 name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
4066 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
4067 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org