[patch] Implement sizeof intrinsic, a minor cleanups to trans-intrinsic.c

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Hi,

the attached patch implements the SIZEOF intrinsic.  Since the code for 
determining the length is copied from the code for TRANSFER, I had a 
chance to look at that as well and noticed the complete lack of 
constant-folding in it as well as a redundant initialization, which I 
chose to fix.  The code could also be somewhat simplified, as I did in 
the version for SIZEOF, but for fear of introducing bugs, I didn't touch 
it.  I tried to avoid the redundancy between the two size-determination 
codes by merging them, but failed at doing so: I would have had to walk 
the expression twice in gfc_conv_intrinsic_array_transfer, which 
wouldn't have left me with much saved code.

The patch comes with a new testcase which exercises the stuff that 
should be platform independent.  Built and tested on i386-darwin.  I 
also checked make pdf.  Ok?

Cheers,
- Tobi

2007-05-28  Tobias Schlüter  <tobi@gcc.gnu.org>
fortran/
	* gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SIZEOF.
	* intrinsic.c (add_functions): Add stuff for SIZEOF intrinsic.
	* intrinsic.h (gfc_check_sizeof): Add prototype of ...
	* check.c (gfc_check_sizeof): .. new function.
	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): New function.
	(gfc_conv_intrinsic_strcmp): Whitespace fix.
	(gfc_conv_intrinsic_array_transfer): Remove double initialization,
	use fold_build. where appropriate.
	(gfc_conv_intrinsic_function): Add case for SIZEOF.
	* intrinsic.texi: Add documentation for SIZEOF.
testsuite/
	* gfortran.dg/sizeof.f90: New.

Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h	(revision 125133)
+++ fortran/gfortran.h	(working copy)
@@ -446,6 +446,7 @@ enum gfc_generic_isym_id
   GFC_ISYM_SIN,
   GFC_ISYM_SINH,
   GFC_ISYM_SIZE,
+  GFC_ISYM_SIZEOF,
   GFC_ISYM_SPACING,
   GFC_ISYM_SPREAD,
   GFC_ISYM_SQRT,
Index: fortran/intrinsic.c
===================================================================
--- fortran/intrinsic.c	(revision 125133)
+++ fortran/intrinsic.c	(working copy)
@@ -2138,6 +2138,12 @@ add_functions (void)
 
   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
 
+  add_sym_1 ("sizeof", NOT_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di,
+	     GFC_STD_GNU, gfc_check_sizeof, NULL, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);	     
+
   add_sym_1 ("spacing", ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
 	     x, BT_REAL, dr, REQUIRED);
Index: fortran/intrinsic.h
===================================================================
--- fortran/intrinsic.h	(revision 125133)
+++ fortran/intrinsic.h	(working copy)
@@ -121,6 +121,7 @@ try gfc_check_shape (gfc_expr *);
 try gfc_check_size (gfc_expr *, gfc_expr *);
 try gfc_check_sign (gfc_expr *, gfc_expr *);
 try gfc_check_signal (gfc_expr *, gfc_expr *);
+try gfc_check_sizeof (gfc_expr *);
 try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_srand (gfc_expr *);
 try gfc_check_stat (gfc_expr *, gfc_expr *);
Index: fortran/check.c
===================================================================
--- fortran/check.c	(revision 125133)
+++ fortran/check.c	(working copy)
@@ -2334,6 +2334,13 @@ gfc_check_size (gfc_expr *array, gfc_exp
 
 
 try
+gfc_check_sizeof (gfc_expr *arg __attribute__((unused)))
+{
+  return SUCCESS;
+}
+
+
+try
 gfc_check_sleep_sub (gfc_expr *seconds)
 {
   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
Index: fortran/trans-intrinsic.c
===================================================================
--- fortran/trans-intrinsic.c	(revision 125133)
+++ fortran/trans-intrinsic.c	(working copy)
@@ -2745,9 +2745,83 @@ gfc_conv_intrinsic_size (gfc_se * se, gf
 }
 
 
+static void
+gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_ss *ss;
+  gfc_se argse;
+  tree source;
+  tree source_bytes;
+  tree type;
+  tree tmp;
+  tree lower;
+  tree upper;
+  /*tree stride;*/
+  int n;
+
+  arg = expr->value.function.actual->expr;
+
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg);
+
+  source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
+
+  if (ss == gfc_ss_terminator)
+    {
+      gfc_conv_expr_reference (&argse, arg);
+      source = argse.expr;
+
+      type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+
+      /* Obtain the source word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+	source_bytes = fold_convert (gfc_array_index_type,
+				     argse.string_length);
+      else
+	source_bytes = fold_convert (gfc_array_index_type,
+				     size_in_bytes (type)); 
+    }
+  else
+    {
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg, ss);
+      source = gfc_conv_descriptor_data_get (argse.expr);
+      type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+      /* Obtain the argument's word length.  */
+      if (arg->ts.type == BT_CHARACTER)
+	tmp = fold_convert (gfc_array_index_type, argse.string_length);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    size_in_bytes (type)); 
+      gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+
+      /* Obtain the size of the array in bytes.  */
+      for (n = 0; n < arg->rank; n++)
+	{
+	  tree idx;
+	  idx = gfc_rank_cst[n];
+	  lower = gfc_conv_descriptor_lbound (argse.expr, idx);
+	  upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     upper, lower);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+	  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			     tmp, source_bytes);
+	  gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
+	}
+    }
+
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  se->expr = source_bytes;
+}
+
+
 /* Intrinsic string comparison functions.  */
 
