diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
18 files changed, 520 insertions, 28 deletions
diff --git a/gcc/testsuite/gfortran.dg/allocate_zerosize_1.f90 b/gcc/testsuite/gfortran.dg/allocate_zerosize_1.f90 new file mode 100644 index 00000000000..c482ea0f3b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_zerosize_1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +program main + implicit none + real, allocatable :: a(:), b(:,:) + integer :: n,m + character (len=2) :: one, two + + one = ' 1' + two = ' 2' + + allocate (a(1:-1)) + if (size(a) /= 0) call abort + deallocate (a) + + allocate (b(1:-1,0:10)) + if (size(b) /= 0) call abort + deallocate (b) + + ! Use variables for array bounds. The internal reads + ! are there to hide fact that these are actually constant. + + read (unit=one, fmt='(I2)') n + allocate (a(n:-1)) + if (size(a) /= 0) call abort + deallocate (a) + + read (unit=two, fmt='(I2)') m + allocate (b(1:3, m:0)) + if (size(b) /= 0) call abort + deallocate (b) +end program main diff --git a/gcc/testsuite/gfortran.dg/array_return_value_1.f90 b/gcc/testsuite/gfortran.dg/array_return_value_1.f90 new file mode 100644 index 00000000000..45699ffd7d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_return_value_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Tests the fix for PR27124 in which the unpacking of argument +! temporaries and of array result temporaries occurred in the +! incorrect order. +! +! Test is based on the original example, provided by +! Philippe Schaffnit <P.Schaffnit@access.rwth-aachen.de> +! + PROGRAM Test + INTEGER :: Array(2, 3) = reshape ((/1,4,2,5,3,6/),(/2,3/)) + integer :: Brray(2, 3) = 0 + Brray(1,:) = Function_Test (Array(1,:)) + if (any(reshape (Brray, (/6/)) .ne. (/11, 0, 12, 0, 13, 0/))) call abort () + Array(1,:) = Function_Test (Array(1,:)) + if (any(reshape (Array, (/6/)) .ne. (/11, 4, 12, 5, 13, 6/))) call abort () + + contains + FUNCTION Function_Test (Input) + INTEGER, INTENT(IN) :: Input(1:3) + INTEGER :: Function_Test(1:3) + Function_Test = Input + 10 + END FUNCTION Function_Test + END PROGRAM Test + diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90 index e10fd70b584..a28934e2597 100644 --- a/gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_charlen_function_1.f90 @@ -17,7 +17,7 @@ END MODULE M1 MODULE INTEGER_SETS
INTERFACE OPERATOR (.IN.)
- FUNCTION ELEMENT(X,A)
+ FUNCTION ELEMENT(X,A) ! { dg-error "cannot be assumed character length" }
USE M1
CHARACTER(LEN=*) :: ELEMENT
INTEGER, INTENT(IN) :: X
@@ -59,7 +59,6 @@ function not_OK (ch) not_OK = ch
end function not_OK
- use INTEGER_SETS
use m1
character(4) :: answer
@@ -74,11 +73,8 @@ end function not_OK end function ext
end interface
- answer = i.IN.z ! { dg-error "cannot be used|Operands of user operator" }
- answer = ext (2) ! { dg-error "but cannot be used" }
-
answer = not_OK ("unOK") ! { dg-error "since it is not a dummy" }
END
-! { dg-final { cleanup-modules "M1 INTEGER_SETS" } }
+! { dg-final { cleanup-modules "M1" } }
diff --git a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 index ff42c02a623..1590ec5c697 100644 --- a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 @@ -35,7 +35,7 @@ contains x = fcn (m) ! { dg-error "upper bound in the last dimension" } m(:, 1:2) = fcn (q) call sub (m, x) ! { dg-error "upper bound in the last dimension" } - call sub (m(1:2, 1:2), x) + call sub (m(1:2, 1:2), x) ! { dg-error "Incompatible ranks in elemental subroutine" } print *, p call DHSEQR(x) diff --git a/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 new file mode 100644 index 00000000000..8e3eb94c261 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fixes for PR25597 and PR27096. +! +! This test combines the PR testcases. +! + character(10), dimension (2) :: implicit_result + character(10), dimension (2) :: explicit_result + character(10), dimension (2) :: source + source = "abcdefghij" + explicit_result = join_1(source) + if (any (explicit_result .ne. source)) call abort () + + implicit_result = reallocate_hnv (source, size(source, 1), LEN (source)) + if (any (implicit_result .ne. source)) call abort () + +contains + +! This function would cause an ICE in gfc_trans_deferred_array. + function join_1(self) result(res) + character(len=*), dimension(:) :: self + character(len=len(self)), dimension(:), pointer :: res + allocate (res(2)) + res = self + end function + +! This function originally ICEd and latterly caused a runtime error. + FUNCTION reallocate_hnv(p, n, LEN) + CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv + character(*), dimension(:) :: p + ALLOCATE (reallocate_hnv(n)) + reallocate_hnv = p + END FUNCTION reallocate_hnv + +end + + diff --git a/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 new file mode 100644 index 00000000000..7e7cde5fbdd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fixes for PR25597 and PR27096. +! +! This test combines the PR testcases. +! + character(10), dimension (2) :: implicit_result + character(10), dimension (2) :: explicit_result + character(10), dimension (2) :: source + source = "abcdefghij" + explicit_result = join_1(source) + if (any (explicit_result .ne. source)) call abort () + + implicit_result = reallocate_hnv (source, size(source, 1), LEN (source)) + if (any (implicit_result .ne. source)) call abort () + +contains + +! This function would cause an ICE in gfc_trans_deferred_array. + function join_1(self) result(res) + character(len=*), dimension(:) :: self + character(len=len(self)), dimension(:), pointer :: res + allocate (res(2)) + res = self + end function + +! This function originally ICEd and latterly caused a runtime error. + FUNCTION reallocate_hnv(p, n, LEN) + CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv + character(*), dimension(:) :: p + ALLOCATE (reallocate_hnv(n)) + reallocate_hnv = p + END FUNCTION reallocate_hnv + +end + + diff --git a/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 new file mode 100644 index 00000000000..a277566735d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! This tests the fix for PRs 26834, 25669 and 18803, in which +! shape information for the lbound and ubound intrinsics was not +! transferred to the scalarizer. For this reason, an ICE would +! ensue, whenever these functions were used in temporaries. +! +! The tests are lifted from the PRs and some further checks are +! done to make sure that nothing is broken. +! +! This is PR26834 +subroutine gfcbug34 () + implicit none + type t + integer, pointer :: i (:) => NULL () + end type t + type(t), save :: gf + allocate (gf%i(20)) + write(*,*) 'ubound:', ubound (gf% i) + write(*,*) 'lbound:', lbound (gf% i) +end subroutine gfcbug34 + +! This is PR25669 +subroutine foo (a) + real a(*) + call bar (a, LBOUND(a),2) +end subroutine foo +subroutine bar (b, i, j) + real b(i:j) + print *, i, j + print *, b(i:j) +end subroutine bar + +! This is PR18003 +subroutine io_bug() + integer :: a(10) + print *, ubound(a) +end subroutine io_bug + +! This checks that lbound and ubound are OK in temporary +! expressions. +subroutine io_bug_plus() + integer :: a(10, 10), b(2) + print *, ubound(a)*(/1,2/) + print *, (/1,2/)*ubound(a) +end subroutine io_bug_plus + + character(4) :: ch(2), ech(2) = (/'ABCD', 'EFGH'/) + real(4) :: a(2) + equivalence (ech,a) ! { dg-warning "default CHARACTER EQUIVALENCE statement" } + integer(1) :: i(8) = (/(j, j = 1,8)/) + +! Check that the bugs have gone + call io_bug () + call io_bug_plus () + call foo ((/1.0,2.0,3.0/)) + call gfcbug34 () + +! Check that we have not broken other intrinsics. + print *, cos ((/1.0,2.0/)) + print *, transfer (a, ch) + print *, i(1:4) * transfer (a, i, 4) * 2 +end + + diff --git a/gcc/testsuite/gfortran.dg/character_array_constructor_1.f90 b/gcc/testsuite/gfortran.dg/character_array_constructor_1.f90 new file mode 100644 index 00000000000..ac0f7e315df --- /dev/null +++ b/gcc/testsuite/gfortran.dg/character_array_constructor_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Tests the fix for PR27113, in which character structure +! components would produce the TODO compilation error "complex +! character array constructors". +! +! Test based on part of tonto-2.2; +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! + type BASIS_TYPE + character(len=8) :: label + end type + + type(BASIS_TYPE), dimension(:), pointer :: ptr + character(8), dimension(2) :: carray + + allocate (ptr(2)) + ptr(1)%label = "Label 1" + ptr(2)%label = "Label 2" + +! This is the original bug + call read_library_data_((/ptr%label/)) + + carray(1) = "Label 3" + carray(2) = "Label 4" + +! Mix a character array with the character component of a derived type pointer array. + call read_library_data_((/carray, ptr%label/)) + +! Finally, add a constant (character(8)). + call read_library_data_((/carray, ptr%label, "Label 5 "/)) + +contains + + subroutine read_library_data_ (chr) + character(*), dimension(:) :: chr + character(len = len(chr)) :: tmp + if (size(chr,1) == 2) then + if (any (chr .ne. (/"Label 1", "Label 2"/))) call abort () + elseif (size(chr,1) == 4) then + if (any (chr .ne. (/"Label 3", "Label 4","Label 1", "Label 2"/))) call abort () + elseif (size(chr,1) == 5) then + if (any (chr .ne. (/"Label 3", "Label 4","Label 1", "Label 2", "Label 5"/))) & + call abort () + end if + end subroutine read_library_data_ + +end diff --git a/gcc/testsuite/gfortran.dg/defined_operators_1.f90 b/gcc/testsuite/gfortran.dg/defined_operators_1.f90 new file mode 100644 index 00000000000..f7688b87a55 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_operators_1.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! Tests the fix for PR27122, in which the requirements of 12.3.2.1.1 +! for defined operators were not enforced. +! +! Based on PR test by Thomas Koenig <tkoenig@gcc.gnu.org> +! +module mymod + interface operator (.foo.) + module procedure foo_0 ! { dg-error "must have at least one argument" } + module procedure foo_1 ! { dg-error "must be INTENT" } + module procedure foo_2 ! { dg-error "cannot be optional" } + module procedure foo_3 ! { dg-error "must have, at most, two arguments" } + module procedure foo_1_OK + module procedure foo_2_OK + function foo_chr (chr) ! { dg-error "cannot be assumed character length" } + character(*) :: foo_chr + character(*), intent(in) :: chr + end function foo_chr + subroutine bad_foo (chr) ! { dg-error "must be a FUNCTION" } + character(*), intent(in) :: chr + end subroutine bad_foo + end interface +contains + function foo_0 () + integer :: foo_1 + foo_0 = 1 + end function foo_0 + function foo_1 (a) + integer :: foo_1 + integer :: a + foo_1 = 1 + end function foo_1 + function foo_1_OK (a) + integer :: foo_1_OK + integer, intent (in) :: a + foo_1_OK = 1 + end function foo_1_OK + function foo_2 (a, b) + integer :: foo_2 + integer, intent(in) :: a + integer, intent(in), optional :: b + foo_2 = 2 * a + b + end function foo_2 + function foo_2_OK (a, b) + real :: foo_2_OK + real, intent(in) :: a + real, intent(in) :: b + foo_2_OK = 2.0 * a + b + end function foo_2_OK + function foo_3 (a, b, c) + integer :: foo_3 + integer, intent(in) :: a, b, c + foo_3 = a + 3 * b - c + end function foo_3 +end module mymod diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90 new file mode 100644 index 00000000000..1a3446264cf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! Test the fix for PR25099, in which conformance checking was not being +! done for elemental subroutines and therefore for interface assignments. +! +! Contributed by Joost VandeVondele <jv244@cam.ac.uk> +! +module elem_assign + implicit none + type mytype + integer x + end type mytype + interface assignment(=) + module procedure myassign + end interface assignment(=) + contains + elemental subroutine myassign(x,y) + type(mytype), intent(out) :: x + type(mytype), intent(in) :: y + x%x = y%x + end subroutine myassign +end module elem_assign + + use elem_assign + integer :: I(2,2),J(2) + type (mytype) :: w(2,2), x(4), y(5), z(4) +! The original PR + CALL S(I,J) ! { dg-error "Incompatible ranks in elemental subroutine" } +! Check interface assignments + x = w ! { dg-error "Incompatible ranks in elemental subroutine" } + x = y ! { dg-error "different shape for elemental subroutine" } + x = z +CONTAINS + ELEMENTAL SUBROUTINE S(I,J) + INTEGER, INTENT(IN) :: I,J + END SUBROUTINE S +END + +! { dg-final { cleanup-modules "elem_assign" } } diff --git a/gcc/testsuite/gfortran.dg/g77/20030115-1.f b/gcc/testsuite/gfortran.dg/g77/20030115-1.f deleted file mode 100644 index faa08e5205e..00000000000 --- a/gcc/testsuite/gfortran.dg/g77/20030115-1.f +++ /dev/null @@ -1,17 +0,0 @@ -C { dg-do compile } - SUBROUTINE FOO (B) - - 10 CALL BAR(A) - ASSIGN 20 TO M ! { dg-warning "Obsolete: ASSIGN" "ASSIGN" } - - IF(100.LT.A) GOTO 10 - GOTO 40 -C - 20 IF(B.LT.ABS(A)) GOTO 10 - ASSIGN 30 TO M ! { dg-warning "Obsolete: ASSIGN" "ASSIGN" } - GOTO 40 -C - 30 ASSIGN 10 TO M ! { dg-warning "Obsolete: ASSIGN" "ASSIGN" } - 40 GOTO M,(10,20,30) ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } - - END diff --git a/gcc/testsuite/gfortran.dg/label_1.f90 b/gcc/testsuite/gfortran.dg/label_1.f90 index 149c79f1029..94f3b5e61ad 100644 --- a/gcc/testsuite/gfortran.dg/label_1.f90 +++ b/gcc/testsuite/gfortran.dg/label_1.f90 @@ -3,7 +3,7 @@ program a 0056780 continue ! { dg-error "Too many digits" } -0 continue ! { dg-error "Statement label at" } +0 continue ! { dg-error "Zero is not a valid statement label" } stop 001234 ! { dg-error "Too many digits" } end program a diff --git a/gcc/testsuite/gfortran.dg/namelist_4.f90 b/gcc/testsuite/gfortran.dg/namelist_4.f90 index 9e62a1f370f..52a5bc9938c 100644 --- a/gcc/testsuite/gfortran.dg/namelist_4.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_4.f90 @@ -28,8 +28,9 @@ program P1 CONTAINS
! This has the additional wrinkle of a reference to the object.
INTEGER FUNCTION F1()
- NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
- f2 = 1 ! Used to ICE here
+ NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" } +! Used to ICE here
+ f2 = 1 ! { dg-error "is not a VALUE" }
F1=1
END FUNCTION
INTEGER FUNCTION F2()
diff --git a/gcc/testsuite/gfortran.dg/proc_assign_1.f90 b/gcc/testsuite/gfortran.dg/proc_assign_1.f90 new file mode 100644 index 00000000000..a0f725080c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_assign_1.f90 @@ -0,0 +1,78 @@ +! { dg-do compile }
+! This tests the patch for PR26787 in which it was found that setting
+! the result of one module procedure from within another produced an
+! ICE rather than an error.
+!
+! This is an "elaborated" version of the original testcase from
+! Joshua Cogliati <jjcogliati-r1@yahoo.com>
+!
+function ext1 ()
+ integer ext1, ext2, arg
+ ext1 = 1
+ entry ext2 (arg)
+ ext2 = arg
+contains
+ subroutine int_1 ()
+ ext1 = arg * arg ! OK - host associated.
+ end subroutine int_1
+end function ext1
+
+module simple
+ implicit none
+contains
+ integer function foo ()
+ foo = 10 ! OK - function result
+ call foobar ()
+ contains
+ subroutine foobar ()
+ integer z
+ foo = 20 ! OK - host associated.
+ end subroutine foobar
+ end function foo
+ subroutine bar() ! This was the original bug.
+ foo = 10 ! { dg-error "is not a VALUE" }
+ end subroutine bar
+ integer function oh_no ()
+ oh_no = 1
+ foo = 5 ! { dg-error "is not a VALUE" }
+ end function oh_no
+end module simple
+
+module simpler
+ implicit none
+contains
+ integer function foo_er ()
+ foo_er = 10 ! OK - function result
+ end function foo_er
+end module simpler
+
+ use simpler
+ real w, stmt_fcn
+ interface
+ function ext1 ()
+ integer ext1
+ end function ext1
+ function ext2 (arg)
+ integer ext2, arg
+ end function ext2
+ end interface
+ stmt_fcn (w) = sin (w)
+ call x (y ())
+ x = 10 ! { dg-error "Expected VARIABLE" }
+ y = 20 ! { dg-error "is not a VALUE" }
+ foo_er = 8 ! { dg-error "is not a VALUE" }
+ ext1 = 99 ! { dg-error "is not a VALUE" }
+ ext2 = 99 ! { dg-error "is not a VALUE" }
+ stmt_fcn = 1.0 ! { dg-error "Expected VARIABLE" }
+ w = stmt_fcn (1.0)
+contains
+ subroutine x (i)
+ integer i
+ y = i ! { dg-error "is not a VALUE" }
+ end subroutine x
+ function y ()
+ integer y
+ y = 2 ! OK - function result
+ end function y
+end
+! { dg-final { cleanup-modules "simple simpler" } }
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 index 2a2c3550454..634eaca0e27 100644 --- a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 +++ b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 @@ -14,7 +14,7 @@ end module t subroutine r use t - b = 1. ! { dg-error "l-value since it is a procedure" } + b = 1. ! { dg-error "is not a VALUE" } y = a(1.) end subroutine r diff --git a/gcc/testsuite/gfortran.dg/read_bad_advance.f90 b/gcc/testsuite/gfortran.dg/read_bad_advance.f90 new file mode 100644 index 00000000000..5b43cfecc7f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/read_bad_advance.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR27138 Failure to advance line on bad list directed read. +! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> + program test + implicit none + integer :: ntype = 55 + real :: rtype + complex :: ctype + logical :: ltype + OPEN (10) + write(10,*) "aaaa aaaa aaaa aaaa" + write(10,*) "bbbb bbbb bbbb bbbb" + write(10,*) "cccc cccc cccc cccc" + write(10,*) "dddd dddd dddd dddd" + write(10,*) " " + write(10,*) "1234 5678 9012 3456" + rewind(10) + READ (10,*,END=77,ERR=77) ntype + goto 99 + 77 READ (10,*,END=78,ERR=78) rtype + goto 99 + 78 READ (10,*,END=79,ERR=79) ctype + goto 99 + 79 READ (10,*,END=80,ERR=80) ltype + goto 99 + 80 READ (10,*,END=99,ERR=99) ntype + if (ntype.ne.1234) goto 99 + close(10, status="delete") + stop + 99 close(10, status="delete") + call abort() + end program test diff --git a/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 new file mode 100644 index 00000000000..b830b5dfc7d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Test of the fix of PR27089, where gfortran was unable to resolve the +! type of n_elements_uncommon_with_ in the specification expression on +! line 21. +! +! Test extracted from vec{int}.F90 of tonto. +! +module test + public n_elements_uncommon_with_ + interface n_elements_uncommon_with_ + module procedure n_elements_uncommon_with + end interface +contains + pure function n_elements_uncommon_with(x) result(res) + integer(4), dimension(:), intent(in) :: x + integer(4) :: res + res = size (x, 1) + end function + pure function elements_uncommon_with(x) result(res) + integer(4), dimension(:), intent(in) :: x + integer(4), dimension(n_elements_uncommon_with_(x)) :: res + res = x + end function +end module test + use test + integer(4) :: z(4) + z = 1 + print *, elements_uncommon_with (z) + print *, n_elements_uncommon_with_ (z) +end +! { dg-final { cleanup-modules "test" } } diff --git a/gcc/testsuite/gfortran.dg/write_recursive.f90 b/gcc/testsuite/gfortran.dg/write_recursive.f90 new file mode 100644 index 00000000000..20014abd228 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/write_recursive.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR26766 Recursive I/O with internal units +! Test case derived from example in PR +! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> +program pr26766 + implicit none + character (len=8) :: str, tmp + write (str, '(a)') bar (1234) + if (str.ne."abcd") call abort() + str = "wxyz" + write (str, '(2a4)') foo (1), bar (1) + if (str.ne."abcdabcd") call abort() + +contains + + function foo (i) result (s) + integer, intent(in) :: i + character (len=4) :: s, t + if (i < 0) then + s = "1234" + else + ! Internal I/O, allowed recursive in f2003, see section 9.11 + write (s, '(a)') "abcd" + end if + end function foo + + function bar (i) result (s) + integer, intent(in) :: i + character (len=4) :: s, t + if (i < 0) then + s = "4567" + else + write (s, '(a)') foo(i) + end if + end function bar + +end program pr26766 + + |