CbC/CbC_gcc: gcc/fortran/iresolve.c comparison

comparison gcc/fortran/iresolve.c @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 /* Intrinsic function resolution.
-Copyright (C) 2000-2017 Free Software Foundation, Inc.
+Copyright (C) 2000-2018 Free Software Foundation, Inc.
 Contributed by Andy Vaught & Katherine Holcomb
 This file is part of GCC.
 GCC is free software; you can redistribute it and/or modify it under
 #include "stringpool.h"
 #include "intrinsic.h"
 #include "constructor.h"
 #include "arith.h"
 /* Given printf-like arguments, return a stable version of the result string.
 We already have a working, optimized string hashing table in the form of
 the identifier table.  Reusing this table is likely not to be wasted,
 since if the function name makes it to the gimple output of the frontend,
 we'll have to create the identifier anyway.  */
 const char *
 gfc_get_string (const char *format, ...)
 source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 if (source->expr_type == EXPR_CONSTANT)
 {
 source->ts.u.cl->length
-		= gfc_get_int_expr (gfc_default_integer_kind, NULL,
+		= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
 				    source->value.character.length);
 source->rank = 0;
 }
 else if (source->expr_type == EXPR_ARRAY)
 {
 gfc_constructor *c = gfc_constructor_first (source->value.constructor);
 source->ts.u.cl->length
-		= gfc_get_int_expr (gfc_default_integer_kind, NULL,
+		= gfc_get_int_expr (gfc_charlen_int_kind, NULL,
 				    c->expr->value.character.length);
 }
 }
 /* Helper function for resolving the "mask" argument.  */
 {
 f->ts.type = BT_CHARACTER;
 f->ts.kind = (kind == NULL)
 	     ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
 f->value.function.name
 = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind,
 		      gfc_type_letter (x->ts.type), x->ts.kind);
 }
 void
 gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts.type = a->ts.type;
 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 if (a->ts.kind != f->ts.kind)
 {
 void
 gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts.type = a->ts.type;
 f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer);
 if (a->ts.kind != f->ts.kind)
 {
 void
 gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts = x->ts;
 if (n->ts.kind != gfc_c_int_kind)
 {
 ts.type = BT_INTEGER;
 ts.kind = gfc_c_int_kind;
 void
 gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts = x->ts;
 f->rank = 1;
 if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT)
 {
 f->shape = gfc_get_shape (1);
 is_trig_resolved (gfc_expr *f)
 {
 /* We know we've already resolved the function if we see the lib call
 starting with '__'.  */
 return (f->value.function.name != NULL
-	  && strncmp ("__", f->value.function.name, 2) == 0);
+	  && gfc_str_startswith (f->value.function.name, "__"));
 }
 /* Return a shallow copy of the function expression f.  The original expression
 has its pointers cleared so that it may be freed without affecting the
 shallow copy.  This is similar to gfc_copy_expr, but doesn't perform a deep
 /* If dim kind is greater than default integer we need to use the larger.  */
 m = gfc_default_integer_kind;
 if (dim != NULL)
 m = m < dim->ts.kind ? dim->ts.kind : m;
 /* Convert shift to at least m, so we don't need
 kind=1 and kind=2 versions of the library functions.  */
 if (shift->ts.kind < m)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 ts.type = BT_INTEGER;
 ts.kind = m;
 gfc_convert_type_warn (shift, &ts, 2, 0);
 }
 if (dim != NULL)
 {
 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 	  && dim->symtree->n.sym->attr.optional)
 	{
 void
 gfc_resolve_ctime (gfc_expr *f, gfc_expr *time)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts.type = BT_CHARACTER;
 f->ts.kind = gfc_default_character_kind;
 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
 if (time->ts.kind != 8)
 /* If dim kind is greater than default integer we need to use the larger.  */
 m = gfc_default_integer_kind;
 if (dim != NULL)
 m = m < dim->ts.kind ? dim->ts.kind : m;
 /* Convert shift to at least m, so we don't need
 kind=1 and kind=2 versions of the library functions.  */
 if (shift->ts.kind < m)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 ts.type = BT_INTEGER;
 ts.kind = m;
 gfc_convert_type_warn (shift, &ts, 2, 0);
 }
 if (dim != NULL)
 {
 if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL
 	  && dim->symtree->n.sym->attr.optional)
 	{
 void
 gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
 /* If the kind of i and j are different, then g77 cross-promoted the
 kinds to the largest value.  The Fortran 95 standard requires the
 kinds to match.  */
 if (i->ts.kind != j->ts.kind)
 {
 if (i->ts.kind == gfc_kind_max (i, j))
 	gfc_convert_type (j, &i->ts, 2);
 void
 gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
 /* If the kind of i and j are different, then g77 cross-promoted the
 kinds to the largest value.  The Fortran 95 standard requires the
 kinds to match.  */
 if (i->ts.kind != j->ts.kind)
 {
 if (i->ts.kind == gfc_kind_max (i, j))
 	gfc_convert_type (j, &i->ts, 2);
 void
 gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 {
 /* If the kind of i and j are different, then g77 cross-promoted the
 kinds to the largest value.  The Fortran 95 standard requires the
 kinds to match.  */
 if (i->ts.kind != j->ts.kind)
 {
 if (i->ts.kind == gfc_kind_max (i, j))
 	gfc_convert_type (j, &i->ts, 2);
 void
 gfc_resolve_isatty (gfc_expr *f, gfc_expr *u)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts.type = BT_LOGICAL;
 f->ts.kind = gfc_default_integer_kind;
 if (u->ts.kind != gfc_c_int_kind)
 {
 ts.type = BT_INTEGER;
 s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind;
 f->ts = i->ts;
 f->value.function.name
 = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind);
-}
-void
-gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
-		  gfc_expr *s ATTRIBUTE_UNUSED)
-{
-f->ts.type = BT_INTEGER;
-f->ts.kind = gfc_default_integer_kind;
-f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
 }
 void
 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 	{
 	  f->shape = gfc_get_shape (f->rank);
 	  mpz_init_set (f->shape[0], b->shape[1]);
 	}
 }
 else
 {
 /* b->rank == 1 and a->rank == 2 here, all other cases have
 	 been caught in check.c.   */
 if (a->shape)
 	{
 gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
 {
 gfc_resolve_minmax ("__max_%c%d", f, args);
 }
+/* The smallest kind for which a minloc and maxloc implementation exists.  */
+#define MINMAXLOC_MIN_KIND 4
 void
 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
-		    gfc_expr *mask)
+		    gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
 {
 const char *name;
 int i, j, idim;
+int fkind;
-f->ts.type = BT_INTEGER;
+int d_num;
-f->ts.kind = gfc_default_integer_kind;
+f->ts.type = BT_INTEGER;
+/* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
+we do a type conversion further down.  */
+if (kind)
+fkind = mpz_get_si (kind->value.integer);
+else
+fkind = gfc_default_integer_kind;
+if (fkind < MINMAXLOC_MIN_KIND)
+f->ts.kind = MINMAXLOC_MIN_KIND;
+else
+f->ts.kind = fkind;
 if (dim == NULL)
 {
 f->rank = 1;
 f->shape = gfc_get_shape (1);
 resolve_mask_arg (mask);
 }
 else
 name = "maxloc";
-f->value.function.name
+if (dim)
-= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+{
+if (array->ts.type != BT_CHARACTER || f->rank != 0)
+	d_num = 1;
+else
+	d_num = 2;
+}
+else
+d_num = 0;
+f->value.function.name
+= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
+if (kind)
+fkind = mpz_get_si (kind->value.integer);
+else
+fkind = gfc_default_integer_kind;
+if (fkind != f->ts.kind)
+{
+gfc_typespec ts;
+gfc_clear_ts (&ts);
+ts.type = BT_INTEGER;
+ts.kind = fkind;
+gfc_convert_type_warn (f, &ts, 2, 0);
+}
+if (back->ts.kind != gfc_logical_4_kind)
+{
+gfc_typespec ts;
+gfc_clear_ts (&ts);
+ts.type = BT_LOGICAL;
+ts.kind = gfc_logical_4_kind;
+gfc_convert_type_warn (back, &ts, 2, 0);
+}
 }
 void
 gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 resolve_mask_arg (mask);
 }
 else
 name = "maxval";
-f->value.function.name
+if (array->ts.type != BT_CHARACTER)
-= gfc_get_string (PREFIX ("%s_%c%d"), name,
+f->value.function.name
-		      gfc_type_letter (array->ts.type), array->ts.kind);
+= gfc_get_string (PREFIX ("%s_%c%d"), name,
+			gfc_type_letter (array->ts.type), array->ts.kind);
+else
+f->value.function.name
+= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
+			gfc_type_letter (array->ts.type), array->ts.kind);
 }
 void
 gfc_resolve_mclock (gfc_expr *f)
 }
 void
 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