-  static void
+static void
 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
 {
   tree type;
@@ -2850,7 +2924,6 @@ gfc_conv_intrinsic_array_transfer (gfc_s
     }
   else
     {
-      gfc_init_se (&argse, NULL);
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
       source = gfc_conv_descriptor_data_get (argse.expr);
@@ -2898,13 +2971,13 @@ gfc_conv_intrinsic_array_transfer (gfc_s
 	  stride = gfc_conv_descriptor_stride (argse.expr, idx);
 	  lower = gfc_conv_descriptor_lbound (argse.expr, idx);
 	  upper = gfc_conv_descriptor_ubound (argse.expr, idx);
-	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
-			upper, lower);
+	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     upper, lower);
 	  gfc_add_modify_expr (&argse.pre, extent, tmp);
-	  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
-			extent, gfc_index_one_node);
-	  tmp = build2 (MULT_EXPR, gfc_array_index_type,
-			tmp, source_bytes);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     extent, gfc_index_one_node);
+	  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			     tmp, source_bytes);
 	}
     }
 
@@ -2964,17 +3037,18 @@ gfc_conv_intrinsic_array_transfer (gfc_s
   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
   if (tmp != NULL_TREE)
     {
-      tmp = build2 (MULT_EXPR, gfc_array_index_type,
-		    tmp, dest_word_len);
-      tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			 tmp, dest_word_len);
+      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+			 tmp, source_bytes);
     }
   else
     tmp = source_bytes;
 
   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
   gfc_add_modify_expr (&se->pre, size_words,
-		       build2 (CEIL_DIV_EXPR, gfc_array_index_type,
-			       size_bytes, dest_word_len));
+		       fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
+				    size_bytes, dest_word_len));
 
   /* Evaluate the bounds of the result.  If the loop range exists, we have
      to check if it is too large.  If so, we modify loop->to be consistent
@@ -2985,23 +3059,23 @@ gfc_conv_intrinsic_array_transfer (gfc_s
     {
       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 			 se->loop->to[n], se->loop->from[n]);
-      tmp = build2 (PLUS_EXPR, gfc_array_index_type,
-		    tmp, gfc_index_one_node);
-      tmp = build2 (MIN_EXPR, gfc_array_index_type,
-		    tmp, size_words);
+      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			 tmp, gfc_index_one_node);
+      tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
+			 tmp, size_words);
       gfc_add_modify_expr (&se->pre, size_words, tmp);
       gfc_add_modify_expr (&se->pre, size_bytes,
-			   build2 (MULT_EXPR, gfc_array_index_type,
-			   size_words, dest_word_len));
-      upper = build2 (PLUS_EXPR, gfc_array_index_type,
-		      size_words, se->loop->from[n]);
-      upper = build2 (MINUS_EXPR, gfc_array_index_type,
-		      upper, gfc_index_one_node);
+			   fold_build2 (MULT_EXPR, gfc_array_index_type,
+					size_words, dest_word_len));
+      upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			   size_words, se->loop->from[n]);
+      upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			   upper, gfc_index_one_node);
     }
   else
     {
-      upper = build2 (MINUS_EXPR, gfc_array_index_type,
-		      size_words, gfc_index_one_node);
+      upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			   size_words, gfc_index_one_node);
       se->loop->from[n] = gfc_index_zero_node;
     }
 
@@ -3866,6 +3940,10 @@ gfc_conv_intrinsic_function (gfc_se * se
       gfc_conv_intrinsic_size (se, expr);
       break;
 
+    case GFC_ISYM_SIZEOF:
+      gfc_conv_intrinsic_sizeof (se, expr);
+      break;
+
     case GFC_ISYM_SUM:
       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
       break;
Index: fortran/intrinsic.texi
===================================================================
--- fortran/intrinsic.texi	(revision 125133)
+++ fortran/intrinsic.texi	(working copy)
@@ -222,6 +222,7 @@ Some basic guidelines for editing this d
 * @code{SIN}:           SIN,       Sine function
 * @code{SINH}:          SINH,      Hyperbolic sine function
 * @code{SIZE}:          SIZE,      Function to determine the size of an array
+* @code{SIZEOF}:        SIZEOF,    Determine the size in bytes of an expression
 * @code{SLEEP}:         SLEEP,     Sleep for the specified number of seconds
 * @code{SNGL}:          SNGL,      Convert double precision real to default real
 * @code{SPACING}:       SPACING,   Smallest distance between two numbers of a given type
@@ -9012,6 +9013,49 @@ END PROGRAM
 @end table
 
 
+@node SIZEOF
+@section @code{SIZEOF} --- Size in bytes of an expression
+@fnindex SIZEOF
+@cindex expression size
+@cindex size of an expression
+
+@table @asis
+@item @emph{Description}:
+@code{SIZEOF(X)} calculates the number of bytes of storage the
+expression @code{X} occupies.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Intrinsic function
+
+@item @emph{Syntax}:
+@code{N = SIZEOF(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{X} @tab The argument shall be of any type, rank or shape.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type integer.  Its value is the number of bytes
+occupied by the argument.  If the argument has the @code{POINTER}
+attribute, the number of bytes of the storage area pointed to is
+returned.  If the argument is of a derived type with @code{POINTER} or
+@code{ALLOCATABLE} components, the return value doesn't account for
+the sizes of the data pointed to by these components.
+
+@item @emph{Example}:
+@smallexample
+   integer :: i
+   real :: r, s(5)
+   print *, (sizeof(s)/sizeof(r) == 5)
+   end
+@end smallexample
+The example will print @code{.TRUE.} unless you are using a platform
+where default @code{REAL} variables are unusually padded.
+@end table
 
 @node SLEEP
 @section @code{SLEEP} --- Sleep for the specified number of seconds
Index: testsuite/gfortran.dg/sizeof.f90
===================================================================
--- testsuite/gfortran.dg/sizeof.f90	(revision 0)
+++ testsuite/gfortran.dg/sizeof.f90	(revision 0)
@@ -0,0 +1,82 @@
+! { dg-do run }
+! Verify that the sizeof intrinsic does as advertised
+subroutine check_int (j)
+  INTEGER(4) :: i, ia(5), ib(5,4), ip, ipa(:)
+  target :: ib
+  POINTER :: ip, ipa
+  logical :: l(6)
+  integer(8) :: jb(5,4)
+
+  if (sizeof (j) /= sizeof (i)) call abort
+  if (sizeof (jb) /= 2*sizeof (ib)) call abort
+
+  ipa=>ib(2:3,1)
+
+  l = (/ sizeof(i) == 4, sizeof(ia) == 20, sizeof(ib) == 80, &
+       sizeof(ip) == 4, sizeof(ipa) == 8, sizeof(ib(1:5:2,3)) == 12 /)
+
+  if (any(.not.l)) call abort
+  if (sizeof(l) /= 6*sizeof(l(1))) call abort
+end subroutine check_int
+
+subroutine check_real (x, y)
+  dimension y(5)
+  real(4) :: r(20,20,20), rp(:,:)
+  target :: r
+  pointer :: rp
+  double precision :: d(5,5)
+  complex :: c(5)
+  
+  if (sizeof (y) /= 5*sizeof (x)) call abort
+
+  if (sizeof (r) /= 8000*4) call abort
+  rp => r(5,2:10,1:5)
+  if (sizeof (rp) /= 45*4) call abort
+  rp => r(1:5,1:5,1)
+  if (sizeof (d) /= 2*sizeof (rp)) call abort
+  if (sizeof (c(1)) /= 2*sizeof(r(1,1,1))) call abort
+end subroutine check_real
+
+subroutine check_derived ()
+  type dt
+     integer i
+  end type dt
+  type (dt) :: a
+  integer :: i
+  type foo
+     integer :: i(5000)
+     real :: j(5)
+     type(dt) :: d
+  end type foo
+  type bar
+     integer :: j(5000)
+     real :: k(5)
+     type(dt) :: d
+  end type bar
+  type (foo) :: oof
+  type (bar) :: rab
+  integer(8) :: size_500, size_200, sizev500, sizev200
+  type all
+     real, allocatable :: r(:)
+  end type all
+  real :: r(200), s(500)
+  type(all) :: v
+
+  if (sizeof(a) /= sizeof(i)) call abort
+  if (sizeof(oof) /= sizeof(rab)) call abort
+  allocate (v%r(500))
+  sizev500 = sizeof (v)
+  size_500 = sizeof (v%r)
+  deallocate (v%r)
+  allocate (v%r(200))
+  sizev200 = sizeof (v)
+  size_200 = sizeof (v%r)
+  deallocate (v%r)
+  if (size_500 - size_200 /= sizeof(s) - sizeof(r) .or. sizev500 /= sizev200) &
+       call abort
+end subroutine check_derived
+
+call check_int ()
+call check_real ()
+call check_derived ()
+end