2010-07-08 Janus Weil <janus@gcc.gnu.org>

	PR fortran/44649
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE.
	* intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size,
	gfc_resolve_storage_size): New prototypes.
	* check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions.
	* intrinsic.c (add_functions): Add STORAGE_SIZE.
	* iresolve.c (gfc_resolve_storage_size): New function.
	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic
	arguments.
	(gfc_conv_intrinsic_storage_size): New function.
	(gfc_conv_intrinsic_function): Handle STORAGE_SIZE.

2010-07-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44649
	* gfortran.dg/c_sizeof_1.f90: Modified.
	* gfortran.dg/storage_size_1.f08: New.
	* gfortran.dg/storage_size_2.f08: New.


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

11 files changed, 211 insertions, 4 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 34ce90c2d76..1a9e71f29cd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2010-07-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44649
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE.
+	* intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size,
+	gfc_resolve_storage_size): New prototypes.
+	* check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions.
+	* intrinsic.c (add_functions): Add STORAGE_SIZE.
+	* iresolve.c (gfc_resolve_storage_size): New function.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic
+	arguments.
+	(gfc_conv_intrinsic_storage_size): New function.
+	(gfc_conv_intrinsic_function): Handle STORAGE_SIZE.
+
 2010-07-08  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/44847
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 27bd900f9e3..7578775ef42 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3046,6 +3046,20 @@ gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED)
 
 
 gfc_try
+gfc_check_c_sizeof (gfc_expr *arg)
+{
+  if (verify_c_interop (&arg->ts) != SUCCESS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an "
+		 "interoperable data entity", gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic, &arg->where);
+      return FAILURE;
+    }
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_sleep_sub (gfc_expr *seconds)
 {
   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
@@ -4559,3 +4573,27 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
 
   return SUCCESS;
 }
+
+
+gfc_try
+gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  if (kind == NULL)
+    return SUCCESS;
+
+  if (type_check (kind, 1, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (kind, 1) == FAILURE)
+    return FAILURE;
+
+  if (kind->expr_type != EXPR_CONSTANT)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
+		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 &kind->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 82703e65c59..37979268c65 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -348,6 +348,7 @@ enum gfc_isym_id
   GFC_ISYM_CPU_TIME,
   GFC_ISYM_CSHIFT,
   GFC_ISYM_CTIME,
+  GFC_ISYM_C_SIZEOF,
   GFC_ISYM_DATE_AND_TIME,
   GFC_ISYM_DBLE,
   GFC_ISYM_DIGITS,
@@ -504,6 +505,7 @@ enum gfc_isym_id
   GFC_ISYM_SRAND,
   GFC_ISYM_SR_KIND,
   GFC_ISYM_STAT,
+  GFC_ISYM_STORAGE_SIZE,
   GFC_ISYM_SUM,
   GFC_ISYM_SYMLINK,
   GFC_ISYM_SYMLNK,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 833fd30beb1..87d9c800df0 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2459,7 +2459,10 @@ add_functions (void)
 	     x, BT_UNKNOWN, 0, REQUIRED);
 
   make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
-  make_alias ("c_sizeof", GFC_STD_F2008);
+  
+  add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
+	     x, BT_UNKNOWN, 0, REQUIRED);
 
   add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
@@ -2500,6 +2503,12 @@ add_functions (void)
 
   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
 
+  add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_storage_size, NULL, gfc_resolve_storage_size,
+	     a, BT_UNKNOWN, 0, REQUIRED,
+	     kind, BT_INTEGER, di, OPTIONAL);
+  
   add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 		gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
 		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 919f09e90b4..f5da7a0649c 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -133,10 +133,12 @@ gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_sizeof (gfc_expr *);
+gfc_try gfc_check_c_sizeof (gfc_expr *);
 gfc_try gfc_check_sngl (gfc_expr *);
 gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_srand (gfc_expr *);
 gfc_try gfc_check_stat (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -494,6 +496,7 @@ void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
 void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
 void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind);
 void gfc_resolve_srand (gfc_code *);
 void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index f354312781b..c09ae9738fa 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2319,6 +2319,18 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u)
 
 
 void
+gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
+			  gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
 gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
   const char *name;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 0b737b0e42a..b899618b60c 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3885,6 +3885,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 
   if (ss == gfc_ss_terminator)
     {
+      if (arg->ts.type == BT_CLASS)
+	gfc_add_component_ref (arg, "$data");
+
       gfc_conv_expr_reference (&argse, arg);
 
       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@@ -3934,6 +3937,56 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 }
 
 
