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