1 /* Intrinsic function resolution.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
4 Contributed by Andy Vaught & Katherine Holcomb
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
24 /* Assign name and types to intrinsic procedures. For functions, the
25 first argument to a resolution function is an expression pointer to
26 the original function node and the rest are pointers to the
27 arguments of the function call. For subroutines, a pointer to the
28 code node is passed. The result type and library subroutine name
29 are generally set according to the function arguments. */
36 #include "intrinsic.h"
39 /* String pool subroutines. This are used to provide static locations
40 for the string constants that represent library function names. */
42 typedef struct string_node
44 struct string_node
*next
;
51 static string_node
*string_head
[HASH_SIZE
];
54 /* Return a hash code based on the name. */
57 hash (const char *name
)
63 h
= 5311966 * h
+ *name
++;
71 /* Given printf-like arguments, return a static address of the
72 resulting string. If the name is not in the table, it is added. */
75 gfc_get_string (const char *format
, ...)
82 va_start (ap
, format
);
83 vsprintf (temp_name
, format
, ap
);
89 for (p
= string_head
[h
]; p
; p
= p
->next
)
90 if (strcmp (p
->string
, temp_name
) == 0)
94 p
= gfc_getmem (sizeof (string_node
) + strlen (temp_name
));
96 strcpy (p
->string
, temp_name
);
98 p
->next
= string_head
[h
];
112 for (h
= 0; h
< HASH_SIZE
; h
++)
114 for (p
= string_head
[h
]; p
; p
= q
)
123 /********************** Resolution functions **********************/
127 gfc_resolve_abs (gfc_expr
* f
, gfc_expr
* a
)
131 if (f
->ts
.type
== BT_COMPLEX
)
132 f
->ts
.type
= BT_REAL
;
134 f
->value
.function
.name
=
135 gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
140 gfc_resolve_acos (gfc_expr
* f
, gfc_expr
* x
)
144 f
->value
.function
.name
=
145 gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
150 gfc_resolve_aimag (gfc_expr
* f
, gfc_expr
* x
)
153 f
->ts
.type
= BT_REAL
;
154 f
->ts
.kind
= x
->ts
.kind
;
155 f
->value
.function
.name
=
156 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
161 gfc_resolve_aint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
164 f
->ts
.type
= a
->ts
.type
;
165 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
167 /* The resolved name is only used for specific intrinsics where
168 the return kind is the same as the arg kind. */
169 f
->value
.function
.name
=
170 gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
175 gfc_resolve_dint (gfc_expr
* f
, gfc_expr
* a
)
177 gfc_resolve_aint (f
, a
, NULL
);
182 gfc_resolve_all (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
189 gfc_resolve_index (dim
, 1);
190 f
->rank
= mask
->rank
- 1;
191 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
194 f
->value
.function
.name
=
195 gfc_get_string ("__all_%c%d", gfc_type_letter (mask
->ts
.type
),
201 gfc_resolve_anint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
204 f
->ts
.type
= a
->ts
.type
;
205 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
207 /* The resolved name is only used for specific intrinsics where
208 the return kind is the same as the arg kind. */
209 f
->value
.function
.name
=
210 gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
215 gfc_resolve_dnint (gfc_expr
* f
, gfc_expr
* a
)
217 gfc_resolve_anint (f
, a
, NULL
);
222 gfc_resolve_any (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
229 gfc_resolve_index (dim
, 1);
230 f
->rank
= mask
->rank
- 1;
231 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
234 f
->value
.function
.name
=
235 gfc_get_string ("__any_%c%d", gfc_type_letter (mask
->ts
.type
),
241 gfc_resolve_asin (gfc_expr
* f
, gfc_expr
* x
)
245 f
->value
.function
.name
=
246 gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
251 gfc_resolve_atan (gfc_expr
* f
, gfc_expr
* x
)
255 f
->value
.function
.name
=
256 gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
261 gfc_resolve_atan2 (gfc_expr
* f
, gfc_expr
* x
,
262 gfc_expr
* y ATTRIBUTE_UNUSED
)
266 f
->value
.function
.name
=
267 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
271 /* Resolve the BESYN and BESJN intrinsics. */
274 gfc_resolve_besn (gfc_expr
* f
, gfc_expr
* n
, gfc_expr
* x
)
279 if (n
->ts
.kind
!= gfc_c_int_kind
)
281 ts
.type
= BT_INTEGER
;
282 ts
.kind
= gfc_c_int_kind
;
283 gfc_convert_type (n
, &ts
, 2);
285 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
290 gfc_resolve_btest (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos
)
293 f
->ts
.type
= BT_LOGICAL
;
294 f
->ts
.kind
= gfc_default_logical_kind
;
296 f
->value
.function
.name
= gfc_get_string ("__btest_%d_%d", i
->ts
.kind
,
302 gfc_resolve_ceiling (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
305 f
->ts
.type
= BT_INTEGER
;
306 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
307 : mpz_get_si (kind
->value
.integer
);
309 f
->value
.function
.name
=
310 gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
311 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
316 gfc_resolve_char (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
319 f
->ts
.type
= BT_CHARACTER
;
320 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_character_kind
321 : mpz_get_si (kind
->value
.integer
);
323 f
->value
.function
.name
=
324 gfc_get_string ("__char_%d_%c%d", f
->ts
.kind
,
325 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
330 gfc_resolve_cmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
333 f
->ts
.type
= BT_COMPLEX
;
334 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_real_kind
335 : mpz_get_si (kind
->value
.integer
);
338 f
->value
.function
.name
=
339 gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
340 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
342 f
->value
.function
.name
=
343 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
344 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
345 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
349 gfc_resolve_dcmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
)
351 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind
));
355 gfc_resolve_conjg (gfc_expr
* f
, gfc_expr
* x
)
359 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
364 gfc_resolve_cos (gfc_expr
* f
, gfc_expr
* x
)
368 f
->value
.function
.name
=
369 gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
374 gfc_resolve_cosh (gfc_expr
* f
, gfc_expr
* x
)
378 f
->value
.function
.name
=
379 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
384 gfc_resolve_count (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
387 f
->ts
.type
= BT_INTEGER
;
388 f
->ts
.kind
= gfc_default_integer_kind
;
392 f
->rank
= mask
->rank
- 1;
393 gfc_resolve_index (dim
, 1);
394 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
397 f
->value
.function
.name
=
398 gfc_get_string ("__count_%d_%c%d", f
->ts
.kind
,
399 gfc_type_letter (mask
->ts
.type
), mask
->ts
.kind
);
404 gfc_resolve_cshift (gfc_expr
* f
, gfc_expr
* array
,
411 f
->rank
= array
->rank
;
412 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
421 gfc_resolve_index (dim
, 1);
422 /* Convert dim to shift's kind, so we don't need so many variations. */
423 if (dim
->ts
.kind
!= shift
->ts
.kind
)
424 gfc_convert_type (dim
, &shift
->ts
, 2);
426 f
->value
.function
.name
=
427 gfc_get_string ("__cshift%d_%d", n
, shift
->ts
.kind
);
432 gfc_resolve_dble (gfc_expr
* f
, gfc_expr
* a
)
435 f
->ts
.type
= BT_REAL
;
436 f
->ts
.kind
= gfc_default_double_kind
;
437 f
->value
.function
.name
=
438 gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
443 gfc_resolve_dim (gfc_expr
* f
, gfc_expr
* x
,
444 gfc_expr
* y ATTRIBUTE_UNUSED
)
448 f
->value
.function
.name
=
449 gfc_get_string ("__dim_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
454 gfc_resolve_dot_product (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
458 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
460 f
->ts
.type
= BT_LOGICAL
;
461 f
->ts
.kind
= gfc_default_logical_kind
;
465 temp
.expr_type
= EXPR_OP
;
466 gfc_clear_ts (&temp
.ts
);
467 temp
.operator = INTRINSIC_NONE
;
470 gfc_type_convert_binary (&temp
);
474 f
->value
.function
.name
=
475 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f
->ts
.type
),
481 gfc_resolve_dprod (gfc_expr
* f
,
482 gfc_expr
* a ATTRIBUTE_UNUSED
,
483 gfc_expr
* b ATTRIBUTE_UNUSED
)
485 f
->ts
.kind
= gfc_default_double_kind
;
486 f
->ts
.type
= BT_REAL
;
488 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
493 gfc_resolve_eoshift (gfc_expr
* f
, gfc_expr
* array
,
501 f
->rank
= array
->rank
;
502 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
507 if (boundary
&& boundary
->rank
> 0)
510 /* Convert dim to the same type as shift, so we don't need quite so many
512 if (dim
!= NULL
&& dim
->ts
.kind
!= shift
->ts
.kind
)
513 gfc_convert_type (dim
, &shift
->ts
, 2);
515 f
->value
.function
.name
=
516 gfc_get_string ("__eoshift%d_%d", n
, shift
->ts
.kind
);
521 gfc_resolve_exp (gfc_expr
* f
, gfc_expr
* x
)
525 f
->value
.function
.name
=
526 gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
531 gfc_resolve_exponent (gfc_expr
* f
, gfc_expr
* x
)
534 f
->ts
.type
= BT_INTEGER
;
535 f
->ts
.kind
= gfc_default_integer_kind
;
537 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
542 gfc_resolve_floor (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
545 f
->ts
.type
= BT_INTEGER
;
546 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
547 : mpz_get_si (kind
->value
.integer
);
549 f
->value
.function
.name
=
550 gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
551 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
556 gfc_resolve_fnum (gfc_expr
* f
, gfc_expr
* n
)
559 f
->ts
.type
= BT_INTEGER
;
560 f
->ts
.kind
= gfc_default_integer_kind
;
561 if (n
->ts
.kind
!= f
->ts
.kind
)
562 gfc_convert_type (n
, &f
->ts
, 2);
563 f
->value
.function
.name
= gfc_get_string (PREFIX("fnum_i%d"), f
->ts
.kind
);
568 gfc_resolve_fraction (gfc_expr
* f
, gfc_expr
* x
)
572 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
576 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
579 gfc_resolve_g77_math1 (gfc_expr
* f
, gfc_expr
* x
)
582 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
587 gfc_resolve_getcwd (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
589 f
->ts
.type
= BT_INTEGER
;
591 f
->value
.function
.name
= gfc_get_string (PREFIX("getcwd"));
596 gfc_resolve_getgid (gfc_expr
* f
)
598 f
->ts
.type
= BT_INTEGER
;
600 f
->value
.function
.name
= gfc_get_string (PREFIX("getgid"));
605 gfc_resolve_getpid (gfc_expr
* f
)
607 f
->ts
.type
= BT_INTEGER
;
609 f
->value
.function
.name
= gfc_get_string (PREFIX("getpid"));
614 gfc_resolve_getuid (gfc_expr
* f
)
616 f
->ts
.type
= BT_INTEGER
;
618 f
->value
.function
.name
= gfc_get_string (PREFIX("getuid"));
622 gfc_resolve_iand (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j ATTRIBUTE_UNUSED
)
626 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
631 gfc_resolve_ibclr (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos ATTRIBUTE_UNUSED
)
635 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
640 gfc_resolve_ibits (gfc_expr
* f
, gfc_expr
* i
,
641 gfc_expr
* pos ATTRIBUTE_UNUSED
,
642 gfc_expr
* len ATTRIBUTE_UNUSED
)
646 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
651 gfc_resolve_ibset (gfc_expr
* f
, gfc_expr
* i
,
652 gfc_expr
* pos ATTRIBUTE_UNUSED
)
656 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
661 gfc_resolve_ichar (gfc_expr
* f
, gfc_expr
* c
)
664 f
->ts
.type
= BT_INTEGER
;
665 f
->ts
.kind
= gfc_default_integer_kind
;
667 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
672 gfc_resolve_idnint (gfc_expr
* f
, gfc_expr
* a
)
674 gfc_resolve_nint (f
, a
, NULL
);
679 gfc_resolve_ieor (gfc_expr
* f
, gfc_expr
* i
,
680 gfc_expr
* j ATTRIBUTE_UNUSED
)
684 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
689 gfc_resolve_ior (gfc_expr
* f
, gfc_expr
* i
,
690 gfc_expr
* j ATTRIBUTE_UNUSED
)
694 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
699 gfc_resolve_int (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
702 f
->ts
.type
= BT_INTEGER
;
703 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
704 : mpz_get_si (kind
->value
.integer
);
706 f
->value
.function
.name
=
707 gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
, gfc_type_letter (a
->ts
.type
),
713 gfc_resolve_ishft (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
)
717 f
->value
.function
.name
=
718 gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
723 gfc_resolve_ishftc (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
,
728 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: shift
->ts
.kind
;
731 f
->value
.function
.name
=
732 gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
737 gfc_resolve_lbound (gfc_expr
* f
, gfc_expr
* array
,
740 static char lbound
[] = "__lbound";
742 f
->ts
.type
= BT_INTEGER
;
743 f
->ts
.kind
= gfc_default_integer_kind
;
748 f
->shape
= gfc_get_shape (1);
749 mpz_init_set_ui (f
->shape
[0], array
->rank
);
752 f
->value
.function
.name
= lbound
;
757 gfc_resolve_len (gfc_expr
* f
, gfc_expr
* string
)
760 f
->ts
.type
= BT_INTEGER
;
761 f
->ts
.kind
= gfc_default_integer_kind
;
762 f
->value
.function
.name
= gfc_get_string ("__len_%d", string
->ts
.kind
);
767 gfc_resolve_len_trim (gfc_expr
* f
, gfc_expr
* string
)
770 f
->ts
.type
= BT_INTEGER
;
771 f
->ts
.kind
= gfc_default_integer_kind
;
772 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
777 gfc_resolve_log (gfc_expr
* f
, gfc_expr
* x
)
781 f
->value
.function
.name
=
782 gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
787 gfc_resolve_log10 (gfc_expr
* f
, gfc_expr
* x
)
791 f
->value
.function
.name
=
792 gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
797 gfc_resolve_logical (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
800 f
->ts
.type
= BT_LOGICAL
;
801 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_logical_kind
802 : mpz_get_si (kind
->value
.integer
);
805 f
->value
.function
.name
=
806 gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
807 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
812 gfc_resolve_matmul (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
816 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
818 f
->ts
.type
= BT_LOGICAL
;
819 f
->ts
.kind
= gfc_default_logical_kind
;
823 temp
.expr_type
= EXPR_OP
;
824 gfc_clear_ts (&temp
.ts
);
825 temp
.operator = INTRINSIC_NONE
;
828 gfc_type_convert_binary (&temp
);
832 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
834 f
->value
.function
.name
=
835 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f
->ts
.type
),
841 gfc_resolve_minmax (const char * name
, gfc_expr
* f
, gfc_actual_arglist
* args
)
843 gfc_actual_arglist
*a
;
845 f
->ts
.type
= args
->expr
->ts
.type
;
846 f
->ts
.kind
= args
->expr
->ts
.kind
;
847 /* Find the largest type kind. */
848 for (a
= args
->next
; a
; a
= a
->next
)
850 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
851 f
->ts
.kind
= a
->expr
->ts
.kind
;
854 /* Convert all parameters to the required kind. */
855 for (a
= args
; a
; a
= a
->next
)
857 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
858 gfc_convert_type (a
->expr
, &f
->ts
, 2);
861 f
->value
.function
.name
=
862 gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
867 gfc_resolve_max (gfc_expr
* f
, gfc_actual_arglist
* args
)
869 gfc_resolve_minmax ("__max_%c%d", f
, args
);
874 gfc_resolve_maxloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
879 f
->ts
.type
= BT_INTEGER
;
880 f
->ts
.kind
= gfc_default_integer_kind
;
886 f
->rank
= array
->rank
- 1;
887 gfc_resolve_index (dim
, 1);
890 name
= mask
? "mmaxloc" : "maxloc";
891 f
->value
.function
.name
=
892 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
893 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
898 gfc_resolve_maxval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
906 f
->rank
= array
->rank
- 1;
907 gfc_resolve_index (dim
, 1);
910 f
->value
.function
.name
=
911 gfc_get_string ("__%s_%c%d", mask
? "mmaxval" : "maxval",
912 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
917 gfc_resolve_merge (gfc_expr
* f
, gfc_expr
* tsource
,
918 gfc_expr
* fsource ATTRIBUTE_UNUSED
,
919 gfc_expr
* mask ATTRIBUTE_UNUSED
)
923 f
->value
.function
.name
=
924 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
930 gfc_resolve_min (gfc_expr
* f
, gfc_actual_arglist
* args
)
932 gfc_resolve_minmax ("__min_%c%d", f
, args
);
937 gfc_resolve_minloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
942 f
->ts
.type
= BT_INTEGER
;
943 f
->ts
.kind
= gfc_default_integer_kind
;
949 f
->rank
= array
->rank
- 1;
950 gfc_resolve_index (dim
, 1);
953 name
= mask
? "mminloc" : "minloc";
954 f
->value
.function
.name
=
955 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
956 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
961 gfc_resolve_minval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
969 f
->rank
= array
->rank
- 1;
970 gfc_resolve_index (dim
, 1);
973 f
->value
.function
.name
=
974 gfc_get_string ("__%s_%c%d", mask
? "mminval" : "minval",
975 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
980 gfc_resolve_mod (gfc_expr
* f
, gfc_expr
* a
,
981 gfc_expr
* p ATTRIBUTE_UNUSED
)
985 f
->value
.function
.name
=
986 gfc_get_string ("__mod_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
991 gfc_resolve_modulo (gfc_expr
* f
, gfc_expr
* a
,
992 gfc_expr
* p ATTRIBUTE_UNUSED
)
996 f
->value
.function
.name
=
997 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a
->ts
.type
),
1002 gfc_resolve_nearest (gfc_expr
* f
, gfc_expr
* a
,
1003 gfc_expr
*p ATTRIBUTE_UNUSED
)
1007 f
->value
.function
.name
=
1008 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
1013 gfc_resolve_nint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
1016 f
->ts
.type
= BT_INTEGER
;
1017 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
1018 : mpz_get_si (kind
->value
.integer
);
1020 f
->value
.function
.name
=
1021 gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1026 gfc_resolve_not (gfc_expr
* f
, gfc_expr
* i
)
1030 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1035 gfc_resolve_pack (gfc_expr
* f
,
1036 gfc_expr
* array ATTRIBUTE_UNUSED
,
1038 gfc_expr
* vector ATTRIBUTE_UNUSED
)
1040 static char pack
[] = "__pack",
1041 pack_s
[] = "__pack_s";
1046 if (mask
->rank
!= 0)
1047 f
->value
.function
.name
= pack
;
1050 /* We convert mask to default logical only in the scalar case.
1051 In the array case we can simply read the array as if it were
1052 of type default logical. */
1053 if (mask
->ts
.kind
!= gfc_default_logical_kind
)
1057 ts
.type
= BT_LOGICAL
;
1058 ts
.kind
= gfc_default_logical_kind
;
1059 gfc_convert_type (mask
, &ts
, 2);
1062 f
->value
.function
.name
= pack_s
;
1068 gfc_resolve_product (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1076 f
->rank
= array
->rank
- 1;
1077 gfc_resolve_index (dim
, 1);
1080 f
->value
.function
.name
=
1081 gfc_get_string ("__%s_%c%d", mask
? "mproduct" : "product",
1082 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1087 gfc_resolve_real (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
1090 f
->ts
.type
= BT_REAL
;
1093 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1095 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
) ?
1096 a
->ts
.kind
: gfc_default_real_kind
;
1098 f
->value
.function
.name
=
1099 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1100 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1105 gfc_resolve_repeat (gfc_expr
* f
, gfc_expr
* string
,
1106 gfc_expr
* ncopies ATTRIBUTE_UNUSED
)
1109 f
->ts
.type
= BT_CHARACTER
;
1110 f
->ts
.kind
= string
->ts
.kind
;
1111 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1116 gfc_resolve_reshape (gfc_expr
* f
, gfc_expr
* source
, gfc_expr
* shape
,
1117 gfc_expr
* pad ATTRIBUTE_UNUSED
,
1118 gfc_expr
* order ATTRIBUTE_UNUSED
)
1120 static char reshape0
[] = "__reshape";
1127 gfc_array_size (shape
, &rank
);
1128 f
->rank
= mpz_get_si (rank
);
1130 switch (source
->ts
.type
)
1133 kind
= source
->ts
.kind
* 2;
1139 kind
= source
->ts
.kind
;
1152 f
->value
.function
.name
=
1153 gfc_get_string ("__reshape_%d", source
->ts
.kind
);
1157 f
->value
.function
.name
= reshape0
;
1161 /* TODO: Make this work with a constant ORDER parameter. */
1162 if (shape
->expr_type
== EXPR_ARRAY
1163 && gfc_is_constant_expr (shape
)
1167 f
->shape
= gfc_get_shape (f
->rank
);
1168 c
= shape
->value
.constructor
;
1169 for (i
= 0; i
< f
->rank
; i
++)
1171 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1179 gfc_resolve_rrspacing (gfc_expr
* f
, gfc_expr
* x
)
1183 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1188 gfc_resolve_scale (gfc_expr
* f
, gfc_expr
* x
,
1189 gfc_expr
* y ATTRIBUTE_UNUSED
)
1193 f
->value
.function
.name
= gfc_get_string ("__scale_%d_%d", x
->ts
.kind
,
1199 gfc_resolve_scan (gfc_expr
* f
, gfc_expr
* string
,
1200 gfc_expr
* set ATTRIBUTE_UNUSED
,
1201 gfc_expr
* back ATTRIBUTE_UNUSED
)
1204 f
->ts
.type
= BT_INTEGER
;
1205 f
->ts
.kind
= gfc_default_integer_kind
;
1206 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1211 gfc_resolve_set_exponent (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1215 f
->value
.function
.name
=
1216 gfc_get_string ("__set_exponent_%d_%d", x
->ts
.kind
, i
->ts
.kind
);
1221 gfc_resolve_shape (gfc_expr
* f
, gfc_expr
* array
)
1224 f
->ts
.type
= BT_INTEGER
;
1225 f
->ts
.kind
= gfc_default_integer_kind
;
1227 f
->value
.function
.name
= gfc_get_string ("__shape_%d", f
->ts
.kind
);
1228 f
->shape
= gfc_get_shape (1);
1229 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1234 gfc_resolve_sign (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b ATTRIBUTE_UNUSED
)
1238 f
->value
.function
.name
=
1239 gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1244 gfc_resolve_sin (gfc_expr
* f
, gfc_expr
* x
)
1248 f
->value
.function
.name
=
1249 gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1254 gfc_resolve_sinh (gfc_expr
* f
, gfc_expr
* x
)
1258 f
->value
.function
.name
=
1259 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1264 gfc_resolve_spacing (gfc_expr
* f
, gfc_expr
* x
)
1268 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1273 gfc_resolve_spread (gfc_expr
* f
, gfc_expr
* source
,
1277 static char spread
[] = "__spread";
1280 f
->rank
= source
->rank
+ 1;
1281 f
->value
.function
.name
= spread
;
1283 gfc_resolve_index (dim
, 1);
1284 gfc_resolve_index (ncopies
, 1);
1289 gfc_resolve_sqrt (gfc_expr
* f
, gfc_expr
* x
)
1293 f
->value
.function
.name
=
1294 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1298 /* Resolve the g77 compatibility function STAT AND FSTAT. */
1301 gfc_resolve_stat (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
,
1302 gfc_expr
* a ATTRIBUTE_UNUSED
)
1305 f
->ts
.type
= BT_INTEGER
;
1306 f
->ts
.kind
= gfc_default_integer_kind
;
1307 f
->value
.function
.name
= gfc_get_string (PREFIX("stat_i%d"), f
->ts
.kind
);
1312 gfc_resolve_fstat (gfc_expr
* f
, gfc_expr
* n
, gfc_expr
* a ATTRIBUTE_UNUSED
)
1315 f
->ts
.type
= BT_INTEGER
;
1316 f
->ts
.kind
= gfc_default_integer_kind
;
1317 if (n
->ts
.kind
!= f
->ts
.kind
)
1318 gfc_convert_type (n
, &f
->ts
, 2);
1320 f
->value
.function
.name
= gfc_get_string (PREFIX("fstat_i%d"), f
->ts
.kind
);
1325 gfc_resolve_sum (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1333 f
->rank
= array
->rank
- 1;
1334 gfc_resolve_index (dim
, 1);
1337 f
->value
.function
.name
=
1338 gfc_get_string ("__%s_%c%d", mask
? "msum" : "sum",
1339 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1343 /* Resolve the g77 compatibility function SYSTEM. */
1346 gfc_resolve_system (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
1348 f
->ts
.type
= BT_INTEGER
;
1350 f
->value
.function
.name
= gfc_get_string (PREFIX("system"));
1355 gfc_resolve_tan (gfc_expr
* f
, gfc_expr
* x
)
1359 f
->value
.function
.name
=
1360 gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1365 gfc_resolve_tanh (gfc_expr
* f
, gfc_expr
* x
)
1369 f
->value
.function
.name
=
1370 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1375 gfc_resolve_transfer (gfc_expr
* f
, gfc_expr
* source ATTRIBUTE_UNUSED
,
1376 gfc_expr
* mold
, gfc_expr
* size
)
1378 /* TODO: Make this do something meaningful. */
1379 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
1383 if (size
== NULL
&& mold
->rank
== 0)
1386 f
->value
.function
.name
= transfer0
;
1391 f
->value
.function
.name
= transfer1
;
1397 gfc_resolve_transpose (gfc_expr
* f
, gfc_expr
* matrix
)
1399 static char transpose0
[] = "__transpose";
1406 f
->shape
= gfc_get_shape (2);
1407 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
1408 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
1411 switch (matrix
->ts
.type
)
1414 kind
= matrix
->ts
.kind
* 2;
1420 kind
= matrix
->ts
.kind
;
1434 f
->value
.function
.name
=
1435 gfc_get_string ("__transpose_%d", kind
);
1439 f
->value
.function
.name
= transpose0
;
1445 gfc_resolve_trim (gfc_expr
* f
, gfc_expr
* string
)
1448 f
->ts
.type
= BT_CHARACTER
;
1449 f
->ts
.kind
= string
->ts
.kind
;
1450 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
1455 gfc_resolve_ubound (gfc_expr
* f
, gfc_expr
* array
,
1458 static char ubound
[] = "__ubound";
1460 f
->ts
.type
= BT_INTEGER
;
1461 f
->ts
.kind
= gfc_default_integer_kind
;
1466 f
->shape
= gfc_get_shape (1);
1467 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1470 f
->value
.function
.name
= ubound
;
1474 /* Resolve the g77 compatibility function UMASK. */
1477 gfc_resolve_umask (gfc_expr
* f
, gfc_expr
* n
)
1480 f
->ts
.type
= BT_INTEGER
;
1481 f
->ts
.kind
= n
->ts
.kind
;
1482 f
->value
.function
.name
= gfc_get_string (PREFIX("umask_i%d"), n
->ts
.kind
);
1486 /* Resolve the g77 compatibility function UNLINK. */
1489 gfc_resolve_unlink (gfc_expr
* f
, gfc_expr
* n ATTRIBUTE_UNUSED
)
1492 f
->ts
.type
= BT_INTEGER
;
1494 f
->value
.function
.name
= gfc_get_string (PREFIX("unlink"));
1498 gfc_resolve_unpack (gfc_expr
* f
, gfc_expr
* vector
, gfc_expr
* mask
,
1499 gfc_expr
* field ATTRIBUTE_UNUSED
)
1502 f
->ts
.type
= vector
->ts
.type
;
1503 f
->ts
.kind
= vector
->ts
.kind
;
1504 f
->rank
= mask
->rank
;
1506 f
->value
.function
.name
=
1507 gfc_get_string ("__unpack%d", field
->rank
> 0 ? 1 : 0);
1512 gfc_resolve_verify (gfc_expr
* f
, gfc_expr
* string
,
1513 gfc_expr
* set ATTRIBUTE_UNUSED
,
1514 gfc_expr
* back ATTRIBUTE_UNUSED
)
1517 f
->ts
.type
= BT_INTEGER
;
1518 f
->ts
.kind
= gfc_default_integer_kind
;
1519 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
1523 /* Intrinsic subroutine resolution. */
1526 gfc_resolve_cpu_time (gfc_code
* c ATTRIBUTE_UNUSED
)
1530 name
= gfc_get_string (PREFIX("cpu_time_%d"),
1531 c
->ext
.actual
->expr
->ts
.kind
);
1532 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1537 gfc_resolve_mvbits (gfc_code
* c
)
1542 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1543 name
= gfc_get_string (PREFIX("mvbits_i%d"), kind
);
1545 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1550 gfc_resolve_random_number (gfc_code
* c ATTRIBUTE_UNUSED
)
1555 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1556 if (c
->ext
.actual
->expr
->rank
== 0)
1557 name
= gfc_get_string (PREFIX("random_r%d"), kind
);
1559 name
= gfc_get_string (PREFIX("arandom_r%d"), kind
);
1561 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1565 /* G77 compatibility subroutines etime() and dtime(). */
1568 gfc_resolve_etime_sub (gfc_code
* c
)
1572 name
= gfc_get_string (PREFIX("etime_sub"));
1573 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1577 /* G77 compatibility subroutine second(). */
1580 gfc_resolve_second_sub (gfc_code
* c
)
1584 name
= gfc_get_string (PREFIX("second_sub"));
1585 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1589 /* G77 compatibility function srand(). */
1592 gfc_resolve_srand (gfc_code
* c
)
1595 name
= gfc_get_string (PREFIX("srand"));
1596 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1600 /* Resolve the getarg intrinsic subroutine. */
1603 gfc_resolve_getarg (gfc_code
* c
)
1608 kind
= gfc_default_integer_kind
;
1609 name
= gfc_get_string (PREFIX("getarg_i%d"), kind
);
1610 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1613 /* Resolve the getcwd intrinsic subroutine. */
1616 gfc_resolve_getcwd_sub (gfc_code
* c
)
1621 if (c
->ext
.actual
->next
->expr
!= NULL
)
1622 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1624 kind
= gfc_default_integer_kind
;
1626 name
= gfc_get_string (PREFIX("getcwd_i%d_sub"), kind
);
1627 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1631 /* Resolve the get_command intrinsic subroutine. */
1634 gfc_resolve_get_command (gfc_code
* c
)
1639 kind
= gfc_default_integer_kind
;
1640 name
= gfc_get_string (PREFIX("get_command_i%d"), kind
);
1641 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1645 /* Resolve the get_command_argument intrinsic subroutine. */
1648 gfc_resolve_get_command_argument (gfc_code
* c
)
1653 kind
= gfc_default_integer_kind
;
1654 name
= gfc_get_string (PREFIX("get_command_argument_i%d"), kind
);
1655 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1658 /* Resolve the get_environment_variable intrinsic subroutine. */
1661 gfc_resolve_get_environment_variable (gfc_code
* code
)
1666 kind
= gfc_default_integer_kind
;
1667 name
= gfc_get_string (PREFIX("get_environment_variable_i%d"), kind
);
1668 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1671 /* Resolve the SYSTEM intrinsic subroutine. */
1674 gfc_resolve_system_sub (gfc_code
* c
)
1678 name
= gfc_get_string (PREFIX("system_sub"));
1679 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1682 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1685 gfc_resolve_system_clock (gfc_code
* c
)
1690 if (c
->ext
.actual
->expr
!= NULL
)
1691 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1692 else if (c
->ext
.actual
->next
->expr
!= NULL
)
1693 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1694 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1695 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1697 kind
= gfc_default_integer_kind
;
1699 name
= gfc_get_string (PREFIX("system_clock_%d"), kind
);
1700 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1703 /* Resolve the EXIT intrinsic subroutine. */
1706 gfc_resolve_exit (gfc_code
* c
)
1711 if (c
->ext
.actual
->expr
!= NULL
)
1712 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1714 kind
= gfc_default_integer_kind
;
1716 name
= gfc_get_string (PREFIX("exit_i%d"), kind
);
1717 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1720 /* Resolve the FLUSH intrinsic subroutine. */
1723 gfc_resolve_flush (gfc_code
* c
)
1729 ts
.type
= BT_INTEGER
;
1730 ts
.kind
= gfc_default_integer_kind
;
1731 n
= c
->ext
.actual
->expr
;
1733 && n
->ts
.kind
!= ts
.kind
)
1734 gfc_convert_type (n
, &ts
, 2);
1736 name
= gfc_get_string (PREFIX("flush_i%d"), ts
.kind
);
1737 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1740 /* Resolve the STAT and FSTAT intrinsic subroutines. */
1743 gfc_resolve_stat_sub (gfc_code
* c
)
1747 name
= gfc_get_string (PREFIX("stat_i%d_sub"), gfc_default_integer_kind
);
1748 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1753 gfc_resolve_fstat_sub (gfc_code
* c
)
1759 u
= c
->ext
.actual
->expr
;
1760 ts
= &c
->ext
.actual
->next
->expr
->ts
;
1761 if (u
->ts
.kind
!= ts
->kind
)
1762 gfc_convert_type (u
, ts
, 2);
1763 name
= gfc_get_string (PREFIX("fstat_i%d_sub"), ts
->kind
);
1764 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1767 /* Resolve the UMASK intrinsic subroutine. */
1770 gfc_resolve_umask_sub (gfc_code
* c
)
1775 if (c
->ext
.actual
->next
->expr
!= NULL
)
1776 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1778 kind
= gfc_default_integer_kind
;
1780 name
= gfc_get_string (PREFIX("umask_i%d_sub"), kind
);
1781 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1784 /* Resolve the UNLINK intrinsic subroutine. */
1787 gfc_resolve_unlink_sub (gfc_code
* c
)
1792 if (c
->ext
.actual
->next
->expr
!= NULL
)
1793 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1795 kind
= gfc_default_integer_kind
;
1797 name
= gfc_get_string (PREFIX("unlink_i%d_sub"), kind
);
1798 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1803 gfc_iresolve_init_1 (void)
1807 for (i
= 0; i
< HASH_SIZE
; i
++)
1808 string_head
[i
] = NULL
;
1813 gfc_iresolve_done_1 (void)