re PR libfortran/34209 (run-time lib: NEAREST(0.0_8, -1.0) produces wrong numbers)

2007-11-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/34209
	* iresolve.c (gfc_resolve_nearest): If sign variable kind does not match
	kind of input variable, convert it to match.

	PR fortran/33317
	* trans.h: Modify prototype for gfc_conv_missing_dummy.
	* trans-expr.c (gfc_conv_missing_dummy): Modify to pass an integer kind
	parameter in.  Set the type of the dummy to the kind given.
	(gfc_conv_function_call): Pass representation.length to
	gfc_conv_missing_dummy.
	* iresolve.c (gfc_resolve_cshift): Determine the correct kind to use and
	if appropriate set representation.length to this kind value.
	(gfc_resolve_eoshift): Likewise.
	* check.c (gfc_check_cshift): Enable dim_check to allow DIM as an
	optional argument. (gfc_check_eoshift): Likewise.
	* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Update call to
	gfc_conv_missing_dummy.

From-SVN: r130391

gcc/fortran/ChangeLog

+2007-11-23  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/34209
+	* iresolve.c (gfc_resolve_nearest): If sign variable kind does not match
+	kind of input variable, convert it to match.
+
+	PR fortran/33317
+	* trans.h: Modify prototype for gfc_conv_missing_dummy.
+	* trans-expr.c (gfc_conv_missing_dummy): Modify to pass an integer kind
+	parameter in.  Set the type of the dummy to the kind given.
+	(gfc_conv_function_call): Pass representation.length to
+	gfc_conv_missing_dummy.
+	* iresolve.c (gfc_resolve_cshift): Determine the correct kind to use and
+	if appropriate set representation.length to this kind value.
+	(gfc_resolve_eoshift): Likewise.
+	* check.c (gfc_check_cshift): Enable dim_check to allow DIM as an
+	optional argument. (gfc_check_eoshift): Likewise.
+	* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Update call to
+	gfc_conv_missing_dummy.
+
 2007-11-23  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34187

gcc/fortran/check.c

@@ -863,8 +863,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
       /* TODO: more requirements on shift parameter.  */
     }
 
-  /* FIXME (PR33317): Allow optional DIM=.  */
-  if (dim_check (dim, 2, false) == FAILURE)
+  if (dim_check (dim, 2, true) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -1033,8 +1032,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
       /* TODO: more restrictions on boundary.  */
     }
 
-  /* FIXME (PR33317): Allow optional DIM=.  */
-  if (dim_check (dim, 4, false) == FAILURE)
+  if (dim_check (dim, 4, true) == FAILURE)
     return FAILURE;
 
   return SUCCESS;

gcc/fortran/iresolve.c

