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_fraction (gfc_expr
* f
, gfc_expr
* x
)
560 f
->value
.function
.name
= gfc_get_string ("__fraction_%d", x
->ts
.kind
);
564 /* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */
567 gfc_resolve_g77_math1 (gfc_expr
* f
, gfc_expr
* x
)
570 f
->value
.function
.name
= gfc_get_string ("<intrinsic>");
575 gfc_resolve_getgid (gfc_expr
* f
)
577 f
->ts
.type
= BT_INTEGER
;
579 f
->value
.function
.name
= gfc_get_string (PREFIX("getgid"));
584 gfc_resolve_getpid (gfc_expr
* f
)
586 f
->ts
.type
= BT_INTEGER
;
588 f
->value
.function
.name
= gfc_get_string (PREFIX("getpid"));
593 gfc_resolve_getuid (gfc_expr
* f
)
595 f
->ts
.type
= BT_INTEGER
;
597 f
->value
.function
.name
= gfc_get_string (PREFIX("getuid"));
601 gfc_resolve_iand (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* j ATTRIBUTE_UNUSED
)
605 f
->value
.function
.name
= gfc_get_string ("__iand_%d", i
->ts
.kind
);
610 gfc_resolve_ibclr (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* pos ATTRIBUTE_UNUSED
)
614 f
->value
.function
.name
= gfc_get_string ("__ibclr_%d", i
->ts
.kind
);
619 gfc_resolve_ibits (gfc_expr
* f
, gfc_expr
* i
,
620 gfc_expr
* pos ATTRIBUTE_UNUSED
,
621 gfc_expr
* len ATTRIBUTE_UNUSED
)
625 f
->value
.function
.name
= gfc_get_string ("__ibits_%d", i
->ts
.kind
);
630 gfc_resolve_ibset (gfc_expr
* f
, gfc_expr
* i
,
631 gfc_expr
* pos ATTRIBUTE_UNUSED
)
635 f
->value
.function
.name
= gfc_get_string ("__ibset_%d", i
->ts
.kind
);
640 gfc_resolve_ichar (gfc_expr
* f
, gfc_expr
* c
)
643 f
->ts
.type
= BT_INTEGER
;
644 f
->ts
.kind
= gfc_default_integer_kind
;
646 f
->value
.function
.name
= gfc_get_string ("__ichar_%d", c
->ts
.kind
);
651 gfc_resolve_idnint (gfc_expr
* f
, gfc_expr
* a
)
653 gfc_resolve_nint (f
, a
, NULL
);
658 gfc_resolve_ieor (gfc_expr
* f
, gfc_expr
* i
,
659 gfc_expr
* j ATTRIBUTE_UNUSED
)
663 f
->value
.function
.name
= gfc_get_string ("__ieor_%d", i
->ts
.kind
);
668 gfc_resolve_ior (gfc_expr
* f
, gfc_expr
* i
,
669 gfc_expr
* j ATTRIBUTE_UNUSED
)
673 f
->value
.function
.name
= gfc_get_string ("__ior_%d", i
->ts
.kind
);
678 gfc_resolve_int (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
681 f
->ts
.type
= BT_INTEGER
;
682 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
683 : mpz_get_si (kind
->value
.integer
);
685 f
->value
.function
.name
=
686 gfc_get_string ("__int_%d_%c%d", f
->ts
.kind
, gfc_type_letter (a
->ts
.type
),
692 gfc_resolve_ishft (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
)
696 f
->value
.function
.name
=
697 gfc_get_string ("__ishft_%d_%d", i
->ts
.kind
, shift
->ts
.kind
);
702 gfc_resolve_ishftc (gfc_expr
* f
, gfc_expr
* i
, gfc_expr
* shift
,
707 s_kind
= (size
== NULL
) ? gfc_default_integer_kind
: shift
->ts
.kind
;
710 f
->value
.function
.name
=
711 gfc_get_string ("__ishftc_%d_%d_%d", i
->ts
.kind
, shift
->ts
.kind
, s_kind
);
716 gfc_resolve_lbound (gfc_expr
* f
, gfc_expr
* array
,
719 static char lbound
[] = "__lbound";
721 f
->ts
.type
= BT_INTEGER
;
722 f
->ts
.kind
= gfc_default_integer_kind
;
727 f
->shape
= gfc_get_shape (1);
728 mpz_init_set_ui (f
->shape
[0], array
->rank
);
731 f
->value
.function
.name
= lbound
;
736 gfc_resolve_len (gfc_expr
* f
, gfc_expr
* string
)
739 f
->ts
.type
= BT_INTEGER
;
740 f
->ts
.kind
= gfc_default_integer_kind
;
741 f
->value
.function
.name
= gfc_get_string ("__len_%d", string
->ts
.kind
);
746 gfc_resolve_len_trim (gfc_expr
* f
, gfc_expr
* string
)
749 f
->ts
.type
= BT_INTEGER
;
750 f
->ts
.kind
= gfc_default_integer_kind
;
751 f
->value
.function
.name
= gfc_get_string ("__len_trim%d", string
->ts
.kind
);
756 gfc_resolve_log (gfc_expr
* f
, gfc_expr
* x
)
760 f
->value
.function
.name
=
761 gfc_get_string ("__log_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
766 gfc_resolve_log10 (gfc_expr
* f
, gfc_expr
* x
)
770 f
->value
.function
.name
=
771 gfc_get_string ("__log10_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
776 gfc_resolve_logical (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
779 f
->ts
.type
= BT_LOGICAL
;
780 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_logical_kind
781 : mpz_get_si (kind
->value
.integer
);
784 f
->value
.function
.name
=
785 gfc_get_string ("__logical_%d_%c%d", f
->ts
.kind
,
786 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
791 gfc_resolve_matmul (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b
)
795 if (a
->ts
.type
== BT_LOGICAL
&& b
->ts
.type
== BT_LOGICAL
)
797 f
->ts
.type
= BT_LOGICAL
;
798 f
->ts
.kind
= gfc_default_logical_kind
;
802 temp
.expr_type
= EXPR_OP
;
803 gfc_clear_ts (&temp
.ts
);
804 temp
.operator = INTRINSIC_NONE
;
807 gfc_type_convert_binary (&temp
);
811 f
->rank
= (a
->rank
== 2 && b
->rank
== 2) ? 2 : 1;
813 f
->value
.function
.name
=
814 gfc_get_string ("__matmul_%c%d", gfc_type_letter (f
->ts
.type
),
820 gfc_resolve_minmax (const char * name
, gfc_expr
* f
, gfc_actual_arglist
* args
)
822 gfc_actual_arglist
*a
;
824 f
->ts
.type
= args
->expr
->ts
.type
;
825 f
->ts
.kind
= args
->expr
->ts
.kind
;
826 /* Find the largest type kind. */
827 for (a
= args
->next
; a
; a
= a
->next
)
829 if (a
->expr
->ts
.kind
> f
->ts
.kind
)
830 f
->ts
.kind
= a
->expr
->ts
.kind
;
833 /* Convert all parameters to the required kind. */
834 for (a
= args
; a
; a
= a
->next
)
836 if (a
->expr
->ts
.kind
!= f
->ts
.kind
)
837 gfc_convert_type (a
->expr
, &f
->ts
, 2);
840 f
->value
.function
.name
=
841 gfc_get_string (name
, gfc_type_letter (f
->ts
.type
), f
->ts
.kind
);
846 gfc_resolve_max (gfc_expr
* f
, gfc_actual_arglist
* args
)
848 gfc_resolve_minmax ("__max_%c%d", f
, args
);
853 gfc_resolve_maxloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
858 f
->ts
.type
= BT_INTEGER
;
859 f
->ts
.kind
= gfc_default_integer_kind
;
865 f
->rank
= array
->rank
- 1;
866 gfc_resolve_index (dim
, 1);
869 name
= mask
? "mmaxloc" : "maxloc";
870 f
->value
.function
.name
=
871 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
872 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
877 gfc_resolve_maxval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
885 f
->rank
= array
->rank
- 1;
886 gfc_resolve_index (dim
, 1);
889 f
->value
.function
.name
=
890 gfc_get_string ("__%s_%c%d", mask
? "mmaxval" : "maxval",
891 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
896 gfc_resolve_merge (gfc_expr
* f
, gfc_expr
* tsource
,
897 gfc_expr
* fsource ATTRIBUTE_UNUSED
,
898 gfc_expr
* mask ATTRIBUTE_UNUSED
)
902 f
->value
.function
.name
=
903 gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource
->ts
.type
),
909 gfc_resolve_min (gfc_expr
* f
, gfc_actual_arglist
* args
)
911 gfc_resolve_minmax ("__min_%c%d", f
, args
);
916 gfc_resolve_minloc (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
921 f
->ts
.type
= BT_INTEGER
;
922 f
->ts
.kind
= gfc_default_integer_kind
;
928 f
->rank
= array
->rank
- 1;
929 gfc_resolve_index (dim
, 1);
932 name
= mask
? "mminloc" : "minloc";
933 f
->value
.function
.name
=
934 gfc_get_string ("__%s%d_%d_%c%d", name
, dim
!= NULL
, f
->ts
.kind
,
935 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
940 gfc_resolve_minval (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
948 f
->rank
= array
->rank
- 1;
949 gfc_resolve_index (dim
, 1);
952 f
->value
.function
.name
=
953 gfc_get_string ("__%s_%c%d", mask
? "mminval" : "minval",
954 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
959 gfc_resolve_mod (gfc_expr
* f
, gfc_expr
* a
,
960 gfc_expr
* p ATTRIBUTE_UNUSED
)
964 f
->value
.function
.name
=
965 gfc_get_string ("__mod_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
970 gfc_resolve_modulo (gfc_expr
* f
, gfc_expr
* a
,
971 gfc_expr
* p ATTRIBUTE_UNUSED
)
975 f
->value
.function
.name
=
976 gfc_get_string ("__modulo_%c%d", gfc_type_letter (a
->ts
.type
),
981 gfc_resolve_nearest (gfc_expr
* f
, gfc_expr
* a
,
982 gfc_expr
*p ATTRIBUTE_UNUSED
)
986 f
->value
.function
.name
=
987 gfc_get_string ("__nearest_%c%d", gfc_type_letter (a
->ts
.type
),
992 gfc_resolve_nint (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
995 f
->ts
.type
= BT_INTEGER
;
996 f
->ts
.kind
= (kind
== NULL
) ? gfc_default_integer_kind
997 : mpz_get_si (kind
->value
.integer
);
999 f
->value
.function
.name
=
1000 gfc_get_string ("__nint_%d_%d", f
->ts
.kind
, a
->ts
.kind
);
1005 gfc_resolve_not (gfc_expr
* f
, gfc_expr
* i
)
1009 f
->value
.function
.name
= gfc_get_string ("__not_%d", i
->ts
.kind
);
1014 gfc_resolve_pack (gfc_expr
* f
,
1015 gfc_expr
* array ATTRIBUTE_UNUSED
,
1016 gfc_expr
* mask ATTRIBUTE_UNUSED
,
1017 gfc_expr
* vector ATTRIBUTE_UNUSED
)
1019 static char pack
[] = "__pack";
1024 f
->value
.function
.name
= pack
;
1029 gfc_resolve_product (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1037 f
->rank
= array
->rank
- 1;
1038 gfc_resolve_index (dim
, 1);
1041 f
->value
.function
.name
=
1042 gfc_get_string ("__%s_%c%d", mask
? "mproduct" : "product",
1043 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1048 gfc_resolve_real (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* kind
)
1051 f
->ts
.type
= BT_REAL
;
1054 f
->ts
.kind
= mpz_get_si (kind
->value
.integer
);
1056 f
->ts
.kind
= (a
->ts
.type
== BT_COMPLEX
) ?
1057 a
->ts
.kind
: gfc_default_real_kind
;
1059 f
->value
.function
.name
=
1060 gfc_get_string ("__real_%d_%c%d", f
->ts
.kind
,
1061 gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1066 gfc_resolve_repeat (gfc_expr
* f
, gfc_expr
* string
,
1067 gfc_expr
* ncopies ATTRIBUTE_UNUSED
)
1070 f
->ts
.type
= BT_CHARACTER
;
1071 f
->ts
.kind
= string
->ts
.kind
;
1072 f
->value
.function
.name
= gfc_get_string ("__repeat_%d", string
->ts
.kind
);
1077 gfc_resolve_reshape (gfc_expr
* f
, gfc_expr
* source
, gfc_expr
* shape
,
1078 gfc_expr
* pad ATTRIBUTE_UNUSED
,
1079 gfc_expr
* order ATTRIBUTE_UNUSED
)
1081 static char reshape0
[] = "__reshape";
1088 gfc_array_size (shape
, &rank
);
1089 f
->rank
= mpz_get_si (rank
);
1091 switch (source
->ts
.type
)
1094 kind
= source
->ts
.kind
* 2;
1100 kind
= source
->ts
.kind
;
1113 f
->value
.function
.name
=
1114 gfc_get_string ("__reshape_%d", source
->ts
.kind
);
1118 f
->value
.function
.name
= reshape0
;
1122 /* TODO: Make this work with a constant ORDER parameter. */
1123 if (shape
->expr_type
== EXPR_ARRAY
1124 && gfc_is_constant_expr (shape
)
1128 f
->shape
= gfc_get_shape (f
->rank
);
1129 c
= shape
->value
.constructor
;
1130 for (i
= 0; i
< f
->rank
; i
++)
1132 mpz_init_set (f
->shape
[i
], c
->expr
->value
.integer
);
1140 gfc_resolve_rrspacing (gfc_expr
* f
, gfc_expr
* x
)
1144 f
->value
.function
.name
= gfc_get_string ("__rrspacing_%d", x
->ts
.kind
);
1149 gfc_resolve_scale (gfc_expr
* f
, gfc_expr
* x
,
1150 gfc_expr
* y ATTRIBUTE_UNUSED
)
1154 f
->value
.function
.name
= gfc_get_string ("__scale_%d_%d", x
->ts
.kind
,
1160 gfc_resolve_scan (gfc_expr
* f
, gfc_expr
* string
,
1161 gfc_expr
* set ATTRIBUTE_UNUSED
,
1162 gfc_expr
* back ATTRIBUTE_UNUSED
)
1165 f
->ts
.type
= BT_INTEGER
;
1166 f
->ts
.kind
= gfc_default_integer_kind
;
1167 f
->value
.function
.name
= gfc_get_string ("__scan_%d", string
->ts
.kind
);
1172 gfc_resolve_set_exponent (gfc_expr
* f
, gfc_expr
* x
, gfc_expr
* i
)
1176 f
->value
.function
.name
=
1177 gfc_get_string ("__set_exponent_%d_%d", x
->ts
.kind
, i
->ts
.kind
);
1182 gfc_resolve_shape (gfc_expr
* f
, gfc_expr
* array
)
1185 f
->ts
.type
= BT_INTEGER
;
1186 f
->ts
.kind
= gfc_default_integer_kind
;
1188 f
->value
.function
.name
= gfc_get_string ("__shape_%d", f
->ts
.kind
);
1189 f
->shape
= gfc_get_shape (1);
1190 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1195 gfc_resolve_sign (gfc_expr
* f
, gfc_expr
* a
, gfc_expr
* b ATTRIBUTE_UNUSED
)
1199 f
->value
.function
.name
=
1200 gfc_get_string ("__sign_%c%d", gfc_type_letter (a
->ts
.type
), a
->ts
.kind
);
1205 gfc_resolve_sin (gfc_expr
* f
, gfc_expr
* x
)
1209 f
->value
.function
.name
=
1210 gfc_get_string ("__sin_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1215 gfc_resolve_sinh (gfc_expr
* f
, gfc_expr
* x
)
1219 f
->value
.function
.name
=
1220 gfc_get_string ("__sinh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1225 gfc_resolve_spacing (gfc_expr
* f
, gfc_expr
* x
)
1229 f
->value
.function
.name
= gfc_get_string ("__spacing_%d", x
->ts
.kind
);
1234 gfc_resolve_spread (gfc_expr
* f
, gfc_expr
* source
,
1238 static char spread
[] = "__spread";
1241 f
->rank
= source
->rank
+ 1;
1242 f
->value
.function
.name
= spread
;
1244 gfc_resolve_index (dim
, 1);
1245 gfc_resolve_index (ncopies
, 1);
1250 gfc_resolve_sqrt (gfc_expr
* f
, gfc_expr
* x
)
1254 f
->value
.function
.name
=
1255 gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1260 gfc_resolve_sum (gfc_expr
* f
, gfc_expr
* array
, gfc_expr
* dim
,
1268 f
->rank
= array
->rank
- 1;
1269 gfc_resolve_index (dim
, 1);
1272 f
->value
.function
.name
=
1273 gfc_get_string ("__%s_%c%d", mask
? "msum" : "sum",
1274 gfc_type_letter (array
->ts
.type
), array
->ts
.kind
);
1279 gfc_resolve_tan (gfc_expr
* f
, gfc_expr
* x
)
1283 f
->value
.function
.name
=
1284 gfc_get_string ("__tan_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1289 gfc_resolve_tanh (gfc_expr
* f
, gfc_expr
* x
)
1293 f
->value
.function
.name
=
1294 gfc_get_string ("__tanh_%c%d", gfc_type_letter (x
->ts
.type
), x
->ts
.kind
);
1299 gfc_resolve_transfer (gfc_expr
* f
, gfc_expr
* source ATTRIBUTE_UNUSED
,
1300 gfc_expr
* mold
, gfc_expr
* size
)
1302 /* TODO: Make this do something meaningful. */
1303 static char transfer0
[] = "__transfer0", transfer1
[] = "__transfer1";
1307 if (size
== NULL
&& mold
->rank
== 0)
1310 f
->value
.function
.name
= transfer0
;
1315 f
->value
.function
.name
= transfer1
;
1321 gfc_resolve_transpose (gfc_expr
* f
, gfc_expr
* matrix
)
1323 static char transpose0
[] = "__transpose";
1330 f
->shape
= gfc_get_shape (2);
1331 mpz_init_set (f
->shape
[0], matrix
->shape
[1]);
1332 mpz_init_set (f
->shape
[1], matrix
->shape
[0]);
1335 switch (matrix
->ts
.type
)
1338 kind
= matrix
->ts
.kind
* 2;
1344 kind
= matrix
->ts
.kind
;
1358 f
->value
.function
.name
=
1359 gfc_get_string ("__transpose_%d", kind
);
1363 f
->value
.function
.name
= transpose0
;
1369 gfc_resolve_trim (gfc_expr
* f
, gfc_expr
* string
)
1372 f
->ts
.type
= BT_CHARACTER
;
1373 f
->ts
.kind
= string
->ts
.kind
;
1374 f
->value
.function
.name
= gfc_get_string ("__trim_%d", string
->ts
.kind
);
1379 gfc_resolve_ubound (gfc_expr
* f
, gfc_expr
* array
,
1382 static char ubound
[] = "__ubound";
1384 f
->ts
.type
= BT_INTEGER
;
1385 f
->ts
.kind
= gfc_default_integer_kind
;
1390 f
->shape
= gfc_get_shape (1);
1391 mpz_init_set_ui (f
->shape
[0], array
->rank
);
1394 f
->value
.function
.name
= ubound
;
1399 gfc_resolve_unpack (gfc_expr
* f
, gfc_expr
* vector
, gfc_expr
* mask
,
1400 gfc_expr
* field ATTRIBUTE_UNUSED
)
1403 f
->ts
.type
= vector
->ts
.type
;
1404 f
->ts
.kind
= vector
->ts
.kind
;
1405 f
->rank
= mask
->rank
;
1407 f
->value
.function
.name
=
1408 gfc_get_string ("__unpack%d", field
->rank
> 0 ? 1 : 0);
1413 gfc_resolve_verify (gfc_expr
* f
, gfc_expr
* string
,
1414 gfc_expr
* set ATTRIBUTE_UNUSED
,
1415 gfc_expr
* back ATTRIBUTE_UNUSED
)
1418 f
->ts
.type
= BT_INTEGER
;
1419 f
->ts
.kind
= gfc_default_integer_kind
;
1420 f
->value
.function
.name
= gfc_get_string ("__verify_%d", string
->ts
.kind
);
1424 /* Intrinsic subroutine resolution. */
1427 gfc_resolve_cpu_time (gfc_code
* c ATTRIBUTE_UNUSED
)
1431 name
= gfc_get_string (PREFIX("cpu_time_%d"),
1432 c
->ext
.actual
->expr
->ts
.kind
);
1433 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1438 gfc_resolve_random_number (gfc_code
* c ATTRIBUTE_UNUSED
)
1443 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1444 if (c
->ext
.actual
->expr
->rank
== 0)
1445 name
= gfc_get_string (PREFIX("random_r%d"), kind
);
1447 name
= gfc_get_string (PREFIX("arandom_r%d"), kind
);
1449 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1454 /* G77 compatibility subroutines etime() and dtime(). */
1457 gfc_resolve_etime_sub (gfc_code
* c
)
1461 name
= gfc_get_string (PREFIX("etime_sub"));
1462 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1466 /* G77 compatibility subroutine second(). */
1469 gfc_resolve_second_sub (gfc_code
* c
)
1473 name
= gfc_get_string (PREFIX("second_sub"));
1474 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1478 /* G77 compatibility function srand(). */
1481 gfc_resolve_srand (gfc_code
* c
)
1484 name
= gfc_get_string (PREFIX("srand"));
1485 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1489 /* Resolve the getarg intrinsic subroutine. */
1492 gfc_resolve_getarg (gfc_code
* c
)
1497 kind
= gfc_default_integer_kind
;
1498 name
= gfc_get_string (PREFIX("getarg_i%d"), kind
);
1499 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1503 /* Resolve the get_command intrinsic subroutine. */
1506 gfc_resolve_get_command (gfc_code
* c
)
1511 kind
= gfc_default_integer_kind
;
1512 name
= gfc_get_string (PREFIX("get_command_i%d"), kind
);
1513 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1517 /* Resolve the get_command_argument intrinsic subroutine. */
1520 gfc_resolve_get_command_argument (gfc_code
* c
)
1525 kind
= gfc_default_integer_kind
;
1526 name
= gfc_get_string (PREFIX("get_command_argument_i%d"), kind
);
1527 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1530 /* Resolve the get_environment_variable intrinsic subroutine. */
1533 gfc_resolve_get_environment_variable (gfc_code
* code
)
1538 kind
= gfc_default_integer_kind
;
1539 name
= gfc_get_string (PREFIX("get_environment_variable_i%d"), kind
);
1540 code
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1544 /* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
1547 gfc_resolve_system_clock (gfc_code
* c
)
1552 if (c
->ext
.actual
->expr
!= NULL
)
1553 kind
= c
->ext
.actual
->expr
->ts
.kind
;
1554 else if (c
->ext
.actual
->next
->expr
!= NULL
)
1555 kind
= c
->ext
.actual
->next
->expr
->ts
.kind
;
1556 else if (c
->ext
.actual
->next
->next
->expr
!= NULL
)
1557 kind
= c
->ext
.actual
->next
->next
->expr
->ts
.kind
;
1559 kind
= gfc_default_integer_kind
;
1561 name
= gfc_get_string (PREFIX("system_clock_%d"), kind
);
1562 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (name
);
1566 gfc_iresolve_init_1 (void)
1570 for (i
= 0; i
< HASH_SIZE
; i
++)
1571 string_head
[i
] = NULL
;
1576 gfc_iresolve_done_1 (void)