PR fortran/23516

* intrinsic.c (add_function): Add IMAG, IMAGPART, and REALPART
  intrinsics.
* intrinsic.h: Prototypes for gfc_simplify_realpart and
  gfc_resolve_realpart.
* intrinsic.texi: Document intrinsic procedures.
* simplify.c (gfc_simplify_realpart): New function.
* irseolve.c (gfc_resolve_realpart): New function.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@104537 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0095d4d..e6c8da1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2005-09-22  Steven G. Kargl  <kargls@comcast.net>
+
+       PR fortran/23516
+       * intrinsic.c (add_function): Add IMAG, IMAGPART, and REALPART
+       intrinsics.
+       * intrinsic.h: Prototypes for gfc_simplify_realpart and
+       gfc_resolve_realpart.
+       * intrinsic.texi: Document intrinsic procedures.
+       * simplify.c (gfc_simplify_realpart): New function.
+       * irseolve.c (gfc_resolve_realpart): New function.
+
 2005-09-21  Erik Edelmann  <erik.edelmann@iki.fi>
 
        PR fortran/19929

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 180e7ae..be23556 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -949,10 +949,14 @@ add_functions (void)
             gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
             z, BT_COMPLEX, dz, REQUIRED);
 
+  make_alias ("imag", GFC_STD_GNU);
+  make_alias ("imagpart", GFC_STD_GNU);
+
   add_sym_1 ("dimag", 1, 1, BT_REAL, dd, GFC_STD_GNU, 
             NULL, gfc_simplify_aimag, gfc_resolve_aimag, 
             z, BT_COMPLEX, dd, REQUIRED);
 
+
   make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
 
   add_sym_2 ("aint", 1, 1, BT_REAL, dr, GFC_STD_F77,
@@ -1813,6 +1817,11 @@ add_functions (void)
             gfc_check_real, gfc_simplify_real, gfc_resolve_real,
             a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 
+  /* This provides compatibility with g77.  */
+  add_sym_1 ("realpart", 1, 0, BT_REAL, dr, GFC_STD_GNU,
+            gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
+            a, BT_UNKNOWN, dr, REQUIRED);
+
   add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
             NULL, gfc_simplify_float, NULL,
             a, BT_INTEGER, di, REQUIRED);

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index a10e844..c405cce 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -233,6 +233,7 @@ gfc_expr *gfc_simplify_precision (gfc_expr *);
 gfc_expr *gfc_simplify_radix (gfc_expr *);
 gfc_expr *gfc_simplify_range (gfc_expr *);
 gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_realpart (gfc_expr *);
 gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
                                gfc_expr *);
@@ -345,6 +346,7 @@ void gfc_resolve_not (gfc_expr *, gfc_expr *);
 void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_realpart (gfc_expr *, gfc_expr *);
 void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,

diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 0ac6a54..2043c28 100644 (file)
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -89,6 +89,7 @@ and editing.  All contributions and corrections are strongly encouraged.
 * @code{FNUM}:          FNUM,      File number function
 * @code{LOG}:           LOG,       Logarithm function
 * @code{LOG10}:         LOG10,     Base 10 logarithm function 
+* @code{REAL}:          REAL,      Convert to real type 
 * @code{SQRT}:          SQRT,      Square-root function
 * @code{SIN}:           SIN,       Sine function
 * @code{SINH}:          SINH,      Hyperbolic sine function
@@ -402,11 +403,16 @@ end program test_adjustr
 @section @code{AIMAG} --- Imaginary part of complex number  
 @findex @code{AIMAG} intrinsic
 @findex @code{DIMAG} intrinsic
+@findex @code{IMAG} intrinsic
+@findex @code{IMAGPART} intrinsic
 @cindex Imaginary part
 
 @table @asis
 @item @emph{Description}:
 @code{AIMAG(Z)} yields the imaginary part of complex argument @code{Z}.
