Automatic allocation of string in recursive function unexpected result [issue with `ifx` and bug in `gfortran` and `nvfortran`]

eelis · October 30, 2024, 5:43pm

I am playing around with this function

recursive function to_string(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//to_string(tree%l)//"+"//to_string(tree%r)//")"
case(2)
  out="("//to_string(tree%l)//"-"//to_string(tree%r)//")"
case(3)
  out="("//to_string(tree%l)//"*"//to_string(tree%r)//")"
case(4)
  out="("//to_string(tree%l)//"/"//to_string(tree%r)//")"
end select
  out=trim(out)
end function to_string

It produces randomly unexpected results.
If I replace it with

recursive function to_string_trim(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
case(2)
  out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
case(3)
  out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
case(4)
  out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
end select
end function to_string_trim

It works as expected.

Here is the whole code if you wish to try:

implicit none
type :: btree_t
  integer :: id=0
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type :: dummy_t
end type
type :: btree_p
  type(btree_t), pointer :: p=>null()
end type
interface operator(.op.)
  procedure op_dummy_dummy
  procedure op_dummy_btree
  procedure op_btree_dummy
  procedure op_btree_btree
end interface
type(btree_t), pointer :: e
type(dummy_t) :: a
type(btree_p) :: trees(6)
integer, allocatable :: operators(:)
real, allocatable :: values(:)
trees(1) % p=>((a.op.a).op.a).op.a
trees(2) % p=>(a.op.(a.op.a)).op.a
trees(3) % p=>(a.op.a).op.(a.op.a)
trees(4) % p=>((a.op.a).op.a).op.a
trees(5) % p=>(a.op.(a.op.a)).op.a
trees(6) % p=>(a.op.a).op.(a.op.a)
call swap(trees(4) % p)
call swap(trees(5) % p)
call swap(trees(6) % p)
block
integer :: itree
integer :: iop, jop, kop
!tree_loop: do itree=1,6
!do iop=1,4; do jop=1,4; do kop=1,4
itree=3
  e=>trees(itree)%p
  iop=3;jop=2;kop=3
  operators=[iop,jop,kop]
  values=[1.,1.,1.,13.]
  call filltree(e, operators, values)
!  if (eval(e)==24) exit tree_loop
!  print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop !this doesn't print correctly
  print"(a,a,i0,4x,3(i0,x))",to_string_trim(e),"=",int(eval(e)),iop,jop,kop
!enddo;enddo;enddo
!end do tree_loop
!print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop
end block
contains


function op_dummy_dummy(v1,v2) result(out)
type(dummy_t), intent(in) :: v1
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: a, b, out
allocate(out, a, b)
out%l=>a
out%r=>b
end function op_dummy_dummy 


function op_btree_dummy(a,v2) result(out)
type(btree_t), intent(in), pointer :: a
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: b, out
allocate(out, b)
out%l=>a
out%r=>b
end function op_btree_dummy


function op_dummy_btree(v1,b) result(out)
type(dummy_t), intent(in) :: v1
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: a, out
allocate(out, a)
out%l=>a
out%r=>b
end function op_dummy_btree


function op_btree_btree(a,b) result(out)
type(btree_t), intent(in), pointer :: a
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: out
allocate(out)
out%l=>a
out%r=>b
end function op_btree_btree


recursive subroutine filltree(tree, operators, values)
type(btree_t), pointer :: tree, first, second
integer, allocatable :: operators(:)
integer, allocatable :: nextops(:)
real :: values(:)
if (associated(tree%l).and.associated(tree%r)) then
  tree%binop=operators(1)
  operators=operators(2:)
  call filltree(tree%l, operators, values)
  call filltree(tree%r, operators, values)
else
  tree%v=values(1)
  values=values(2:)
end if
end subroutine filltree


recursive subroutine swap(tree)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
if (tree%binop>0) then
  call swap(a)
  call swap(b)
  tree%l=>b
  tree%r=>a
end if
end subroutine swap


real recursive function eval(tree) result(out)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
select case (tree%binop)
case(0)
  out=tree%v
case(1)
  out=eval(a)+eval(b)
case(2)
  out=eval(a)-eval(b)
case(3)
  out=eval(a)*eval(b)
case(4)
  out=eval(a)/eval(b)
end select
end function eval


recursive function to_string_l(tree) result(out)
  type(btree_t), pointer :: tree
  character(len=100) :: out
  character(len=1024) :: ch
  select case(tree%binop)
  case(0)
    write(ch,"(i0)") int(tree%v)
    out=trim(ch)
  case(1)
    out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
  case(2)
    out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
  case(3)
    out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
  case(4)
    out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
  end select
end function to_string_l


recursive function to_string_trim(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
case(2)
  out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
case(3)
  out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
case(4)
  out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
end select
end function to_string_trim


recursive function to_string(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//to_string(tree%l)//"+"//to_string(tree%r)//")"
case(2)
  out="("//to_string(tree%l)//"-"//to_string(tree%r)//")"
case(3)
  out="("//to_string(tree%l)//"*"//to_string(tree%r)//")"
case(4)
  out="("//to_string(tree%l)//"/"//to_string(tree%r)//")"
end select
  out=trim(out)
end function to_string
end

example output:
unexpected: ((1(1*13))=0 3 2 3
expected: ((1-1)*(1*13))=0 3 2 3

Can someone explain why this happens? Moreover, if you change the tree (itree) then it works as expected to some other cases.

eelis · November 1, 2024, 3:38pm

When I compile with ifx, I get compiler errors, like this

bintree.f90(25): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy argument.   [OP_DUMMY_DUMMY]
trees(1) % p=>((a.op.a).op.a).op.a
-----------------^

I don’t have this issue with gfortran. Do you think this is standard conforming behavior? Or should I report it?

But, to compile, I needed to change the program a bit:

implicit none
type :: btree_t
  integer :: id=0
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type :: dummy_t
end type
type :: btree_p
  type(btree_t), pointer :: p=>null()
end type
interface operator(.op.)
  procedure op_dummy_dummy
  procedure op_dummy_btree
  procedure op_btree_dummy
  procedure op_btree_btree
end interface
interface op
  procedure op_dummy_dummy
  procedure op_dummy_btree
  procedure op_btree_dummy
  procedure op_btree_btree
end interface
type(btree_t), pointer :: e
type(dummy_t) :: a
type(btree_p) :: trees(6)
integer, allocatable :: operators(:)
real, allocatable :: values(:)
trees(1) % p=>op(op(op(a,a),a),a)
trees(2) % p=>op(op(a,op(a,a)),a)
trees(3) % p=>op(op(a,a),op(a,a))
trees(4) % p=>op(op(op(a,a),a),a)
trees(5) % p=>op(op(a,op(a,a)),a)
trees(6) % p=>op(op(a,a),op(a,a))
call swap(trees(4) % p)
call swap(trees(5) % p)
call swap(trees(6) % p)
block
integer :: itree
integer :: iop, jop, kop
!tree_loop: do itree=1,6
!do iop=1,4; do jop=1,4; do kop=1,4
itree=3
  e=>trees(itree)%p
  iop=3;jop=2;kop=3
  operators=[iop,jop,kop]
  values=[1.,1.,1.,13.]
  call filltree(e, operators, values)
!  if (eval(e)==24) exit tree_loop
!  print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop !this doesn't print correctly
  print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop
!enddo;enddo;enddo
!end do tree_loop
!print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop
end block
contains


function op_dummy_dummy(v1,v2) result(out)
type(dummy_t), intent(in) :: v1
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: a, b, out
allocate(out, a, b)
out%l=>a
out%r=>b
end function op_dummy_dummy 


function op_btree_dummy(a,v2) result(out)
type(btree_t), intent(in), pointer :: a
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: b, out
allocate(out, b)
out%l=>a
out%r=>b
end function op_btree_dummy


function op_dummy_btree(v1,b) result(out)
type(dummy_t), intent(in) :: v1
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: a, out
allocate(out, a)
out%l=>a
out%r=>b
end function op_dummy_btree


function op_btree_btree(a,b) result(out)
type(btree_t), intent(in), pointer :: a
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: out
allocate(out)
out%l=>a
out%r=>b
end function op_btree_btree


recursive subroutine filltree(tree, operators, values)
type(btree_t), pointer :: tree, first, second
integer, allocatable :: operators(:)
integer, allocatable :: nextops(:)
real :: values(:)
if (associated(tree%l).and.associated(tree%r)) then
  tree%binop=operators(1)
  operators=operators(2:)
  call filltree(tree%l, operators, values)
  call filltree(tree%r, operators, values)
else
  tree%v=values(1)
  values=values(2:)
end if
end subroutine filltree


recursive subroutine swap(tree)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
if (tree%binop>0) then
  call swap(a)
  call swap(b)
  tree%l=>b
  tree%r=>a
end if
end subroutine swap


real recursive function eval(tree) result(out)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
select case (tree%binop)
case(0)
  out=tree%v
case(1)
  out=eval(a)+eval(b)
case(2)
  out=eval(a)-eval(b)
case(3)
  out=eval(a)*eval(b)
case(4)
  out=eval(a)/eval(b)
end select
end function eval


recursive function to_string_l(tree) result(out)
  type(btree_t), pointer :: tree
  character(len=100) :: out
  character(len=1024) :: ch
  select case(tree%binop)
  case(0)
    write(ch,"(i0)") int(tree%v)
    out=trim(ch)
  case(1)
    out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
  case(2)
    out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
  case(3)
    out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
  case(4)
    out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
  end select
end function to_string_l


recursive function to_string_trim(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
case(2)
  out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
case(3)
  out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
case(4)
  out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
end select
end function to_string_trim


recursive function to_string(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//to_string(tree%l)//"+"//to_string(tree%r)//")"
case(2)
  out="("//to_string(tree%l)//"-"//to_string(tree%r)//")"
case(3)
  out="("//to_string(tree%l)//"*"//to_string(tree%r)//")"
case(4)
  out="("//to_string(tree%l)//"/"//to_string(tree%r)//")"
end select
  out=trim(out)
end function to_string
end

Then it works correctly. Moreover, I get expected results from both functions. Even with the modified program, gfortran produces unexpected results. So I think gfortran has a bug.

edit.
nvfortran accepts both versions and output unexpected

(0*0)=0    3 2 3

So, my understanding is that

ifx has a restriction that is not standard conforming (gfortran and nvfortran accept it) => I guess I should report it?
gfortran has some bug that produces unexpected results => I’ll have to report that.
nvfortran has a bug too

septc · November 1, 2024, 7:49pm

I’ve just tried the code (but have not read the program yet because very complicated…). Gfortran with no options indeed gave the “unexpected” results ((1(1*13))=0 3 2 3 (even with target attached to all variables on the caller side), but gfortran -fcheck=all gave this runtime error:

At line 113 of file test.f90
Fortran runtime error: Array bound mismatch for dimension 1 of array 'values' (4/3)

So some problem might exist besides the possible issue of pointers or compiler bugs…?

martin · November 2, 2024, 7:04am

Fortran has a bug, creating a static variable for length of auxiliary character variables in complex concatenation expressions like this. With recursive functions this, it might cause bugs like this. See bug: deferred length…

cmaapic · November 2, 2024, 1:56pm

Nag reports an error

C:\document\fortran\4th_edition_update\examples>nagfor fortran_discourse_04.f90
NAG Fortran Compiler Release 7.2(Shin-Urayasu) Build 7211
Extension(NAG): fortran_discourse_04.f90, line 53: Missing blank between PRINT and character constant
detected at PRINT@‘(a,a,i0,4x,3(i0,x))’
Warning: fortran_discourse_04.f90, line 68: Unused dummy variable V1
Warning: fortran_discourse_04.f90, line 68: Unused dummy variable V2
Warning: fortran_discourse_04.f90, line 78: Unused dummy variable V2
Warning: fortran_discourse_04.f90, line 88: Unused dummy variable V1
Warning: fortran_discourse_04.f90, line 115: Unused local variable FIRST
Warning: fortran_discourse_04.f90, line 115: Unused local variable NEXTOPS
Warning: fortran_discourse_04.f90, line 115: Unused local variable SECOND
Error: fortran_discourse_04.f90, line 53: No spacing specified for X edit descriptor
[NAG Fortran Compiler error termination, 1 error, 8 warnings]

and won’t compile it.

septc · November 2, 2024, 4:28pm

I remember a similar problem posted some time ago about the result variable of allocatable character string (with OpenMP, replied by @martin with a link to the bug report 113797)

If this may be related, the runtime error I encountered above might also be a result / side effect of the same possible bug… (but here without OpenMP). FWIW, the last part of the above bug report says:

  typedef character(kind=1) struct
  character(kind=1)[1:slen.1][1:slen.1];
  pstr.2 = 0B;
  slen.1 = 0;
Maybe the order here. slen.1 should be set to 0 before the use inside the typedef.
That is kinda of the reason why static works (with not openmp)

Also FWIW, I’ve tried changing the main program to a subroutine (to avoid the complication of the main program), and “-fsanitize=address” gave a memory leak of >1300 bytes.

A workaround might be to wrap the allocatable string to a derived type (like “variable string”) and use it throughout (including the result variables), or more conveniently, use some existing library for a wrapped string type, but the possible compiler bug above (not sure yet) remains…

eelis · November 4, 2024, 3:03pm

Thank you for posting the output of Nag compiler. It looks like you are using the version that was modified for ifx because it could not handle the pointer valued function through an operator. Did you try the original code with the operator approach?

I have to say, I don’t understand why Nag reports an error. I see that it is pointing at the print statement. However, I don’t see any problem with it and other compilers seem to be fine with it. Are you able to modify it so that Nag is happy with it?

eelis · November 4, 2024, 3:04pm

@martin and @septc, thank you for the information! It indeed looks like a similar issue.

eelis · November 4, 2024, 4:53pm

I tried with lfortran, with the original code I get:

lfortran bintree_original.f90
syntax error: Token '::' is unexpected here
 --> bintree_original.f90:2:6
  |
2 | type :: btree_t
  |      ^^ 

syntax error: Token 'end type' is unexpected here
 --> bintree_original.f90:8:1
  |
8 | end type
  | ^^^^^^^^ 

syntax error: Token 'end type' is unexpected here
  --> bintree_original.f90:13:1
   |
13 | end type
   | ^^^^^^^^ 


Note: Please report unclear, confusing or incorrect messages as bugs at
https://github.com/lfortran/lfortran/issues.

This is likely due to missing program statement at the start of the program. However, when I add it, then I see

lfortran bintree_with_program.f90 
semantic error: `op` is not defined in the Struct: `dummy_t`
  --> bintree_with_program.f90:26:17
   |
26 | trees(1) % p=>((a.op.a).op.a).op.a
   |                 ^^^^^^ 


Note: Please report unclear, confusing or incorrect messages as bugs at
https://github.com/lfortran/lfortran/issues.

I wonder if the first one is a “known issue”? @certik? The other is more exotic so I can report it.

certik · November 4, 2024, 5:14pm

@eelis thanks for trying it. Yes, go ahead and report both bugs, we’ll fix it.

eelis · November 4, 2024, 7:52pm

Thanks for the reply! I reported this for now: type cannot be declared without program · Issue #5250 · lfortran/lfortran · GitHub because it is simple. I am still working on the main issue and will report it.

martin · November 5, 2024, 9:53am

A static (i.e. global) variable is fatal both with multiple threads as well as with recursive calls. So it is no surprise that this bug bites in both circumstances.

If there is a short reproducer, then it would probably be helpful to add it to the gfortran bug report as additional testcase. It also shows that this is a broader issue.

cmaapic · November 5, 2024, 12:18pm

It is a question of standard conformance The Nag compiler message is

Error: fortran_discourse_04.f90, line 53: No spacing specified for X edit descriptor
[NAG Fortran Compiler error termination, 1 error, 8 warnings]

Line 53

print"(a,a,i0,4x,3(i0,x))“,to_string(e),”=",int(eval(e)),iop,jop,kop
^
No spacing specified for X edit descriptor

Here are extracts from the Fortran 2018 and Fortran 2023 standards.

13.8.1.3 X editing

The nX edit descriptor indicates that the transmission of the next character to or from a record is
to occur at The nX edit descriptor indicates that the transmission of the next ch
the character position n characters forward from the current position.

The following is taken from the Fortran 2018 standard

13.8.1.3 X editing
1 The nX edit descriptor indicates that the transmission of the next character to or from a record is to occur at
the character position n characters forward from the current position.

Apologies about the loss of formatting. I

Ian

eelis · November 5, 2024, 7:14pm

Here is a short reproducer:

implicit none
type :: btree_t
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type(btree_t), pointer :: e
type(btree_t), pointer :: b1, b2, b3, b4, left, right
allocate(e, b1, b2, b3, b4, left, right)
left % l => b1
left % r => b2
right % l => b3
right % r => b4
e % l => left
e % r => right
e % binop=3
left%binop=2
right%binop=3
b1%v=1.
b2%v=1.
b3%v=1.
b4%v=13.
print "(a)",to_string(e)
contains


recursive function to_string(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//to_string(tree%l)//"+"//to_string(tree%r)//")"
case(2)
  out="("//to_string(tree%l)//"-"//to_string(tree%r)//")"
case(3)
  out="("//to_string(tree%l)//"*"//to_string(tree%r)//")"
case(4)
  out="("//to_string(tree%l)//"/"//to_string(tree%r)//")"
end select
  out=trim(out)
end function to_string
end

It should give the same problem as the original.
Here is the working version (with trim()):

implicit none
type :: btree_t
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type(btree_t), pointer :: e
type(btree_t), pointer :: b1, b2, b3, b4, left, right
allocate(e, b1, b2, b3, b4, left, right)
left % l => b1
left % r => b2
right % l => b3
right % r => b4
e % l => left
e % r => right
e % binop=3
left%binop=2
right%binop=3
b1%v=1.
b2%v=1.
b3%v=1.
b4%v=13.
print "(a)",to_string_trim(e)
contains


recursive function to_string_trim(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//trim(to_string_trim(tree%l))//"+"//trim(to_string_trim(tree%r))//")"
case(2)
  out="("//trim(to_string_trim(tree%l))//"-"//trim(to_string_trim(tree%r))//")"
case(3)
  out="("//trim(to_string_trim(tree%l))//"*"//trim(to_string_trim(tree%r))//")"
case(4)
  out="("//trim(to_string_trim(tree%l))//"/"//trim(to_string_trim(tree%r))//")"
end select
end function to_string_trim
end

Edit. Interesting, nvfortran produces correct result with this, but not with the original code.

eelis · November 5, 2024, 7:17pm

OK, thanks! I think I see the problem now: so we should not have edit descriptor x but we should always put the spacing as well 1x, even if it is just “one”. So standard does not allow to omit it.

What if you run this:

implicit none
type :: btree_t
  integer :: id=0
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type :: dummy_t
end type
type :: btree_p
  type(btree_t), pointer :: p=>null()
end type
interface operator(.op.)
  procedure op_dummy_dummy
  procedure op_dummy_btree
  procedure op_btree_dummy
  procedure op_btree_btree
end interface
type(btree_t), pointer :: e
type(dummy_t) :: a
type(btree_p) :: trees(6)
integer, allocatable :: operators(:)
real, allocatable :: values(:)
trees(1) % p=>((a.op.a).op.a).op.a
trees(2) % p=>(a.op.(a.op.a)).op.a
trees(3) % p=>(a.op.a).op.(a.op.a)
trees(4) % p=>((a.op.a).op.a).op.a
trees(5) % p=>(a.op.(a.op.a)).op.a
trees(6) % p=>(a.op.a).op.(a.op.a)
call swap(trees(4) % p)
call swap(trees(5) % p)
call swap(trees(6) % p)
block
integer :: itree
integer :: iop, jop, kop
!tree_loop: do itree=1,6
!do iop=1,4; do jop=1,4; do kop=1,4
itree=3
  e=>trees(itree)%p
  iop=3;jop=2;kop=3
  operators=[iop,jop,kop]
  values=[1.,1.,1.,13.]
  call filltree(e, operators, values)
!  if (eval(e)==24) exit tree_loop
!  print "(a,a,i0,4x,3(i0,1x))",to_string(e),"=",int(eval(e)),iop,jop,kop !this doesn't print correctly
  print "(a,a,i0,4x,3(i0,1x))",to_string_trim(e),"=",int(eval(e)),iop,jop,kop
!enddo;enddo;enddo
!end do tree_loop
!print"(a,a,i0,4x,3(i0,x))",to_string(e),"=",int(eval(e)),iop,jop,kop
end block
contains


function op_dummy_dummy(v1,v2) result(out)
type(dummy_t), intent(in) :: v1
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: a, b, out
allocate(out, a, b)
out%l=>a
out%r=>b
end function op_dummy_dummy 


function op_btree_dummy(a,v2) result(out)
type(btree_t), intent(in), pointer :: a
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: b, out
allocate(out, b)
out%l=>a
out%r=>b
end function op_btree_dummy


function op_dummy_btree(v1,b) result(out)
type(dummy_t), intent(in) :: v1
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: a, out
allocate(out, a)
out%l=>a
out%r=>b
end function op_dummy_btree


function op_btree_btree(a,b) result(out)
type(btree_t), intent(in), pointer :: a
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: out
allocate(out)
out%l=>a
out%r=>b
end function op_btree_btree


recursive subroutine filltree(tree, operators, values)
type(btree_t), pointer :: tree, first, second
integer, allocatable :: operators(:)
integer, allocatable :: nextops(:)
real :: values(:)
if (associated(tree%l).and.associated(tree%r)) then
  tree%binop=operators(1)
  operators=operators(2:)
  call filltree(tree%l, operators, values)
  call filltree(tree%r, operators, values)
else
  tree%v=values(1)
  values=values(2:)
end if
end subroutine filltree


recursive subroutine swap(tree)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
if (tree%binop>0) then
  call swap(a)
  call swap(b)
  tree%l=>b
  tree%r=>a
end if
end subroutine swap


real recursive function eval(tree) result(out)
type(btree_t), pointer :: tree,a,b
a=>tree%l
b=>tree%r
select case (tree%binop)
case(0)
  out=tree%v
case(1)
  out=eval(a)+eval(b)
case(2)
  out=eval(a)-eval(b)
case(3)
  out=eval(a)*eval(b)
case(4)
  out=eval(a)/eval(b)
end select
end function eval


recursive function to_string_l(tree) result(out)
  type(btree_t), pointer :: tree
  character(len=100) :: out
  character(len=1024) :: ch
  select case(tree%binop)
  case(0)
    write(ch,"(i0)") int(tree%v)
    out=trim(ch)
  case(1)
    out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
  case(2)
    out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
  case(3)
    out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
  case(4)
    out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
  end select
end function to_string_l


recursive function to_string_trim(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//trim(to_string(tree%l))//"+"//trim(to_string(tree%r))//")"
case(2)
  out="("//trim(to_string(tree%l))//"-"//trim(to_string(tree%r))//")"
case(3)
  out="("//trim(to_string(tree%l))//"*"//trim(to_string(tree%r))//")"
case(4)
  out="("//trim(to_string(tree%l))//"/"//trim(to_string(tree%r))//")"
end select
end function to_string_trim


recursive function to_string(tree) result(out)
type(btree_t), pointer :: tree
character(len=:), allocatable :: out
character(len=1024) :: ch
select case(tree%binop)
case(0)
  write(ch,"(i0)") int(tree%v)
  out=trim(ch)
case(1)
  out="("//to_string(tree%l)//"+"//to_string(tree%r)//")"
case(2)
  out="("//to_string(tree%l)//"-"//to_string(tree%r)//")"
case(3)
  out="("//to_string(tree%l)//"*"//to_string(tree%r)//")"
case(4)
  out="("//to_string(tree%l)//"/"//to_string(tree%r)//")"
end select
  out=trim(out)
end function to_string
end

eelis · November 5, 2024, 7:37pm

I reported another one Segmentation fault at compile time · Issue #5262 · lfortran/lfortran · GitHub (code slightly modified due to issue #5250)

edit.

Here is another one: Operator mistaken for a member of a "Struct" · Issue #5263 · lfortran/lfortran · GitHub (this is actually the first I noticed that I wanted to report)

eelis · November 5, 2024, 7:53pm

This is the short producer of the issue I have with ifx:

program test
implicit none
type :: btree_t
  integer :: id=0
  type(btree_t), pointer :: l=>null()
  type(btree_t), pointer :: r=>null()
  integer :: binop=0
  real :: v=0
end type
type :: dummy_t
end type
type :: btree_p
  type(btree_t), pointer :: p=>null()
end type
interface operator(.op.)
  procedure op_dummy_dummy
  procedure op_dummy_btree
  procedure op_btree_dummy
  procedure op_btree_btree
end interface
type(btree_t), pointer :: e
type(dummy_t) :: a
type(btree_p) :: trees(6)
integer, allocatable :: operators(:)
real, allocatable :: values(:)
trees(1) % p=>((a.op.a).op.a).op.a
trees(2) % p=>(a.op.(a.op.a)).op.a
trees(3) % p=>(a.op.a).op.(a.op.a)
trees(4) % p=>((a.op.a).op.a).op.a
trees(5) % p=>(a.op.(a.op.a)).op.a
trees(6) % p=>(a.op.a).op.(a.op.a)
contains


function op_dummy_dummy(v1,v2) result(out)
type(dummy_t), intent(in) :: v1
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: a, b, out
allocate(out, a, b)
out%l=>a
out%r=>b
end function op_dummy_dummy 


function op_btree_dummy(a,v2) result(out)
type(btree_t), intent(in), pointer :: a
type(dummy_t), intent(in) :: v2
type(btree_t), pointer :: b, out
allocate(out, b)
out%l=>a
out%r=>b
end function op_btree_dummy


function op_dummy_btree(v1,b) result(out)
type(dummy_t), intent(in) :: v1
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: a, out
allocate(out, a)
out%l=>a
out%r=>b
end function op_dummy_btree


function op_btree_btree(a,b) result(out)
type(btree_t), intent(in), pointer :: a
type(btree_t), intent(in), pointer :: b
type(btree_t), pointer :: out
allocate(out)
out%l=>a
out%r=>b
end function op_btree_btree
end program test

Output:

bintree_build.f90(26): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(1) % p=>((a.op.a).op.a).op.a
-----------------^
bintree_build.f90(26): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_BTREE_DUMMY]
trees(1) % p=>((a.op.a).op.a).op.a
-----------------------^
bintree_build.f90(27): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(2) % p=>(a.op.(a.op.a)).op.a
----------------------^
bintree_build.f90(27): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_BTREE]
trees(2) % p=>(a.op.(a.op.a)).op.a
----------------^
bintree_build.f90(28): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(3) % p=>(a.op.a).op.(a.op.a)
----------------^
bintree_build.f90(28): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(3) % p=>(a.op.a).op.(a.op.a)
----------------------------^
bintree_build.f90(29): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(4) % p=>((a.op.a).op.a).op.a
-----------------^
bintree_build.f90(29): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_BTREE_DUMMY]
trees(4) % p=>((a.op.a).op.a).op.a
-----------------------^
bintree_build.f90(30): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(5) % p=>(a.op.(a.op.a)).op.a
----------------------^
bintree_build.f90(30): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_BTREE]
trees(5) % p=>(a.op.(a.op.a)).op.a
----------------^
bintree_build.f90(31): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(6) % p=>(a.op.a).op.(a.op.a)
----------------^
bintree_build.f90(31): error #7496: A non-pointer actual argument shall have a TARGET attribute when associated with a pointer dummy 
argument.   [OP_DUMMY_DUMMY]
trees(6) % p=>(a.op.a).op.(a.op.a)
----------------------------^
compilation aborted for bintree_build.f90 (code 1)

Any ifx aficionados here? How do we report this? (I have never filed an ifx bug report)

certik · November 5, 2024, 8:20pm

@eelis awesome thank you! Much appreciated.

themos · November 6, 2024, 4:01pm

Hmm.

violates the rules (10.2.1.2 Intrinsic assignment statement, par 1, section(3), lines 9-10 of J3/24-007) of standard Fortran, VALUES being a non-allocatable array that is not conformable to VALUES(2:).

themos · November 7, 2024, 12:13pm

You may want to consider this code which gets around the ifx error message. For now, I think ifx is wrong to issue that error message. But data-pointer function-results may still have unclear or contradictory behaviour in the Standard. Anyone have a clear, complete understanding of this?

type(btree_t), pointer :: q1, q2, q3
q1 => a .op. a
q2 => q1 .op. a
q3 => a .op. q1
trees(1)%p => q2 .op. a
trees(2)%p => q3 .op. a
trees(3)%p => q1 .op. q1
trees(4)%p => q2 .op. a
trees(5)%p => q3 .op. a
trees(6)%p => q1 .op. q1

Topic		Replies	Views
Recursively defined derived types - bug in gfortran?	8	1161	December 18, 2021
Does this program make sense? Help	10	409	November 29, 2023
Using select type on allocatable character Help	7	210	April 11, 2024
An error occurred when `gfortran/flang-old` used `associate` to receive an `allocatable` string Help	2	459	December 27, 2022
Findloc with allocatable character arrays gfortran Help	12	546	May 31, 2024

Automatic allocation of string in recursive function unexpected result [issue with `ifx` and bug in `gfortran` and `nvfortran`]

Related topics