+2013-03-27 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/56650
+ PR fortran/36437
+ * check.c (gfc_check_sizeof, gfc_check_c_sizeof,
+ gfc_check_storage_size): Update checks.
+ * intrinsic.texi (SIZEOF): Correct class.
+ * intrinsic.h (gfc_simplify_sizeof,
+ gfc_simplify_storage_size): New prototypes.
+ * intrinsic.c (add_functions): Use them.
+ * simplify.c (gfc_simplify_sizeof,
+ gfc_simplify_storage_size): New functions.
+
2013-03-27 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/25708
- * module.c (module_locus): Use long for position.
- (module_content): New variable.
- (module_pos): Likewise.
- (prev_character): Remove.
- (bad_module): Free data instead of closing mod file.
- (set_module_locus): Use module_pos.
- (get_module_locus): Likewise.
- (module_char): use buffer rather than stdio file.
- (module_unget_char): Likewise.
- (read_module_to_tmpbuf): New function.
- (gfc_use_module): Call read_module_to_tmpbuf.
+ * module.c (module_locus): Use long for position.
+ (module_content): New variable.
+ (module_pos): Likewise.
+ (prev_character): Remove.
+ (bad_module): Free data instead of closing mod file.
+ (set_module_locus): Use module_pos.
+ (get_module_locus): Likewise.
+ (module_char): use buffer rather than stdio file.
+ (module_unget_char): Likewise.
+ (read_module_to_tmpbuf): New function.
+ (gfc_use_module): Call read_module_to_tmpbuf.
2013-03-26 Tobias Burnus <burnus@net-b.de>
{
if (arg->ts.type == BT_PROCEDURE)
{
- gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return FAILURE;
}
+
+ if (arg->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &arg->where);
+ return FAILURE;
+ }
+
+ if (arg->rank && arg->expr_type == EXPR_VARIABLE
+ && arg->symtree->n.sym->as != NULL
+ && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+ && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+ "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &arg->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
return FAILURE;
}
+ if (arg->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+ "TYPE(*)",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &arg->where);
+ return FAILURE;
+ }
+
if (arg->rank && arg->expr_type == EXPR_VARIABLE
&& arg->symtree->n.sym->as != NULL
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
gfc_try
-gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
+gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
{
+ if (a->ts.type == BT_ASSUMED)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &a->where);
+ return FAILURE;
+ }
+
+ if (a->ts.type == BT_PROCEDURE)
+ {
+ gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
+ "procedure", gfc_current_intrinsic_arg[0]->name,
+ gfc_current_intrinsic, &a->where);
+ return FAILURE;
+ }
+
if (kind == NULL)
return SUCCESS;
make_from_module();
add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
- GFC_STD_GNU, gfc_check_sizeof, NULL, NULL,
+ GFC_STD_GNU, gfc_check_sizeof, gfc_simplify_sizeof, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
- gfc_check_c_sizeof, NULL, NULL,
+ gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
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,
+ gfc_check_storage_size, gfc_simplify_storage_size,
+ gfc_resolve_storage_size,
a, BT_UNKNOWN, 0, REQUIRED,
kind, BT_INTEGER, di, OPTIONAL);
gfc_expr *gfc_simplify_sin (gfc_expr *);
gfc_expr *gfc_simplify_sinh (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_sizeof (gfc_expr *);
+gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sngl (gfc_expr *);
gfc_expr *gfc_simplify_spacing (gfc_expr *);
gfc_expr *gfc_simplify_spread (gfc_expr *, gfc_expr *, gfc_expr *);
GNU extension
@item @emph{Class}:
-Intrinsic function
+Inquiry function
@item @emph{Syntax}:
@code{N = SIZEOF(X)}
#include "intrinsic.h"
#include "target-memory.h"
#include "constructor.h"
-#include "version.h" /* For version_string. */
+#include "tm.h" /* For BITS_PER_UNIT. */
+#include "version.h" /* For version_string. */
gfc_expr gfc_bad_expr;
}
+/* SIZEOF and C_SIZEOF return the size in bytes of an array element
+ multiplied by the array size. */
+
+gfc_expr *
+gfc_simplify_sizeof (gfc_expr *x)
+{
+ gfc_expr *result = NULL;
+ mpz_t array_size;
+
+ if (x->ts.type == BT_CLASS || x->ts.deferred)
+ return NULL;
+
+ if (x->ts.type == BT_CHARACTER
+ && (!x->ts.u.cl || !x->ts.u.cl->length
+ || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+ return NULL;
+
+ if (x->rank && x->expr_type != EXPR_ARRAY
+ && gfc_array_size (x, &array_size) == FAILURE)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &x->where);
+ mpz_set_si (result->value.integer, gfc_target_expr_size (x));
+
+ /* gfc_target_expr_size already takes the array size for array constructors
+ into account. */
+ if (x->rank && x->expr_type != EXPR_ARRAY)
+ {
+ mpz_mul (result->value.integer, result->value.integer, array_size);
+ mpz_clear (array_size);
+ }
+
+ return result;
+}
+
+
+/* STORAGE_SIZE returns the size in bits of a single array element. */
+
+gfc_expr *
+gfc_simplify_storage_size (gfc_expr *x,
+ gfc_expr *kind)
+{
+ gfc_expr *result = NULL;
+ int k;
+ size_t elt_size;
+
+ if (x->ts.type == BT_CLASS || x->ts.deferred)
+ return NULL;
+
+ if (x->ts.type == BT_CHARACTER
+ && (!x->ts.u.cl || !x->ts.u.cl->length
+ || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+ return NULL;
+
+ k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
+ if (k == -1)
+ return &gfc_bad_expr;
+
+ if (x->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *c = gfc_constructor_first (x->value.constructor);
+ elt_size = gfc_target_expr_size (c->expr);
+ }
+ else
+ elt_size = gfc_target_expr_size (x);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &x->where);
+ mpz_set_si (result->value.integer, elt_size);
+
+ mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
+ return result;
+}
+
+
gfc_expr *
gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{
+2013-03-27 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/56650
+ PR fortran/36437
+ * gfortran.dg/sizeof_2.f90: New.
+ * gfortran.dg/sizeof_3.f90: New.
+ * gfortran.dg/sizeof_proc.f90: Update dg-error.
+
2013-03-27 Richard Biener <rguenther@suse.de>
PR tree-optimization/37021
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/56650
+! PR fortran/36437
+!
+subroutine foo(x, y)
+ use iso_c_binding
+ type(*) :: x
+ integer :: y(*)
+ integer(8) :: ii
+ procedure() :: proc
+
+ ii = sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
+ ii = c_sizeof (x) ! { dg-error "shall not be TYPE\(.\)" }
+ ii = storage_size (x) ! { dg-error "shall not be TYPE\(.\)" }
+
+ ii = sizeof (y) ! { dg-error "shall not be an assumed-size array" }
+ ii = c_sizeof (y) ! { dg-error "shall not be an assumed-size array" }
+ ii = storage_size (y) ! okay, element-size is known
+
+ ii = sizeof (proc) ! { dg-error "shall not be a procedure" }
+ ii = c_sizeof (proc) ! { dg-error "Procedure unexpected as argument" }
+ ii = storage_size (proc) ! { dg-error "shall not be a procedure" }
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/56650
+! PR fortran/36437
+!
+module m
+ use iso_c_binding, only: c_sizeof, c_int
+ implicit none
+
+ integer(c_int), bind(C) :: MPI_Status_C_obj
+ integer,parameter :: MPI_STATUS_SIZE = c_sizeof(MPI_Status_C_obj)
+end module m
+
+module m2
+ use iso_c_binding, only: c_sizeof, c_int
+ implicit none
+
+ integer(c_int), bind(C) :: MPI_Status_C_obj2
+ integer,parameter :: MPI_STATUS_SIZE2 &
+ = c_sizeof(MPI_Status_C_obj2)*8/bit_size(0)
+end module m2
+
+subroutine test()
+ use m
+ use m2
+ integer :: m1test, m2test
+ m1test = MPI_STATUS_SIZE
+ m2test = MPI_STATUS_SIZE2
+end subroutine test
+
+type t
+ character(len=20) :: str
+end type t
+type(t):: x(5)
+integer :: iii, jjj
+iii = sizeof (x) ! 5*20 (whole size in bytes)
+jjj = storage_size (x) ! 8*20 (element size in bits)
+end
+
+! { dg-final { scan-tree-dump-times "m1test = 4;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "m2test = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iii = 100;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "jjj = 160;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
procedure(real), pointer :: pp
pp => sin
-print *,sizeof(proc) ! { dg-error "may not be a procedure" }
-print *,sizeof(pp) ! { dg-error "may not be a procedure" }
+print *,sizeof(proc) ! { dg-error "shall not be a procedure" }
+print *,sizeof(pp) ! { dg-error "shall not be a procedure" }
print *,sizeof(pp(0.))
-print *,sizeof(sub) ! { dg-error "may not be a procedure" }
-print *,sizeof(func) ! { dg-error "may not be a procedure" }
+print *,sizeof(sub) ! { dg-error "shall not be a procedure" }
+print *,sizeof(func) ! { dg-error "shall not be a procedure" }
print *,sizeof(func())
contains
projects / gcc.git / commitdiff