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