re PR fortran/15205 (NEAREST intrinsic returns wrong value in DOUBLE PRECISION)

PR fortran/15205
* iresolve.c (gfc_resolve_nearest): Add new function.
* intrinsic.h: ... declare it here.
* intrinsic.c (add_functions): ... add it as resolving function
for NEAREST.

From-SVN: r81843

gcc/fortran/ChangeLog

 2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
+	PR fortran/15205
+	* iresolve.c (gfc_resolve_nearest): Add new function.
+	* intrinsic.h: ... declare it here.
+	* intrinsic.c (add_functions): ... add it as resolving function
+	for NEAREST.
+	
+2004-05-14  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
         PR fortran/14066
 	* match.c (gfc_match_do): Allow infinite loops with
 	label-do-stmt. Do not enforce space after comma.

gcc/fortran/intrinsic.c

@@ -1301,7 +1301,7 @@ add_functions (void)
   make_generic ("modulo", GFC_ISYM_MODULO);
 
   add_sym_2 ("nearest", 1, 1, BT_REAL, dr,
-	     gfc_check_nearest, gfc_simplify_nearest, NULL,
+	     gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
 	     x, BT_REAL, dr, 0, s, BT_REAL, dr, 0);
 
   make_generic ("nearest", GFC_ISYM_NEAREST);

gcc/fortran/intrinsic.h

@@ -270,6 +270,7 @@ void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_not (gfc_expr *, gfc_expr *);
 void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);

gcc/fortran/iresolve.c

@@ -911,6 +911,16 @@ gfc_resolve_modulo (gfc_expr * f, gfc_expr * a,
 		    a->ts.kind);
 }
 
+void
+gfc_resolve_nearest (gfc_expr * f, gfc_expr * a,
+             gfc_expr *p ATTRIBUTE_UNUSED)
+{
+
+  f->ts = a->ts;
+  f->value.function.name =
+    gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type),
+            a->ts.kind);
+}
 
 void
 gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)