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