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. */
37 #include "intrinsic.h"
40 /* String pool subroutines. This are used to provide static locations
41 for the string constants that represent library function names. */
43 typedef struct string_node
45 struct string_node
*next
;
52 static string_node
*string_head
[HASH_SIZE
];
55 /* Return a hash code based on the name. */
58 hash (const char *name
)
64 h
= 5311966 * h
+ *name
++;
72 /* Given printf-like arguments, return a static address of the
73 resulting string. If the name is not in the table, it is added. */
76 gfc_get_string (const char *format
, ...)
83 va_start (ap
, format
);
84 vsprintf (temp_name
, format
, ap
);
90 for (p
= string_head
[h
]; p
; p
= p
->next
)
91 if (strcmp (p
->string
, temp_name
) == 0)
95 p
= gfc_getmem (sizeof (string_node
) + strlen (temp_name
));
97 strcpy (p
->string
, temp_name
);
99 p
->next
= string_head
[h
];
113 for (h
= 0; h
< HASH_SIZE
; h
++)
115 for (p
= string_head
[h
]; p
; p
= q
)
124 /********************** Resolution functions **********************/
128 gfc_resolve_abs (gfc_expr
* f
, gfc_expr
* a
)
132 if (f
->ts
.type
== BT_COMPLEX
)
133 f
->ts
.type
= BT_REAL
;
135 f
->value
.function
.name
=
136 gfc_get_string ("__abs_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
141 gfc_resolve_acos (gfc_expr
* f
, gfc_expr
* x
)
145 f
->value
.function
.name
=
146 gfc_get_string ("__acos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
151 gfc_resolve_aimag (gfc_expr
* f
, gfc_expr
* x
)
154 f
->ts
.type
= BT_REAL
;
155 f
->ts
.kind
= x
->ts
.kind
;
156 f
->value
.function
.name
=
157 gfc_get_string ("__aimag_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
162 gfc_resolve_aint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
165 f
->ts
.type
= a
->ts
.type
;
166 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
168 /* The resolved name is only used for specific intrinsics where
169 the return kind is the same as the arg kind. */
170 f
->value
.function
.name
=
171 gfc_get_string ("__aint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
176 gfc_resolve_dint (gfc_expr
* f
, gfc_expr
* a
)
178 gfc_resolve_aint (f
, a
, NULL
);
183 gfc_resolve_all (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
190 gfc_resolve_index (dim
, 1);
191 f
->rank
= mask
->rank
- 1;
192 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
195 f
->value
.function
.name
=
196 gfc_get_string ("__all_%c%d", gfc_type_letter (mask
->ts
.type
),
202 gfc_resolve_anint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
205 f
->ts
.type
= a
->ts
.type
;
206 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
208 /* The resolved name is only used for specific intrinsics where
209 the return kind is the same as the arg kind. */
210 f
->value
.function
.name
=
211 gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
216 gfc_resolve_dnint (gfc_expr
* f
, gfc_expr
* a
)
218 gfc_resolve_anint (f
, a
, NULL
);
223 gfc_resolve_any (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
230 gfc_resolve_index (dim
, 1);
231 f
->rank
= mask
->rank
- 1;
232 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
235 f
->value
.function
.name
=
236 gfc_get_string ("__any_%c%d", gfc_type_letter (mask
->ts
.type
),
242 gfc_resolve_asin (gfc_expr
* f
, gfc_expr
* x
)
246 f
->value
.function
.name
=
247 gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
252 gfc_resolve_atan (gfc_expr
* f
, gfc_expr
* x
)
256 f
->value
.function
.name
=
257 gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
262 gfc_resolve_atan2 (gfc_expr
* f
, gfc_expr
* x
,
263 gfc_expr
* y ATTRIBUTE_UNUSED
)
267 f
->value
.function
.name
=
268 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
273 gfc_resolve_btest (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos
)
276 f
->ts
.type
= BT_LOGICAL
;
277 f
->ts
.kind
= gfc_default_logical_kind
;
279 f
->value
.function
.name
= gfc_get_string ("__btest_%d_%d", i
->ts
.kind
,
285 gfc_resolve_ceiling (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
288 f
->ts
.type
= BT_INTEGER
;
289 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
290 : mpz_get_si (kind
->value
.integer
);
292 f
->value
.function
.name
=
293 gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
294 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
299 gfc_resolve_char (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
302 f
->ts
.type
= BT_CHARACTER
;
303 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_character_kind
304 : mpz_get_si (kind
->value
.integer
);
306 f
->value
.function
.name
=
307 gfc_get_string ("__char_%d_%c%d", f
->ts
.kind
,
308 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
313 gfc_resolve_cmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
316 f
->ts
.type
= BT_COMPLEX
;
317 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_real_kind
318 : mpz_get_si (kind
->value
.integer
);
321 f
->value
.function
.name
=
322 gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
323 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
325 f
->value
.function
.name
=
326 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
327 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
328 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
332 gfc_resolve_dcmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
)
334 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind
));
338 gfc_resolve_conjg (gfc_expr
* f
, gfc_expr
* x
)
342 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
347 gfc_resolve_cos (gfc_expr
* f
, gfc_expr
* x
)
351 f
->value
.function
.name
=
352 gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
357 gfc_resolve_cosh (gfc_expr
* f
, gfc_expr
* x
)
361 f
->value
.function
.name
=
362 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
367 gfc_resolve_count (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
370 f
->ts
.type
= BT_INTEGER
;
371 f
->ts
.kind
= gfc_default_integer_kind
;
375 f
->rank
= mask
->rank
- 1;
376 gfc_resolve_index (dim
, 1);
377 f
->shape
= gfc_copy_shape_excluding (mask
->shape
, mask
->rank
, dim
);
380 f
->value
.function
.name
=
381 gfc_get_string ("__count_%d_%c%d", f
->ts
.kind
,
382 gfc_type_letter (mask
->ts
.type
), mask
->ts
.kind
);
387 gfc_resolve_cshift (gfc_expr
* f
, gfc_expr
* array
,
394 f
->rank
= array
->rank
;
395 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
404 gfc_resolve_index (dim
, 1);
405 /* Convert dim to shift's kind, so we don't need so many variations. */
406 if (dim
->ts
.kind
!= shift
->ts
.kind
)
407 gfc_convert_type (dim
, &shift
->ts
, 2);
409 f
->value
.function
.name
=
410 gfc_get_string ("__cshift%d_%d", n
, shift
->ts
.kind
);
415 gfc_resolve_dble (gfc_expr
* f
, gfc_expr
* a
)
418 f
->ts
.type
= BT_REAL
;
419 f
->ts
.kind
= gfc_default_double_kind
;
420 f
->value
.function
.name
=
421 gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
426 gfc_resolve_dim (gfc_expr
* f
, gfc_expr
* x
,
427 gfc_expr
* y ATTRIBUTE_UNUSED
)
431 f
->value
.function
.name
=
432 gfc_get_string ("__dim_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
437 gfc_resolve_dot_product (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
441 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
443 f
->ts
.type
= BT_LOGICAL
;
444 f
->ts
.kind
= gfc_default_logical_kind
;
448 temp
.expr_type
= EXPR_OP
;
449 gfc_clear_ts (&temp
.ts
);
450 temp
.operator = INTRINSIC_NONE
;
453 gfc_type_convert_binary (&temp
);
457 f
->value
.function
.name
=
458 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f
->ts
.type
),
464 gfc_resolve_dprod (gfc_expr
* f
,
465 gfc_expr
* a ATTRIBUTE_UNUSED
,
466 gfc_expr
* b ATTRIBUTE_UNUSED
)
468 f
->ts
.kind
= gfc_default_double_kind
;
469 f
->ts
.type
= BT_REAL
;
471 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
476 gfc_resolve_eoshift (gfc_expr
* f
, gfc_expr
* array
,
484 f
->rank
= array
->rank
;
485 f
->shape
= gfc_copy_shape (array
->shape
, array
->rank
);
490 if (boundary
&& boundary
->rank
> 0)
493 /* Convert dim to the same type as shift, so we don't need quite so many
495 if (dim
!= NULL
&& dim
->ts
.kind
!= shift
->ts
.kind
)
496 gfc_convert_type (dim
, &shift
->ts
, 2);
498 f
->value
.function
.name
=
499 gfc_get_string ("__eoshift%d_%d", n
, shift
->ts
.kind
);
504 gfc_resolve_exp (gfc_expr
* f
, gfc_expr
* x
)
508 f
->value
.function
.name
=
509 gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
514 gfc_resolve_exponent (gfc_expr
* f
, gfc_expr
* x
)
517 f
->ts
.type
= BT_INTEGER
;
518 f
->ts
.kind
= gfc_default_integer_kind
;
520 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
525 gfc_resolve_floor (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
528 f
->ts
.type
= BT_INTEGER
;
529 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
530 : mpz_get_si (kind
->value
.integer
);
532 f
->value
.function
.name
=
533 gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
534 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
539 gfc_resolve_fraction (gfc_expr
* f
, gfc_expr
* x
)
543 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
548 gfc_resolve_iand (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j ATTRIBUTE_UNUSED
)
552 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
557 gfc_resolve_ibclr (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos ATTRIBUTE_UNUSED
)
561 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
566 gfc_resolve_ibits (gfc_expr
* f
, gfc_expr
* i
,
567 gfc_expr
* pos ATTRIBUTE_UNUSED
,
568 gfc_expr
* len ATTRIBUTE_UNUSED
)
572 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
577 gfc_resolve_ibset (gfc_expr
* f
, gfc_expr
* i
,
578 gfc_expr
* pos ATTRIBUTE_UNUSED
)
582 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
587 gfc_resolve_ichar (gfc_expr
* f
, gfc_expr
* c
)
590 f
->ts
.type
= BT_INTEGER
;
591 f
->ts
.kind
= gfc_default_integer_kind
;
593 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
598 gfc_resolve_idnint (gfc_expr
* f
, gfc_expr
* a
)
600 gfc_resolve_nint (f
, a
, NULL
);
605 gfc_resolve_ieor (gfc_expr
* f
, gfc_expr
* i
,
606 gfc_expr
* j ATTRIBUTE_UNUSED
)
610 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
615 gfc_resolve_ior (gfc_expr
* f
, gfc_expr
* i
,
616 gfc_expr
* j ATTRIBUTE_UNUSED
)
620 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
625 gfc_resolve_int (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
628 f
->ts
.type
= BT_INTEGER
;
629 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
630 : mpz_get_si (kind
->value
.integer
);
632 f
->value
.function
.name
=
633 gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
, gfc_type_letter (a
->ts
.type
),
639 gfc_resolve_ishft (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
)
643 f
->value
.function
.name
=
644 gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
649 gfc_resolve_ishftc (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
,
654 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: shift
->ts
.kind
;
657 f
->value
.function
.name
=
658 gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
663 gfc_resolve_lbound (gfc_expr
* f
, gfc_expr
* array
,
666 static char lbound
[] = "__lbound";
668 f
->ts
.type
= BT_INTEGER
;
669 f
->ts
.kind
= gfc_default_integer_kind
;
674 f
->shape
= gfc_get_shape (1);
675 mpz_init_set_ui (f
->shape
[0], array
->rank
);
678 f
->value
.function
.name
= lbound
;
683 gfc_resolve_len (gfc_expr
* f
, gfc_expr
* string
)
686 f
->ts
.type
= BT_INTEGER
;
687 f
->ts
.kind
= gfc_default_integer_kind
;
688 f
->value
.function
.name
= gfc_get_string ("__len_%d", string
->ts
.kind
);
693 gfc_resolve_len_trim (gfc_expr
* f
, gfc_expr
* string
)
696 f
->ts
.type
= BT_INTEGER
;
697 f
->ts
.kind
= gfc_default_integer_kind
;
698 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
703 gfc_resolve_log (gfc_expr
* f
, gfc_expr
* x
)
707 f
->value
.function
.name
=
708 gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
713 gfc_resolve_log10 (gfc_expr
* f
, gfc_expr
* x
)
717 f
->value
.function
.name
=
718 gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
723 gfc_resolve_logical (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
726 f
->ts
.type
= BT_LOGICAL
;
727 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_logical_kind
728 : mpz_get_si (kind
->value
.integer
);
731 f
->value
.function
.name
=
732 gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
733 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
738 gfc_resolve_matmul (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
742 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
744 f
->ts
.type
= BT_LOGICAL
;
745 f
->ts
.kind
= gfc_default_logical_kind
;
749 temp
.expr_type
= EXPR_OP
;
750 gfc_clear_ts (&temp
.ts
);
751 temp
.operator = INTRINSIC_NONE
;
754 gfc_type_convert_binary (&temp
);
758 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
760 f
->value
.function
.name
=
761 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f
->ts
.type
),
767 gfc_resolve_minmax (const char * name
, gfc_expr
* f
, gfc_actual_arglist
* args
)
769 gfc_actual_arglist
*a
;
771 f
->ts
.type
= args
->expr
->ts
.type
;
772 f
->ts
.kind
= args
->expr
->ts
.kind
;
773 /* Find the largest type kind. */
774 for (a
= args
->next
; a
; a
= a
->next
)
776 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
777 f
->ts
.kind
= a
->expr
->ts
.kind
;
780 /* Convert all parameters to the required kind. */
781 for (a
= args
; a
; a
= a
->next
)
783 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
784 gfc_convert_type (a
->expr
, &f
->ts
, 2);
787 f
->value
.function
.name
=
788 gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
793 gfc_resolve_max (gfc_expr
* f
, gfc_actual_arglist
* args
)
795 gfc_resolve_minmax ("__max_%c%d", f
, args
);
800 gfc_resolve_maxloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
805 f
->ts
.type
= BT_INTEGER
;
806 f
->ts
.kind
= gfc_default_integer_kind
;
812 f
->rank
= array
->rank
- 1;
813 gfc_resolve_index (dim
, 1);
816 name
= mask
? "mmaxloc" : "maxloc";
817 f
->value
.function
.name
=
818 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
819 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
824 gfc_resolve_maxval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
832 f
->rank
= array
->rank
- 1;
833 gfc_resolve_index (dim
, 1);
836 f
->value
.function
.name
=
837 gfc_get_string ("__%s_%c%d", mask
? "mmaxval" : "maxval",
838 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
843 gfc_resolve_merge (gfc_expr
* f
, gfc_expr
* tsource
,
844 gfc_expr
* fsource ATTRIBUTE_UNUSED
,
845 gfc_expr
* mask ATTRIBUTE_UNUSED
)
849 f
->value
.function
.name
=
850 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
856 gfc_resolve_min (gfc_expr
* f
, gfc_actual_arglist
* args
)
858 gfc_resolve_minmax ("__min_%c%d", f
, args
);
863 gfc_resolve_minloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
868 f
->ts
.type
= BT_INTEGER
;
869 f
->ts
.kind
= gfc_default_integer_kind
;
875 f
->rank
= array
->rank
- 1;
876 gfc_resolve_index (dim
, 1);
879 name
= mask
? "mminloc" : "minloc";
880 f
->value
.function
.name
=
881 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
882 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
887 gfc_resolve_minval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
895 f
->rank
= array
->rank
- 1;
896 gfc_resolve_index (dim
, 1);
899 f
->value
.function
.name
=
900 gfc_get_string ("__%s_%c%d", mask
? "mminval" : "minval",
901 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
906 gfc_resolve_mod (gfc_expr
* f
, gfc_expr
* a
,
907 gfc_expr
* p ATTRIBUTE_UNUSED
)
911 f
->value
.function
.name
=
912 gfc_get_string ("__mod_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
917 gfc_resolve_modulo (gfc_expr
* f
, gfc_expr
* a
,
918 gfc_expr
* p ATTRIBUTE_UNUSED
)
922 f
->value
.function
.name
=
923 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a
->ts
.type
),
928 gfc_resolve_nearest (gfc_expr
* f
, gfc_expr
* a
,
929 gfc_expr
*p ATTRIBUTE_UNUSED
)
933 f
->value
.function
.name
=
934 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
939 gfc_resolve_nint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
942 f
->ts
.type
= BT_INTEGER
;
943 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
944 : mpz_get_si (kind
->value
.integer
);
946 f
->value
.function
.name
=
947 gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
952 gfc_resolve_not (gfc_expr
* f
, gfc_expr
* i
)
956 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
961 gfc_resolve_pack (gfc_expr
* f
,
962 gfc_expr
* array ATTRIBUTE_UNUSED
,
963 gfc_expr
* mask ATTRIBUTE_UNUSED
,
964 gfc_expr
* vector ATTRIBUTE_UNUSED
)
966 static char pack
[] = "__pack";
971 f
->value
.function
.name
= pack
;
976 gfc_resolve_product (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
984 f
->rank
= array
->rank
- 1;
985 gfc_resolve_index (dim
, 1);
988 f
->value
.function
.name
=
989 gfc_get_string ("__%s_%c%d", mask
? "mproduct" : "product",
990 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
995 gfc_resolve_real (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
998 f
->ts
.type
= BT_REAL
;
1001 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1003 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
) ?
1004 a
->ts
.kind
: gfc_default_real_kind
;
1006 f
->value
.function
.name
=
1007 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1008 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1013 gfc_resolve_repeat (gfc_expr
* f
, gfc_expr
* string
,
1014 gfc_expr
* ncopies ATTRIBUTE_UNUSED
)
1017 f
->ts
.type
= BT_CHARACTER
;
1018 f
->ts
.kind
= string
->ts
.kind
;
1019 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1024 gfc_resolve_reshape (gfc_expr
* f
, gfc_expr
* source
, gfc_expr
* shape
,
1025 gfc_expr
* pad ATTRIBUTE_UNUSED
,
1026 gfc_expr
* order ATTRIBUTE_UNUSED
)
1028 static char reshape0
[] = "__reshape";
1035 gfc_array_size (shape
, &rank
);
1036 f
->rank
= mpz_get_si (rank
);
1038 switch (source
->ts
.type
)
1041 kind
= source
->ts
.kind
* 2;
1047 kind
= source
->ts
.kind
;
1060 f
->value
.function
.name
=
1061 gfc_get_string ("__reshape_%d", source
->ts
.kind
);
1065 f
->value
.function
.name
= reshape0
;
1069 /* TODO: Make this work with a constant ORDER parameter. */
1070 if (shape
->expr_type
== EXPR_ARRAY
1071 && gfc_is_constant_expr (shape
)
1075 f
->shape
= gfc_get_shape (f
->rank
);
1076 c
= shape
->value
.constructor
;
1077 for (i
= 0; i
< f
->rank
; i
++)
1079 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1087 gfc_resolve_rrspacing (gfc_expr
* f
, gfc_expr
* x
)
1091 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1096 gfc_resolve_scale (gfc_expr
* f
, gfc_expr
* x
,
1097 gfc_expr
* y ATTRIBUTE_UNUSED
)
1101 f
->value
.function
.name
= gfc_get_string ("__scale_%d_%d", x
->ts
.kind
,
1107 gfc_resolve_scan (gfc_expr
* f
, gfc_expr
* string
,
1108 gfc_expr
* set ATTRIBUTE_UNUSED
,
1109 gfc_expr
* back ATTRIBUTE_UNUSED
)
1112 f
->ts
.type
= BT_INTEGER
;
1113 f
->ts
.kind
= gfc_default_integer_kind
;
1114 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1119 gfc_resolve_set_exponent (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1123 f
->value
.function
.name
=
1124 gfc_get_string ("__set_exponent_%d_%d", x
->ts
.kind
, i
->ts
.kind
);
1129 gfc_resolve_shape (gfc_expr
* f
, gfc_expr
* array
)
1132 f
->ts
.type
= BT_INTEGER
;
1133 f
->ts
.kind
= gfc_default_integer_kind
;
1135 f
->value
.function
.name
= gfc_get_string ("__shape_%d", f
->ts
.kind
);
1136 f
->shape
= gfc_get_shape (1);
1137 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1142 gfc_resolve_sign (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b ATTRIBUTE_UNUSED
)
1146 f
->value
.function
.name
=
1147 gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1152 gfc_resolve_sin (gfc_expr
* f
, gfc_expr
* x
)
1156 f
->value
.function
.name
=
1157 gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1162 gfc_resolve_sinh (gfc_expr
* f
, gfc_expr
* x
)
1166 f
->value
.function
.name
=
1167 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1172 gfc_resolve_spacing (gfc_expr
* f
, gfc_expr
* x
)
1176 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1181 gfc_resolve_spread (gfc_expr
* f
, gfc_expr
* source
,
1185 static char spread
[] = "__spread";
1188 f
->rank
= source
->rank
+ 1;
1189 f
->value
.function
.name
= spread
;
1191 gfc_resolve_index (dim
, 1);
1192 gfc_resolve_index (ncopies
, 1);
1197 gfc_resolve_sqrt (gfc_expr
* f
, gfc_expr
* x
)
1201 f
->value
.function
.name
=
1202 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1207 gfc_resolve_sum (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1215 f
->rank
= array
->rank
- 1;
1216 gfc_resolve_index (dim
, 1);
1219 f
->value
.function
.name
=
1220 gfc_get_string ("__%s_%c%d", mask
? "msum" : "sum",
1221 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1226 gfc_resolve_tan (gfc_expr
* f
, gfc_expr
* x
)
1230 f
->value
.function
.name
=
1231 gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1236 gfc_resolve_tanh (gfc_expr
* f
, gfc_expr
* x
)
1240 f
->value
.function
.name
=
1241 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1246 gfc_resolve_transfer (gfc_expr
* f
, gfc_expr
* source ATTRIBUTE_UNUSED
,
1247 gfc_expr
* mold
, gfc_expr
* size
)
1249 /* TODO: Make this do something meaningful. */
1250 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
1254 if (size
== NULL
&& mold
->rank
== 0)
1257 f
->value
.function
.name
= transfer0
;
1262 f
->value
.function
.name
= transfer1
;
1268 gfc_resolve_transpose (gfc_expr
* f
, gfc_expr
* matrix
)
1270 static char transpose0
[] = "__transpose";
1277 f
->shape
= gfc_get_shape (2);
1278 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
1279 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
1282 switch (matrix
->ts
.type
)
1285 kind
= matrix
->ts
.kind
* 2;
1291 kind
= matrix
->ts
.kind
;
1305 f
->value
.function
.name
=
1306 gfc_get_string ("__transpose_%d", kind
);
1310 f
->value
.function
.name
= transpose0
;
1316 gfc_resolve_trim (gfc_expr
* f
, gfc_expr
* string
)
1319 f
->ts
.type
= BT_CHARACTER
;
1320 f
->ts
.kind
= string
->ts
.kind
;
1321 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
1326 gfc_resolve_ubound (gfc_expr
* f
, gfc_expr
* array
,
1329 static char ubound
[] = "__ubound";
1331 f
->ts
.type
= BT_INTEGER
;
1332 f
->ts
.kind
= gfc_default_integer_kind
;
1337 f
->shape
= gfc_get_shape (1);
1338 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1341 f
->value
.function
.name
= ubound
;
1346 gfc_resolve_unpack (gfc_expr
* f
, gfc_expr
* vector
, gfc_expr
* mask
,
1347 gfc_expr
* field ATTRIBUTE_UNUSED
)
1350 f
->ts
.type
= vector
->ts
.type
;
1351 f
->ts
.kind
= vector
->ts
.kind
;
1352 f
->rank
= mask
->rank
;
1354 f
->value
.function
.name
=
1355 gfc_get_string ("__unpack%d", field
->rank
> 0 ? 1 : 0);
1360 gfc_resolve_verify (gfc_expr
* f
, gfc_expr
* string
,
1361 gfc_expr
* set ATTRIBUTE_UNUSED
,
1362 gfc_expr
* back ATTRIBUTE_UNUSED
)
1365 f
->ts
.type
= BT_INTEGER
;
1366 f
->ts
.kind
= gfc_default_integer_kind
;
1367 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
1371 /* Intrinsic subroutine resolution. */
1374 gfc_resolve_cpu_time (gfc_code
* c ATTRIBUTE_UNUSED
)
1378 name
= gfc_get_string (PREFIX("cpu_time_%d"),
1379 c
->ext
.actual
->expr
->ts
.kind
);
1380 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1385 gfc_resolve_random_number (gfc_code
* c ATTRIBUTE_UNUSED
)
1390 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1391 if (c
->ext
.actual
->expr
->rank
== 0)
1392 name
= gfc_get_string (PREFIX("random_r%d"), kind
);
1394 name
= gfc_get_string (PREFIX("arandom_r%d"), kind
);
1396 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1401 /* G77 compatibility subroutines etime() and dtime(). */
1404 gfc_resolve_etime_sub (gfc_code
* c
)
1408 name
= gfc_get_string (PREFIX("etime_sub"));
1409 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1413 /* G77 compatibility subroutine second(). */
1416 gfc_resolve_second_sub (gfc_code
* c
)
1420 name
= gfc_get_string (PREFIX("second_sub"));
1421 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1425 /* G77 compatibility function srand(). */
1428 gfc_resolve_srand (gfc_code
* c
)
1431 name
= gfc_get_string (PREFIX("srand"));
1432 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1436 /* Resolve the getarg intrinsic subroutine. */
1439 gfc_resolve_getarg (gfc_code
* c
)
1444 kind
= gfc_default_integer_kind
;
1445 name
= gfc_get_string (PREFIX("getarg_i%d"), kind
);
1446 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1450 /* Resolve the get_command intrinsic subroutine. */
1453 gfc_resolve_get_command (gfc_code
* c
)
1458 kind
= gfc_default_integer_kind
;
1459 name
= gfc_get_string (PREFIX("get_command_i%d"), kind
);
1460 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1464 /* Resolve the get_command_argument intrinsic subroutine. */
1467 gfc_resolve_get_command_argument (gfc_code
* c
)
1472 kind
= gfc_default_integer_kind
;
1473 name
= gfc_get_string (PREFIX("get_command_argument_i%d"), kind
);
1474 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1477 /* Resolve the get_environment_variable intrinsic subroutine. */
1480 gfc_resolve_get_environment_variable (gfc_code
* code
)
1485 kind
= gfc_default_integer_kind
;
1486 name
= gfc_get_string (PREFIX("get_environment_variable_i%d"), kind
);
1487 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1491 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1494 gfc_resolve_system_clock (gfc_code
* c
)
1499 if (c
->ext
.actual
->expr
!= NULL
)
1500 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1501 else if (c
->ext
.actual
->next
->expr
!= NULL
)
1502 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1503 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1504 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1506 kind
= gfc_default_integer_kind
;
1508 name
= gfc_get_string (PREFIX("system_clock_%d"), kind
);
1509 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1513 gfc_iresolve_init_1 (void)
1517 for (i
= 0; i
< HASH_SIZE
; i
++)
1518 string_head
[i
] = NULL
;
1523 gfc_iresolve_done_1 (void)