+The @code{IMAG(Z)} and @code{IMAGPART(Z)} intrinsic functions are provided
+for compatibility with @command{g77}, and their use in new code is 
+strongly discouraged.
 
 @item @emph{Option}:
 f95, gnu
@@ -441,6 +447,8 @@ end program test_aimag
 @multitable @columnfractions .24 .24 .24 .24
 @item Name            @tab Argument            @tab Return type       @tab Option
 @item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)}    @tab f95, gnu
+@item @code{IMAG(Z)}  @tab @code{COMPLEX(*) Z} @tab @code{REAL(*)}    @tab gnu
+@item @code{IMAGPART(Z)} @tab @code{COMPLEX(*) Z} @tab @code{REAL(*)} @tab gnu
 @end multitable
 @end table
 
@@ -2821,6 +2829,64 @@ end program test_log10
 @end table
 
 
+@node REAL
+@section @code{REAL} --- Convert to real type 
+@findex @code{REAL} intrinsic
+@findex @code{REALPART} intrinsic
+@cindex true values
+
+@table @asis
+@item @emph{Description}:
+@code{REAL(X [, KIND])} converts its argument @var{X} to a real type.  The
+@code{REALPART(X)} function is provided for compatibility with @command{g77},
+and its use is strongly discouraged.
+
+@item @emph{Option}:
+f95, gnu
+
+@item @emph{Class}:
+transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .30 .80
+@item @code{X = REAL(X)}
+@item @code{X = REAL(X, KIND)}
+@item @code{X = REALPART(Z)}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{X} @tab shall be @code{INTEGER(*)}, @code{REAL(*)}, or  
+@code{COMPLEX(*)}.
+@item @var{KIND}  @tab (Optional) @var{KIND} shall be a scalar integer.
+@end multitable
+
+@item @emph{Return value}:
+These functions return the a @code{REAL(*)} variable or array under
+the following rules: 
+
+@table @asis
+@item (A)
+@code{REAL(X)} is converted to a default real type if @var{X} is an 
+integer or real variable.
+@item (B)
+@code{REAL(X)} is converted to a real type with the kind type parameter
+of @var{X} if @var{X} is a complex variable.
+@item (C)
+@code{REAL(X, KIND)} is converted to a real type with kind type
+parameter @var{KIND} if @var{X} is a complex, integer, or real
+variable.
+@end table
+
+@item @emph{Example}:
+@smallexample
+program test_real
+  complex :: x = (1.0, 2.0)
+  print *, real(x), real(x,8), realpart(x)
+  end program test_real
+@end smallexample
+@end table
+
 
 @node SIN
 @section @code{SIN} --- Sine function 

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index ed043a6..dda6acb 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1152,6 +1152,17 @@ gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 
 
 void
+gfc_resolve_realpart (gfc_expr * f, gfc_expr * a)
+{
+  f->ts.type = BT_REAL;
+  f->ts.kind = a->ts.kind;
+  f->value.function.name =
+    gfc_get_string ("__real_%d_%c%d", f->ts.kind,
+                   gfc_type_letter (a->ts.type), a->ts.kind);
+}
+
+
+void
 gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
                    gfc_expr * p2 ATTRIBUTE_UNUSED)
 {

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 44dfe1a..7c9a6dc 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -372,6 +372,7 @@ gfc_simplify_adjustr (gfc_expr * e)
 gfc_expr *
 gfc_simplify_aimag (gfc_expr * e)
 {
+
   gfc_expr *result;
 
   if (e->expr_type != EXPR_CONSTANT)
@@ -2591,6 +2592,21 @@ gfc_simplify_real (gfc_expr * e, gfc_expr * k)
   return range_check (result, "REAL");
 }
 
+
+gfc_expr *
+gfc_simplify_realpart (gfc_expr * e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+  mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+
+  return range_check (result, "REALPART");
+}
+
 gfc_expr *
 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
 {