-		    gfc_expr *mask)
+		    gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
 {
 const char *name;
 int i, j, idim;
+int fkind;
-f->ts.type = BT_INTEGER;
+int d_num;
-f->ts.kind = gfc_default_integer_kind;
+f->ts.type = BT_INTEGER;
+/* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
+we do a type conversion further down.  */
+if (kind)
+fkind = mpz_get_si (kind->value.integer);
+else
+fkind = gfc_default_integer_kind;
+if (fkind < MINMAXLOC_MIN_KIND)
+f->ts.kind = MINMAXLOC_MIN_KIND;
+else
+f->ts.kind = fkind;
 if (dim == NULL)
 {
 f->rank = 1;
 f->shape = gfc_get_shape (1);
 resolve_mask_arg (mask);
 }
 else
 name = "minloc";
-f->value.function.name
+if (dim)
-= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+{
+if (array->ts.type != BT_CHARACTER || f->rank != 0)
+	d_num = 1;
+else
+	d_num = 2;
+}
+else
+d_num = 0;
+f->value.function.name
+= gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
+if (fkind != f->ts.kind)
+{
+gfc_typespec ts;
+gfc_clear_ts (&ts);
+ts.type = BT_INTEGER;
+ts.kind = fkind;
+gfc_convert_type_warn (f, &ts, 2, 0);
+}
+if (back->ts.kind != gfc_logical_4_kind)
+{
+gfc_typespec ts;
+gfc_clear_ts (&ts);
+ts.type = BT_LOGICAL;
+ts.kind = gfc_logical_4_kind;
+gfc_convert_type_warn (back, &ts, 2, 0);
+}
 }
 void
 gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 resolve_mask_arg (mask);
 }
 else
 name = "minval";