+static void
+gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
+{
+  gfc_expr *arg;
+  gfc_ss *ss;
+  gfc_se argse,eight;
+  tree type, result_type, tmp;
+
+  arg = expr->value.function.actual->expr;
+  gfc_init_se (&eight, NULL);
+  gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
+  
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (arg);
+  result_type = gfc_get_int_type (expr->ts.kind);
+
+  if (ss == gfc_ss_terminator)
+    {
+      if (arg->ts.type == BT_CLASS)
+      {
+	gfc_add_component_ref (arg, "$vptr");
+	gfc_add_component_ref (arg, "$size");
+	gfc_conv_expr (&argse, arg);
+	tmp = fold_convert (result_type, argse.expr);
+	goto done;
+      }
+
+      gfc_conv_expr_reference (&argse, arg);
+      type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, 
+						     argse.expr));
+    }
+  else
+    {
+      argse.want_pointer = 0;
+      gfc_conv_expr_descriptor (&argse, arg, ss);
+      type = gfc_get_element_type (TREE_TYPE (argse.expr));
+    }
+    
+  /* Obtain the argument's word length.  */
+  if (arg->ts.type == BT_CHARACTER)
+    tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
+  else
+    tmp = fold_convert (result_type, size_in_bytes (type)); 
+
+done:
+  se->expr = fold_build2 (MULT_EXPR, result_type, tmp, eight.expr);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+}
+
+
 /* Intrinsic string comparison functions.  */
 
 static void
@@ -5270,9 +5323,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_SIZEOF:
+    case GFC_ISYM_C_SIZEOF:
       gfc_conv_intrinsic_sizeof (se, expr);
       break;
 
+    case GFC_ISYM_STORAGE_SIZE:
+      gfc_conv_intrinsic_storage_size (se, expr);
+      break;
+
     case GFC_ISYM_SPACING:
       gfc_conv_intrinsic_spacing (se, expr);
       break;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4fe71948218..52a54e9da28 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2010-07-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44649
+	* gfortran.dg/c_sizeof_1.f90: Modified.
+	* gfortran.dg/storage_size_1.f08: New.
+	* gfortran.dg/storage_size_2.f08: New.
+
 2010-07-08  Mikael Pettersson  <mikpe@it.uu.se>
 
 	* gcc.c-torture/execute/20100708-1.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/c_sizeof_1.f90 b/gcc/testsuite/gfortran.dg/c_sizeof_1.f90
index f2a5caf6864..b30bdc5285e 100644
--- a/gcc/testsuite/gfortran.dg/c_sizeof_1.f90
+++ b/gcc/testsuite/gfortran.dg/c_sizeof_1.f90
@@ -1,8 +1,12 @@
 ! { dg-do run }
 ! Support F2008's c_sizeof()
 !
-integer(4) :: i, j(10)
-character(4),parameter :: str(1) = "abcd"
+use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr
+
+integer(kind=c_int) :: i, j(10)
+character(kind=c_char,len=4),parameter :: str(1) = "abcd"
+type(c_ptr) :: cptr
+integer(c_intptr_t) :: iptr
 
 ! Using F2008's C_SIZEOF
 i = c_sizeof(i)
@@ -18,9 +22,10 @@ i = c_sizeof(str(1))
 if (i /= 4) call abort()
 
 i = c_sizeof(str(1)(1:3))
-print *, i
 if (i /= 3) call abort()
 
+write(*,*) c_sizeof(cptr), c_sizeof(iptr), c_sizeof(C_NULL_PTR)
+
 ! Using GNU's SIZEOF
 i = sizeof(i)
 if (i /= 4) call abort()
@@ -36,5 +41,6 @@ if (i /= 4) call abort()
 
 i = sizeof(str(1)(1:3))
 if (i /= 3) call abort()
+
 end
 
diff --git a/gcc/testsuite/gfortran.dg/storage_size_1.f08 b/gcc/testsuite/gfortran.dg/storage_size_1.f08
new file mode 100644
index 00000000000..ade9dfc30b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/storage_size_1.f08
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! PR 44649: [OOP] F2008: storage_size intrinsic
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+type :: t
+  integer(4) :: i
+  real(4) :: r
+end type
+
+type,extends(t) :: t2
+  integer(4) :: j
+end type
+
+type(t) :: a
+type(t), dimension(1:3) :: b
+class(t), allocatable :: cp
+
+allocate(t2::cp)
+
+if (sizeof(a)        /=  8) call abort()
+if (storage_size(a)  /= 64) call abort()
+
+if (sizeof(b)        /= 24) call abort()
+if (storage_size(b)  /= 64) call abort()
+
+if (sizeof(cp)       /=  8) call abort()
+if (storage_size(cp) /= 96) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/storage_size_2.f08 b/gcc/testsuite/gfortran.dg/storage_size_2.f08
new file mode 100644
index 00000000000..50de9575e74
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/storage_size_2.f08
@@ -0,0 +1,27 @@
+! { dg-do compile }
+!
+! PR 44649: [OOP] F2008: storage_size intrinsic
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+use iso_c_binding, only: c_int
+
+type, bind(c) :: t 
+  integer(c_int) :: j
+end type
+
+integer(4) :: i1
+integer(c_int) :: i2
+type(t) :: x
+
+print *,c_sizeof(i1)                ! { dg-error "must be be an interoperable data entity" }
+print *,c_sizeof(i2)
+print *,c_sizeof(x)
+print *, c_sizeof(ran())            ! { dg-error "must be be an interoperable data entity" }
+
+print *,storage_size(1.0,4)
+print *,storage_size(1.0,3.2)       ! { dg-error "must be INTEGER" }
+print *,storage_size(1.0,(/1,2/))   ! { dg-error "must be a scalar" }
+print *,storage_size(1.0,irand())   ! { dg-error "must be a constant" }
+
+end