Hi Thomas,
Welcome back!
I was going to propose that we introduce -std=f2028 and to allow proposed
features to be run only if that option is selected; ie. not by default or
-std=gnu. gfortran.dg should have an f2028 directory as well.
I have already written and tested a patch for Reinhold Bader's proposed
assumed rank features, extended to include pointer assignment. Please see
the attached. I was so taken by his proposal because it is so intuitive and
easy to implement that I decided to pursue it in his memory. I will be
writing the standards boilerplate as well.
The likely timescale for implementation of f2028 is such that I am unlikely
to be around and so wanted to be sure that such test work as I do is
incorporated in gfortran. We have found in the past that experimental
branches are fraught with maintenance problems and tend to wither and die.
What do you think?
Regards
Paul
On Mon, 22 Jul 2024 at 22:21, Thomas Koenig <tkoe...@netcologne.de> wrote:
> Hi everybody,
>
> now that a proposal for unsigned number inclusion in Fortran has
> passed the J3 hurdle, https://j3-fortran.org/doc/year/24/24-116.txt ,
> I thought I would put my working hours where my mouth is and try
> my hand at a testbed implementation for gfortran. I am still
> grateful to Reinhold that he put this on the DIN list as a
> suggestion.
>
> I will use the text above as a preliminary spec. Of course, there
> is a chance that the feature may actually not make it into F2028,
> or that there would be differences, but that is what experimental
> work is for.
>
> As for my motivation, I hate having to drop to C because Fortran
> lacks a feature :-)
>
> Everything will be hidden behind a flag, tentatively called
> -funsigned, to allow inclusion into the compiler at a later date.
>
> The amount of work will be substantial, but not too difficult - mostly
> copying and modifying what already works for integers
>
> Putting the work on a public branch probably works best; I will
> do so in the next few days. As name, I will use fortran_unsigned,
> unless somebody has a better idea.
>
> As to when this will be finished... I don't know, it could already
> be somewhat usable before being complete. It is also work that can
> be split into many relatively small parts, just implementing one
> feature at a time.
>
> Best regards
>
> Thomas
>
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 09d1ebd95d2..4ff05a5c7dd 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -4340,7 +4340,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
/* The target must be either rank one or it must be simply contiguous
and F2008 must be allowed. */
- if (rvalue->rank != 1)
+ if (rvalue->rank != 1 && rvalue->rank != -1)
{
if (!gfc_is_simply_contiguous (rvalue, true, false))
{
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index de3d9e25911..dc4b737b647 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2972,6 +2972,8 @@ typedef struct gfc_association_list
gfc_expr *target;
+ gfc_array_ref *ar;
+
/* Used for inferring the derived type of an associate name, whose selector
is a sibling derived type function that has not yet been parsed. */
gfc_symbol *derived_types;
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index c35f2bdd183..aef601cffcc 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -286,7 +286,8 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
&a->expr->where, gfc_current_intrinsic);
ok = false;
}
- else if (a->expr->rank == -1 && !specific->inquiry)
+ else if (a->expr->rank == -1
+ && !(specific->inquiry || specific->id == GFC_ISYM_RESHAPE))
{
gfc_error ("Assumed-rank argument at %L is only permitted as actual "
"argument to intrinsic inquiry functions",
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 1851a8f94a5..48a9d134b1a 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1920,7 +1920,27 @@ gfc_match_associate (void)
gfc_association_list* a;
/* Match the next association. */
- if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
+ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES)
+ {
+ /* "Expected associate name at %C" would be better.
+ Change associate_3.f03 to match. */
+ gfc_error ("Expected association at %C");
+ goto assocListError;
+ }
+
+ newAssoc->ar = gfc_get_array_ref ();
+
+ /* Required for an assumed rank target. */
+ if (gfc_peek_char () == '('
+ && gfc_match_array_ref (newAssoc->ar, NULL, 0,
+ GFC_MAX_DIMENSIONS) != MATCH_YES)
+ {
+ gfc_error ("Bad array reference at %C");
+ goto assocListError;
+ }
+
+ /* Match the next association. */
+ if (gfc_match (" =>", newAssoc->name) != MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 79c810c86ba..4cadcb56afd 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5279,6 +5279,16 @@ parse_associate (void)
else
sym->attr.class_ok = 1;
}
+ else if (rank == -1 && a->ar)
+ {
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = a->ar->dimen;
+ sym->as->corank = a->ar->codimen;
+ sym->as->type = AS_DEFERRED;
+ sym->attr.dimension = 1;
+ sym->attr.codimension = sym->as->corank ? 1 : 0;
+ sym->attr.pointer = 1;
+ }
else if ((!sym->as && rank != 0)
|| (sym->as && sym->as->rank != rank))
{
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d7a0856fcca..c140c059dfa 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5824,7 +5824,8 @@ resolve_variable (gfc_expr *e)
{
if (!actual_arg
&& !(cs_base && cs_base->current
- && cs_base->current->op == EXEC_SELECT_RANK))
+ && (cs_base->current->op == EXEC_SELECT_RANK
+ || sym->attr.target)))
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bc8eb419cff..7716440c5e0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10637,20 +10637,26 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
- offs = gfc_conv_descriptor_offset_get (rse.expr);
- for (dim = 0; dim < expr2->rank; ++dim)
+ if (expr2->rank == -1)
+ gfc_conv_descriptor_offset_set (&block, desc,
+ gfc_index_zero_node);
+ else
{
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[dim]);
- lbound = gfc_conv_descriptor_lbound_get (rse.expr,
- gfc_rank_cst[dim]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, lbound);
- offs = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offs, tmp);
+ offs = gfc_conv_descriptor_offset_get (rse.expr);
+ for (dim = 0; dim < expr2->rank; ++dim)
+ {
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[dim]);
+ lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
}
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
stride = gfc_conv_descriptor_stride_get (rse.expr,
@@ -10662,6 +10668,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+ if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
+ || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
+ gfc_resolve_expr (remap->u.ar.start[dim]);
+ if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
+ || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
+ gfc_resolve_expr (remap->u.ar.end[dim]);
+
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index d355009fa5e..4f22471513a 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1905,6 +1905,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
/* Now all the other kinds of associate variable. */
+ else if (e->rank == -1 && sym->attr.pointer && sym->assoc->ar)
+ {
+ gfc_expr *expr1 = gfc_lval_expr_from_sym (sym);
+ gfc_free_ref_list (expr1->ref);
+ expr1->ref = gfc_get_ref();
+ expr1->ref->type = REF_ARRAY;
+ expr1->ref->u.ar = *sym->assoc->ar;
+ expr1->ref->u.ar.type = AR_SECTION;
+ gfc_expr *expr2 = gfc_copy_expr (e);
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
+ gfc_add_init_cleanup (block, tmp, NULL);
+ gfc_free_expr (expr1);
+ gfc_free_expr (expr2);
+ }
else if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
real :: x(2,2,2)
real, parameter :: xp(*) = [1,2,3,4,5,6,7,8]
x = reshape (xp, [2,2,2])
call my_sub (x)
if (any (reshape (x, [8]) .ne. xp(8:1:-1))) stop 1
contains
subroutine my_sub (arg)
real, target :: arg(..)
real, allocatable :: y(:)
real, pointer :: argp(:,:)
integer :: i
if (size (arg) .ne. 8) stop 10
! Check reshape
y = reshape (arg, [size (arg)])
if (any (y .ne. xp)) stop 20
! Check pointer assignment
argp(1:2,1: size(arg)/2) => arg
if (size (argp) .ne. size (x)) stop 30
if (any ((argp) .ne. reshape (x, [2, size (x)/2]))) stop 31
! Check ASSOCIATE (size (arg) does not work in the array ref yet)
i = size (arg)
associate (a(1:i) => arg)
if (any (a .ne. xp)) stop 40
a = a(8:1:-1)
end associate
end
end
