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;
193 f
->value
.function
.name
=
194 gfc_get_string ("__all_%c%d", gfc_type_letter (mask
->ts
.type
),
200 gfc_resolve_anint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
203 f
->ts
.type
= a
->ts
.type
;
204 f
->ts
.kind
= (kind
== NULL
) ? a
->ts
.kind
: mpz_get_si (kind
->value
.integer
);
206 /* The resolved name is only used for specific intrinsics where
207 the return kind is the same as the arg kind. */
208 f
->value
.function
.name
=
209 gfc_get_string ("__anint_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
214 gfc_resolve_dnint (gfc_expr
* f
, gfc_expr
* a
)
216 gfc_resolve_anint (f
, a
, NULL
);
221 gfc_resolve_any (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
228 gfc_resolve_index (dim
, 1);
229 f
->rank
= mask
->rank
- 1;
232 f
->value
.function
.name
=
233 gfc_get_string ("__any_%c%d", gfc_type_letter (mask
->ts
.type
),
239 gfc_resolve_asin (gfc_expr
* f
, gfc_expr
* x
)
243 f
->value
.function
.name
=
244 gfc_get_string ("__asin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
249 gfc_resolve_atan (gfc_expr
* f
, gfc_expr
* x
)
253 f
->value
.function
.name
=
254 gfc_get_string ("__atan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
259 gfc_resolve_atan2 (gfc_expr
* f
, gfc_expr
* x
,
260 gfc_expr
* y ATTRIBUTE_UNUSED
)
264 f
->value
.function
.name
=
265 gfc_get_string ("__atan2_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
270 gfc_resolve_btest (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos
)
273 f
->ts
.type
= BT_LOGICAL
;
274 f
->ts
.kind
= gfc_default_logical_kind ();
276 f
->value
.function
.name
= gfc_get_string ("__btest_%d_%d", i
->ts
.kind
,
282 gfc_resolve_ceiling (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
285 f
->ts
.type
= BT_INTEGER
;
286 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind ()
287 : mpz_get_si (kind
->value
.integer
);
289 f
->value
.function
.name
=
290 gfc_get_string ("__ceiling_%d_%c%d", f
->ts
.kind
,
291 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
296 gfc_resolve_char (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
299 f
->ts
.type
= BT_CHARACTER
;
300 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_character_kind ()
301 : mpz_get_si (kind
->value
.integer
);
303 f
->value
.function
.name
=
304 gfc_get_string ("__char_%d_%c%d", f
->ts
.kind
,
305 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
310 gfc_resolve_cmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
, gfc_expr
* kind
)
313 f
->ts
.type
= BT_COMPLEX
;
314 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_real_kind ()
315 : mpz_get_si (kind
->value
.integer
);
318 f
->value
.function
.name
=
319 gfc_get_string ("__cmplx0_%d_%c%d", f
->ts
.kind
,
320 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
322 f
->value
.function
.name
=
323 gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f
->ts
.kind
,
324 gfc_type_letter (x
->ts
.type
), x
->ts
.kind
,
325 gfc_type_letter (y
->ts
.type
), y
->ts
.kind
);
329 gfc_resolve_dcmplx (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* y
)
331 gfc_resolve_cmplx (f
, x
, y
, gfc_int_expr (gfc_default_double_kind ()));
335 gfc_resolve_conjg (gfc_expr
* f
, gfc_expr
* x
)
339 f
->value
.function
.name
= gfc_get_string ("__conjg_%d", x
->ts
.kind
);
344 gfc_resolve_cos (gfc_expr
* f
, gfc_expr
* x
)
348 f
->value
.function
.name
=
349 gfc_get_string ("__cos_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
354 gfc_resolve_cosh (gfc_expr
* f
, gfc_expr
* x
)
358 f
->value
.function
.name
=
359 gfc_get_string ("__cosh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
364 gfc_resolve_count (gfc_expr
* f
, gfc_expr
* mask
, gfc_expr
* dim
)
367 f
->ts
.type
= BT_INTEGER
;
368 f
->ts
.kind
= gfc_default_integer_kind ();
372 f
->rank
= mask
->rank
- 1;
373 gfc_resolve_index (dim
, 1);
376 f
->value
.function
.name
=
377 gfc_get_string ("__count_%d_%c%d", f
->ts
.kind
,
378 gfc_type_letter (mask
->ts
.type
), mask
->ts
.kind
);
383 gfc_resolve_cshift (gfc_expr
* f
, gfc_expr
* array
,
390 f
->rank
= array
->rank
;
399 gfc_resolve_index (dim
, 1);
400 /* Convert dim to shift's kind, so we don't need so many variations. */
401 if (dim
->ts
.kind
!= shift
->ts
.kind
)
402 gfc_convert_type (dim
, &shift
->ts
, 2);
404 f
->value
.function
.name
=
405 gfc_get_string ("__cshift%d_%d", n
, shift
->ts
.kind
);
410 gfc_resolve_dble (gfc_expr
* f
, gfc_expr
* a
)
413 f
->ts
.type
= BT_REAL
;
414 f
->ts
.kind
= gfc_default_double_kind ();
415 f
->value
.function
.name
=
416 gfc_get_string ("__dble_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
421 gfc_resolve_dim (gfc_expr
* f
, gfc_expr
* x
,
422 gfc_expr
* y ATTRIBUTE_UNUSED
)
426 f
->value
.function
.name
=
427 gfc_get_string ("__dim_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
432 gfc_resolve_dot_product (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
436 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
438 f
->ts
.type
= BT_LOGICAL
;
439 f
->ts
.kind
= gfc_default_logical_kind ();
443 temp
.expr_type
= EXPR_OP
;
444 gfc_clear_ts (&temp
.ts
);
445 temp
.operator = INTRINSIC_NONE
;
448 gfc_type_convert_binary (&temp
);
452 f
->value
.function
.name
=
453 gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f
->ts
.type
),
459 gfc_resolve_dprod (gfc_expr
* f
,
460 gfc_expr
* a ATTRIBUTE_UNUSED
,
461 gfc_expr
* b ATTRIBUTE_UNUSED
)
463 f
->ts
.kind
= gfc_default_double_kind ();
464 f
->ts
.type
= BT_REAL
;
466 f
->value
.function
.name
= gfc_get_string ("__dprod_r%d", f
->ts
.kind
);
471 gfc_resolve_eoshift (gfc_expr
* f
, gfc_expr
* array
,
479 f
->rank
= array
->rank
;
484 if (boundary
&& boundary
->rank
> 0)
487 /* Convert dim to the same type as shift, so we don't need quite so many
489 if (dim
!= NULL
&& dim
->ts
.kind
!= shift
->ts
.kind
)
490 gfc_convert_type (dim
, &shift
->ts
, 2);
492 f
->value
.function
.name
=
493 gfc_get_string ("__eoshift%d_%d", n
, shift
->ts
.kind
);
498 gfc_resolve_exp (gfc_expr
* f
, gfc_expr
* x
)
502 f
->value
.function
.name
=
503 gfc_get_string ("__exp_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
508 gfc_resolve_exponent (gfc_expr
* f
, gfc_expr
* x
)
511 f
->ts
.type
= BT_INTEGER
;
512 f
->ts
.kind
= gfc_default_integer_kind ();
514 f
->value
.function
.name
= gfc_get_string ("__exponent_%d", x
->ts
.kind
);
519 gfc_resolve_floor (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
522 f
->ts
.type
= BT_INTEGER
;
523 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind ()
524 : mpz_get_si (kind
->value
.integer
);
526 f
->value
.function
.name
=
527 gfc_get_string ("__floor%d_%c%d", f
->ts
.kind
,
528 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
533 gfc_resolve_fraction (gfc_expr
* f
, gfc_expr
* x
)
537 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
542 gfc_resolve_iand (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j ATTRIBUTE_UNUSED
)
546 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
551 gfc_resolve_ibclr (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos ATTRIBUTE_UNUSED
)
555 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
560 gfc_resolve_ibits (gfc_expr
* f
, gfc_expr
* i
,
561 gfc_expr
* pos ATTRIBUTE_UNUSED
,
562 gfc_expr
* len ATTRIBUTE_UNUSED
)
566 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
571 gfc_resolve_ibset (gfc_expr
* f
, gfc_expr
* i
,
572 gfc_expr
* pos ATTRIBUTE_UNUSED
)
576 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
581 gfc_resolve_ichar (gfc_expr
* f
, gfc_expr
* c
)
584 f
->ts
.type
= BT_INTEGER
;
585 f
->ts
.kind
= gfc_default_integer_kind ();
587 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
592 gfc_resolve_idnint (gfc_expr
* f
, gfc_expr
* a
)
594 gfc_resolve_nint (f
, a
, NULL
);
599 gfc_resolve_ieor (gfc_expr
* f
, gfc_expr
* i
,
600 gfc_expr
* j ATTRIBUTE_UNUSED
)
604 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
609 gfc_resolve_ior (gfc_expr
* f
, gfc_expr
* i
,
610 gfc_expr
* j ATTRIBUTE_UNUSED
)
614 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
619 gfc_resolve_int (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
622 f
->ts
.type
= BT_INTEGER
;
623 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind ()
624 : mpz_get_si (kind
->value
.integer
);
626 f
->value
.function
.name
=
627 gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
, gfc_type_letter (a
->ts
.type
),
633 gfc_resolve_ishft (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
)
637 f
->value
.function
.name
=
638 gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
643 gfc_resolve_ishftc (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
,
648 s_kind
= (size
== NULL
) ? gfc_default_integer_kind () : shift
->ts
.kind
;
651 f
->value
.function
.name
=
652 gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
657 gfc_resolve_lbound (gfc_expr
* f
, gfc_expr
* array ATTRIBUTE_UNUSED
,
660 static char lbound
[] = "__lbound";
662 f
->ts
.type
= BT_INTEGER
;
663 f
->ts
.kind
= gfc_default_integer_kind ();
665 f
->rank
= (dim
== NULL
) ? 1 : 0;
666 f
->value
.function
.name
= lbound
;
671 gfc_resolve_len (gfc_expr
* f
, gfc_expr
* string
)
674 f
->ts
.type
= BT_INTEGER
;
675 f
->ts
.kind
= gfc_default_integer_kind ();
676 f
->value
.function
.name
= gfc_get_string ("__len_%d", string
->ts
.kind
);
681 gfc_resolve_len_trim (gfc_expr
* f
, gfc_expr
* string
)
684 f
->ts
.type
= BT_INTEGER
;
685 f
->ts
.kind
= gfc_default_integer_kind ();
686 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
691 gfc_resolve_log (gfc_expr
* f
, gfc_expr
* x
)
695 f
->value
.function
.name
=
696 gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
701 gfc_resolve_log10 (gfc_expr
* f
, gfc_expr
* x
)
705 f
->value
.function
.name
=
706 gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
711 gfc_resolve_logical (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
714 f
->ts
.type
= BT_LOGICAL
;
715 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_logical_kind ()
716 : mpz_get_si (kind
->value
.integer
);
719 f
->value
.function
.name
=
720 gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
721 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
726 gfc_resolve_matmul (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
730 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
732 f
->ts
.type
= BT_LOGICAL
;
733 f
->ts
.kind
= gfc_default_logical_kind ();
737 temp
.expr_type
= EXPR_OP
;
738 gfc_clear_ts (&temp
.ts
);
739 temp
.operator = INTRINSIC_NONE
;
742 gfc_type_convert_binary (&temp
);
746 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
748 f
->value
.function
.name
=
749 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f
->ts
.type
),
755 gfc_resolve_minmax (const char * name
, gfc_expr
* f
, gfc_actual_arglist
* args
)
757 gfc_actual_arglist
*a
;
759 f
->ts
.type
= args
->expr
->ts
.type
;
760 f
->ts
.kind
= args
->expr
->ts
.kind
;
761 /* Find the largest type kind. */
762 for (a
= args
->next
; a
; a
= a
->next
)
764 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
765 f
->ts
.kind
= a
->expr
->ts
.kind
;
768 /* Convert all parameters to the required kind. */
769 for (a
= args
; a
; a
= a
->next
)
771 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
772 gfc_convert_type (a
->expr
, &f
->ts
, 2);
775 f
->value
.function
.name
=
776 gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
781 gfc_resolve_max (gfc_expr
* f
, gfc_actual_arglist
* args
)
783 gfc_resolve_minmax ("__max_%c%d", f
, args
);
788 gfc_resolve_maxloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
793 f
->ts
.type
= BT_INTEGER
;
794 f
->ts
.kind
= gfc_default_integer_kind ();
800 f
->rank
= array
->rank
- 1;
801 gfc_resolve_index (dim
, 1);
804 name
= mask
? "mmaxloc" : "maxloc";
805 f
->value
.function
.name
=
806 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
807 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
812 gfc_resolve_maxval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
820 f
->rank
= array
->rank
- 1;
821 gfc_resolve_index (dim
, 1);
824 f
->value
.function
.name
=
825 gfc_get_string ("__%s_%c%d", mask
? "mmaxval" : "maxval",
826 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
831 gfc_resolve_merge (gfc_expr
* f
, gfc_expr
* tsource
,
832 gfc_expr
* fsource ATTRIBUTE_UNUSED
,
833 gfc_expr
* mask ATTRIBUTE_UNUSED
)
837 f
->value
.function
.name
=
838 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
844 gfc_resolve_min (gfc_expr
* f
, gfc_actual_arglist
* args
)
846 gfc_resolve_minmax ("__min_%c%d", f
, args
);
851 gfc_resolve_minloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
856 f
->ts
.type
= BT_INTEGER
;
857 f
->ts
.kind
= gfc_default_integer_kind ();
863 f
->rank
= array
->rank
- 1;
864 gfc_resolve_index (dim
, 1);
867 name
= mask
? "mminloc" : "minloc";
868 f
->value
.function
.name
=
869 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
870 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
874 gfc_resolve_minval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
882 f
->rank
= array
->rank
- 1;
883 gfc_resolve_index (dim
, 1);
886 f
->value
.function
.name
=
887 gfc_get_string ("__%s_%c%d", mask
? "mminval" : "minval",
888 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
893 gfc_resolve_mod (gfc_expr
* f
, gfc_expr
* a
,
894 gfc_expr
* p ATTRIBUTE_UNUSED
)
898 f
->value
.function
.name
=
899 gfc_get_string ("__mod_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
904 gfc_resolve_modulo (gfc_expr
* f
, gfc_expr
* a
,
905 gfc_expr
* p ATTRIBUTE_UNUSED
)
909 f
->value
.function
.name
=
910 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a
->ts
.type
),
915 gfc_resolve_nearest (gfc_expr
* f
, gfc_expr
* a
,
916 gfc_expr
*p ATTRIBUTE_UNUSED
)
920 f
->value
.function
.name
=
921 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
926 gfc_resolve_nint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
929 f
->ts
.type
= BT_INTEGER
;
930 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind ()
931 : mpz_get_si (kind
->value
.integer
);
933 f
->value
.function
.name
=
934 gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
939 gfc_resolve_not (gfc_expr
* f
, gfc_expr
* i
)
943 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
948 gfc_resolve_pack (gfc_expr
* f
,
949 gfc_expr
* array ATTRIBUTE_UNUSED
,
950 gfc_expr
* mask ATTRIBUTE_UNUSED
,
951 gfc_expr
* vector ATTRIBUTE_UNUSED
)
953 static char pack
[] = "__pack";
958 f
->value
.function
.name
= pack
;
963 gfc_resolve_product (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
971 f
->rank
= array
->rank
- 1;
972 gfc_resolve_index (dim
, 1);
975 f
->value
.function
.name
=
976 gfc_get_string ("__%s_%c%d", mask
? "mproduct" : "product",
977 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
982 gfc_resolve_real (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
985 f
->ts
.type
= BT_REAL
;
988 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
990 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
) ?
991 a
->ts
.kind
: gfc_default_real_kind ();
993 f
->value
.function
.name
=
994 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
995 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1000 gfc_resolve_repeat (gfc_expr
* f
, gfc_expr
* string
,
1001 gfc_expr
* ncopies ATTRIBUTE_UNUSED
)
1004 f
->ts
.type
= BT_CHARACTER
;
1005 f
->ts
.kind
= string
->ts
.kind
;
1006 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1011 gfc_resolve_reshape (gfc_expr
* f
, gfc_expr
* source
, gfc_expr
* shape
,
1012 gfc_expr
* pad ATTRIBUTE_UNUSED
,
1013 gfc_expr
* order ATTRIBUTE_UNUSED
)
1015 static char reshape0
[] = "__reshape";
1022 gfc_array_size (shape
, &rank
);
1023 f
->rank
= mpz_get_si (rank
);
1025 switch (source
->ts
.type
)
1028 kind
= source
->ts
.kind
* 2;
1034 kind
= source
->ts
.kind
;
1047 f
->value
.function
.name
=
1048 gfc_get_string ("__reshape_%d", source
->ts
.kind
);
1052 f
->value
.function
.name
= reshape0
;
1056 /* TODO: Make this work with a constant ORDER parameter. */
1057 if (shape
->expr_type
== EXPR_ARRAY
1058 && gfc_is_constant_expr (shape
)
1062 f
->shape
= gfc_get_shape (f
->rank
);
1063 c
= shape
->value
.constructor
;
1064 for (i
= 0; i
< f
->rank
; i
++)
1066 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1074 gfc_resolve_rrspacing (gfc_expr
* f
, gfc_expr
* x
)
1078 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1083 gfc_resolve_scale (gfc_expr
* f
, gfc_expr
* x
,
1084 gfc_expr
* y ATTRIBUTE_UNUSED
)
1088 f
->value
.function
.name
= gfc_get_string ("__scale_%d_%d", x
->ts
.kind
,
1094 gfc_resolve_scan (gfc_expr
* f
, gfc_expr
* string
,
1095 gfc_expr
* set ATTRIBUTE_UNUSED
,
1096 gfc_expr
* back ATTRIBUTE_UNUSED
)
1099 f
->ts
.type
= BT_INTEGER
;
1100 f
->ts
.kind
= gfc_default_integer_kind ();
1101 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1106 gfc_resolve_set_exponent (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1110 f
->value
.function
.name
=
1111 gfc_get_string ("__set_exponent_%d_%d", x
->ts
.kind
, i
->ts
.kind
);
1116 gfc_resolve_shape (gfc_expr
* f
, gfc_expr
* array
)
1119 f
->ts
.type
= BT_INTEGER
;
1120 f
->ts
.kind
= gfc_default_integer_kind ();
1122 f
->value
.function
.name
= gfc_get_string ("__shape_%d", f
->ts
.kind
);
1123 f
->shape
= gfc_get_shape (1);
1124 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1129 gfc_resolve_sign (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b ATTRIBUTE_UNUSED
)
1133 f
->value
.function
.name
=
1134 gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1139 gfc_resolve_sin (gfc_expr
* f
, gfc_expr
* x
)
1143 f
->value
.function
.name
=
1144 gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1149 gfc_resolve_sinh (gfc_expr
* f
, gfc_expr
* x
)
1153 f
->value
.function
.name
=
1154 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1159 gfc_resolve_spacing (gfc_expr
* f
, gfc_expr
* x
)
1163 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1168 gfc_resolve_spread (gfc_expr
* f
, gfc_expr
* source
,
1172 static char spread
[] = "__spread";
1175 f
->rank
= source
->rank
+ 1;
1176 f
->value
.function
.name
= spread
;
1178 gfc_resolve_index (dim
, 1);
1179 gfc_resolve_index (ncopies
, 1);
1184 gfc_resolve_sqrt (gfc_expr
* f
, gfc_expr
* x
)
1188 f
->value
.function
.name
=
1189 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1194 gfc_resolve_sum (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1202 f
->rank
= array
->rank
- 1;
1203 gfc_resolve_index (dim
, 1);
1206 f
->value
.function
.name
=
1207 gfc_get_string ("__%s_%c%d", mask
? "msum" : "sum",
1208 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1213 gfc_resolve_tan (gfc_expr
* f
, gfc_expr
* x
)
1217 f
->value
.function
.name
=
1218 gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1223 gfc_resolve_tanh (gfc_expr
* f
, gfc_expr
* x
)
1227 f
->value
.function
.name
=
1228 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1233 gfc_resolve_transfer (gfc_expr
* f
, gfc_expr
* source ATTRIBUTE_UNUSED
,
1234 gfc_expr
* mold
, gfc_expr
* size
)
1236 /* TODO: Make this do something meaningful. */
1237 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
1241 if (size
== NULL
&& mold
->rank
== 0)
1244 f
->value
.function
.name
= transfer0
;
1249 f
->value
.function
.name
= transfer1
;
1255 gfc_resolve_transpose (gfc_expr
* f
, gfc_expr
* matrix
)
1257 static char transpose0
[] = "__transpose";
1263 switch (matrix
->ts
.type
)
1266 kind
= matrix
->ts
.kind
* 2;
1272 kind
= matrix
->ts
.kind
;
1286 f
->value
.function
.name
=
1287 gfc_get_string ("__transpose_%d", kind
);
1291 f
->value
.function
.name
= transpose0
;
1297 gfc_resolve_trim (gfc_expr
* f
, gfc_expr
* string
)
1300 f
->ts
.type
= BT_CHARACTER
;
1301 f
->ts
.kind
= string
->ts
.kind
;
1302 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
1307 gfc_resolve_ubound (gfc_expr
* f
, gfc_expr
* array ATTRIBUTE_UNUSED
,
1310 static char ubound
[] = "__ubound";
1312 f
->ts
.type
= BT_INTEGER
;
1313 f
->ts
.kind
= gfc_default_integer_kind ();
1315 f
->rank
= (dim
== NULL
) ? 1 : 0;
1316 f
->value
.function
.name
= ubound
;
1321 gfc_resolve_unpack (gfc_expr
* f
, gfc_expr
* vector
, gfc_expr
* mask
,
1322 gfc_expr
* field ATTRIBUTE_UNUSED
)
1325 f
->ts
.type
= vector
->ts
.type
;
1326 f
->ts
.kind
= vector
->ts
.kind
;
1327 f
->rank
= mask
->rank
;
1329 f
->value
.function
.name
=
1330 gfc_get_string ("__unpack%d", field
->rank
> 0 ? 1 : 0);
1335 gfc_resolve_verify (gfc_expr
* f
, gfc_expr
* string
,
1336 gfc_expr
* set ATTRIBUTE_UNUSED
,
1337 gfc_expr
* back ATTRIBUTE_UNUSED
)
1340 f
->ts
.type
= BT_INTEGER
;
1341 f
->ts
.kind
= gfc_default_integer_kind ();
1342 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
1346 /* Intrinsic subroutine resolution. */
1349 gfc_resolve_cpu_time (gfc_code
* c ATTRIBUTE_UNUSED
)
1353 name
= gfc_get_string (PREFIX("cpu_time_%d"),
1354 c
->ext
.actual
->expr
->ts
.kind
);
1355 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1360 gfc_resolve_random_number (gfc_code
* c ATTRIBUTE_UNUSED
)
1365 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1366 if (c
->ext
.actual
->expr
->rank
== 0)
1367 name
= gfc_get_string (PREFIX("random_r%d"), kind
);
1369 name
= gfc_get_string (PREFIX("arandom_r%d"), kind
);
1371 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1375 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1378 gfc_resolve_system_clock (gfc_code
* c
)
1383 if (c
->ext
.actual
->expr
!= NULL
)
1384 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1385 else if (c
->ext
.actual
->next
->expr
!= NULL
)
1386 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1387 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1388 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1390 kind
= gfc_default_integer_kind ();
1392 name
= gfc_get_string (PREFIX("system_clock_%d"), kind
);
1393 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1398 gfc_iresolve_init_1 (void)
1402 for (i
= 0; i
< HASH_SIZE
; i
++)
1403 string_head
[i
] = NULL
;
1408 gfc_iresolve_done_1 (void)