-f->value.function.name
+if (array->ts.type != BT_CHARACTER)
-= gfc_get_string (PREFIX ("%s_%c%d"), name,
+f->value.function.name
-		      gfc_type_letter (array->ts.type), array->ts.kind);
+= gfc_get_string (PREFIX ("%s_%c%d"), name,
+			gfc_type_letter (array->ts.type), array->ts.kind);
+else
+f->value.function.name
+= gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0,
+			gfc_type_letter (array->ts.type), array->ts.kind);
 }
 void
 gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 void
 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
 		    gfc_expr *ncopies)
 {
-int len;
 gfc_expr *tmp;
 f->ts.type = BT_CHARACTER;
 f->ts.kind = string->ts.kind;
 f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
 f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 tmp = NULL;
 if (string->expr_type == EXPR_CONSTANT)
 {
-len = string->value.character.length;
+tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL,
-tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
+			      string->value.character.length);
 }
 else if (string->ts.u.cl && string->ts.u.cl->length)
 {
 tmp = gfc_copy_expr (string->ts.u.cl->length);
 }
 f->ts.kind = gfc_default_integer_kind;
 f->value.function.name = image_status;
 }
+/* Resolve get_team ().  */
+void
+gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED)
+{
+static char get_team[] = "_gfortran_caf_get_team";
+f->rank = 0;
+f->ts.type = BT_INTEGER;
+f->ts.kind = gfc_default_integer_kind;
+f->value.function.name = get_team;
+}
 /* Resolve image_index (...).  */
 void
 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 			 gfc_expr *sub ATTRIBUTE_UNUSED)
 if (kind == NULL)
 f->ts.kind = gfc_default_integer_kind;
 else
 gfc_extract_int (kind, &f->ts.kind);
 f->value.function.name = stopped_images;