@@ -559,7 +559,7 @@ void
 gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 		    gfc_expr *dim)
 {
-  int n;
+  int n, m;
 
   if (array->ts.type == BT_CHARACTER && array->ref)
     gfc_resolve_substring_charlen (array);
@@ -573,22 +573,35 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   else
     n = 0;
 
-  /* Convert shift to at least gfc_default_integer_kind, so we don't need
-     kind=1 and kind=2 versions of the library functions.  */
-  if (shift->ts.kind < gfc_default_integer_kind)
+  /* 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;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   if (dim != NULL)
     {
-      gfc_resolve_dim_arg (dim);
-      /* Convert dim to shift's kind, so we don't need so many variations.  */
-      if (dim->ts.kind != shift->ts.kind)
-	gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+      if (dim->expr_type != EXPR_CONSTANT)
+	{
+	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+	  dim->representation.length = shift->ts.kind;
+	}
+      else
+	{
+	  gfc_resolve_dim_arg (dim);
+	  /* Convert dim to shift's kind to reduce variations.  */
+	  if (dim->ts.kind != shift->ts.kind)
+	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
     }
 
   f->value.function.name
@@ -683,7 +696,7 @@ void
 gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 		     gfc_expr *boundary, gfc_expr *dim)
 {
-  int n;
+  int n, m;
 
   if (array->ts.type == BT_CHARACTER && array->ref)
     gfc_resolve_substring_charlen (array);
@@ -698,22 +711,35 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
   if (boundary && boundary->rank > 0)
     n = n | 2;
 
-  /* Convert shift to at least gfc_default_integer_kind, so we don't need
-     kind=1 and kind=2 versions of the library functions.  */
-  if (shift->ts.kind < gfc_default_integer_kind)
+  /* 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;
       ts.type = BT_INTEGER;
-      ts.kind = gfc_default_integer_kind;
+      ts.kind = m;
       gfc_convert_type_warn (shift, &ts, 2, 0);
     }
-
+ 
   if (dim != NULL)
     {
-      gfc_resolve_dim_arg (dim);
-      /* Convert dim to shift's kind, so we don't need so many variations.  */
-      if (dim->ts.kind != shift->ts.kind)
-	gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+      if (dim->expr_type != EXPR_CONSTANT)
+	{
+	  /* Mark this for later setting the type in gfc_conv_missing_dummy.  */
+	  dim->representation.length = shift->ts.kind;
+	}
+      else
+	{
+	  gfc_resolve_dim_arg (dim);
+	  /* Convert dim to shift's kind to reduce variations.  */
+	  if (dim->ts.kind != shift->ts.kind)
+	    gfc_convert_type_warn (dim, &shift->ts, 2, 0);
+        }
     }
 
   f->value.function.name
@@ -1580,8 +1606,11 @@ gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 }
 
 void
-gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p ATTRIBUTE_UNUSED)
+gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p)
 {
+  if (p->ts.kind != a->ts.kind)
+    gfc_convert_type (p, &a->ts, 2);
+
   f->ts = a->ts;
   f->value.function.name
     = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),

gcc/fortran/trans-expr.c

@@ -146,7 +146,7 @@ gfc_conv_expr_present (gfc_symbol * sym)
 /* Converts a missing, dummy argument into a null or zero.  */
 
 void
-gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
 {
   tree present;
   tree tmp;
@@ -154,9 +154,16 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
   present = gfc_conv_expr_present (arg->symtree->n.sym);
 
   tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
-		fold_convert (TREE_TYPE (se->expr), integer_zero_node));
-
+		  fold_convert (TREE_TYPE (se->expr), integer_zero_node));
   tmp = gfc_evaluate_now (tmp, &se->pre);
+
+  if (kind > 0)
+    {
+      tmp = gfc_get_int_type (kind);
+      tmp = fold_convert (tmp, se->expr);
+      tmp = gfc_evaluate_now (tmp, &se->pre); 
+    }
+
   se->expr = tmp;
 
   if (ts.type == BT_CHARACTER)
@@ -2324,7 +2331,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	     check its presence and substitute a null if absent.  */
 	  if (e->expr_type == EXPR_VARIABLE
 	      && e->symtree->n.sym->attr.optional)
-	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts);
+	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
+				    e->representation.length);
 	}
 
       if (fsym && e)

gcc/fortran/trans-intrinsic.c

@@ -214,7 +214,7 @@ gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 	    && e->symtree->n.sym->attr.optional
 	    && formal
 	    && formal->optional)
-	gfc_conv_missing_dummy (&argse, e, formal->ts);
+	gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
 
       gfc_add_block_to_block (&se->pre, &argse.pre);
       gfc_add_block_to_block (&se->post, &argse.post);

gcc/fortran/trans.h

@@ -332,7 +332,7 @@ void gfc_conv_structure (gfc_se *, gfc_expr *, int);
 /* Return an expression which determines if a dummy parameter is present.  */
 tree gfc_conv_expr_present (gfc_symbol *);
 /* Convert a missing, dummy argument into a null or zero.  */
-void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec);
+void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int);
 
 /* Generate code to allocate a string temporary.  */
 tree gfc_conv_string_tmp (gfc_se *, tree, tree);