From 048510c866c4e2759a8e26abaa4bc47db98124c0 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 8 Jul 2010 23:29:56 +0200 Subject: re PR fortran/44649 ([OOP] F2008: storage_size intrinsic (also working for polymorphic types)) 2010-07-08 Janus Weil 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 PR fortran/44649 * gfortran.dg/c_sizeof_1.f90: Modified. * gfortran.dg/storage_size_1.f08: New. * gfortran.dg/storage_size_2.f08: New. From-SVN: r161977 --- gcc/fortran/check.c | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 27bd900..7578775 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; +} -- cgit v1.1