+}
+/* Resolve team_number (team).  */
+void
+gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
+{
+static char team_number[] = "_gfortran_caf_team_number";
+f->rank = 0;
+f->ts.type = BT_INTEGER;
+f->ts.kind = gfc_default_integer_kind;
+f->value.function.name = team_number;
 }
 void
 gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
 {
 int len;
 if (mold->expr_type == EXPR_CONSTANT)
 {
 	  len = mold->value.character.length;
-	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
 						    NULL, len);
 	}
 else
 	{
 	  gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
 	  len = c->expr->value.character.length;
-	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+	  mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
 						    NULL, len);
 	}
 }
 f->ts = mold->ts;
 void
 gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 f->ts.type = BT_CHARACTER;
 f->ts.kind = gfc_default_character_kind;
 if (unit->ts.kind != gfc_c_int_kind)
 {
 of creating temporaries.  */
 c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
 }
+/* Set up the call to RANDOM_INIT.  */
+void
+gfc_resolve_random_init (gfc_code *c)
+{
+const char *name;
+name = gfc_get_string (PREFIX ("random_init"));
+c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
 void
 gfc_resolve_random_number (gfc_code *c)
 {
 const char *name;
 int kind;
 kind = c->ext.actual->expr->ts.kind;
 if (c->ext.actual->expr->rank == 0)
 name = gfc_get_string (PREFIX ("random_r%d"), kind);
 else
 name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 void
 gfc_resolve_rename_sub (gfc_code *c)
 {
 const char *name;
 int kind;
+/* Find the type of status.  If not present use default integer kind.  */
 if (c->ext.actual->next->next->expr != NULL)
 kind = c->ext.actual->next->next->expr->ts.kind;
 else
 kind = gfc_default_integer_kind;
 name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
-void
-gfc_resolve_kill_sub (gfc_code *c)
-{
-const char *name;
-int kind;
-if (c->ext.actual->next->next->expr != NULL)
-kind = c->ext.actual->next->next->expr->ts.kind;
-else
-kind = gfc_default_integer_kind;
-name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
-c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
-}
 void
 gfc_resolve_link_sub (gfc_code *c)
 {
 const char *name;
 void
 gfc_resolve_ctime_sub (gfc_code *c)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 /* ctime TIME argument is a INTEGER(KIND=8), says the doc */
 if (c->ext.actual->expr->ts.kind != 8)
 {
 ts.type = BT_INTEGER;
 ts.kind = 8;
 c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 void
 gfc_resolve_fseek_sub (gfc_code *c)
 {
 gfc_expr *unit;
 gfc_expr *offset;
 gfc_expr *whence;
 void
 gfc_resolve_ttynam_sub (gfc_code *c)
 {
 gfc_typespec ts;
 gfc_clear_ts (&ts);
 if (c->ext.actual->expr->ts.kind != gfc_c_int_kind)
 {
 ts.type = BT_INTEGER;
 ts.kind = gfc_c_int_kind;
 ts.u.derived = NULL;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/iresolve.c @ 131:84e7813d76e9