diff options
| -rw-r--r-- | gcc/DATESTAMP | 2 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 53 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/module.cc | 8 | ||||
| -rw-r--r-- | gcc/fortran/resolve.cc | 90 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.cc | 15 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_11.f03 | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_15.f03 | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_20.f03 | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_23.f03 | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_3.f03 | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_39.f03 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_40.f03 | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_49.f03 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pdt_50.f03 | 54 |
17 files changed, 224 insertions, 51 deletions
diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 7735e7b..c5ef3a2 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250929 +20250930 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6320e3c..16653d2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,56 @@ +2025-09-29 Tonu Naks <naks@adacore.com> + + * doc/gnat_rm/implementation_advice.rst: PolyORB + * doc/gnat_rm/implementation_defined_characteristics.rst: PolyORB + * doc/gnat_rm/implementation_defined_pragmas.rst: ASIS + * doc/gnat_rm/obsolescent_features.rst: PolyORB + * doc/gnat_rm/specialized_needs_annexes.rst: PolyORB + * doc/gnat_rm/the_gnat_library.rst: PolyORB + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: ASIS + * gnat_rm.texi: Regenerate. + * gnat_ugn.texi: Regenerate. + +2025-09-29 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pre_Post_Condition): Handle contracts on + generic formal subprograms like on declarations of access-to-subprogram + types. + +2025-09-29 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Attribute_Constrained_Static_Value): Special case + stand-alone objects for GNATprove. + +2025-09-29 Ronan Desplanques <desplanques@adacore.com> + + * sem_ch3.adb (Process_Full_View): Fix error message. + +2025-09-29 Javier Miranda <miranda@adacore.com> + + * aspects.adb (Get_Aspect_Id): Return No_Aspect for Unsigned_Base_Range + name. + * sem_prag.adb (Analyze_Pragma): Disable pragma Unsigned_Base_Range. + * par-ch4.adb (Scan_Apostrophe): Disable attribute Unsigned_Base_Range. + * doc/gnat_rm/gnat_language_extensions.rst: Remove documentation + of aspect unsigned base range. + * gnat_rm.texi: Regenerate. + +2025-09-29 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_ch6.adb (Validate_Subprogram_Calls): Do not Check_Calls in CodePeer_Mode. + (Check_Calls): Remove CodePeer_Mode special case. + +2025-09-29 Viljar Indus <indus@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: update + rules for pragmas affected by assertion levels. + * gnat_rm.texi: Regenerate. + +2025-09-29 Viljar Indus <indus@adacore.com> + + * ghost.adb (Check_Procedure_Call_Policies): Update the check + between the levels of the argument and the call. + 2025-09-23 Bob Duff <duff@adacore.com> * exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 74fcd1a..219c4b6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1033,7 +1033,7 @@ typedef struct /* These are the attributes required for parameterized derived types. */ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1, - pdt_array:1, pdt_string:1; + pdt_array:1, pdt_string:1, pdt_comp:1; /* This is omp_{out,in,priv,orig} artificial variable in !$OMP DECLARE REDUCTION. */ diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 3168a60..c489dec 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2093,7 +2093,7 @@ enum ab_attribute AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, - AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, + AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, AB_OACC_ROUTINE_NOHOST, @@ -2172,6 +2172,7 @@ static const mstring attr_bits[] = minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), minit ("PDT_ARRAY", AB_PDT_ARRAY), minit ("PDT_STRING", AB_PDT_STRING), + minit ("PDT_COMP", AB_PDT_COMP), minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), @@ -2404,6 +2405,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); if (attr->pdt_type) MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); + if (attr->pdt_comp) + MIO_NAME (ab_attribute) (AB_PDT_COMP , attr_bits); if (attr->pdt_template) MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); if (attr->pdt_array) @@ -2681,6 +2684,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_PDT_TYPE: attr->pdt_type = 1; break; + case AB_PDT_COMP: + attr->pdt_comp = 1; + break; case AB_PDT_TEMPLATE: attr->pdt_template = 1; break; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index daff3b3..00b143c 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16663,6 +16663,26 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template + && !sym->attr.pdt_type && !sym->attr.pdt_template + && !(gfc_get_derived_super_type (sym) + && (gfc_get_derived_super_type (sym)->attr.pdt_type + || gfc_get_derived_super_type (sym)->attr.pdt_template))) + { + gfc_actual_arglist *type_spec_list; + if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived, + &type_spec_list) + != MATCH_YES) + return false; + gfc_free_actual_arglist (c->param_list); + c->param_list = type_spec_list; + if (!sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + } + else if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type + && !sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + if (c->attr.proc_pointer && c->ts.interface) { gfc_symbol *ifc = c->ts.interface; @@ -16863,16 +16883,16 @@ resolve_component (gfc_component *c, gfc_symbol *sym) } if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) + && !c->ts.deferred) { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + if (c->ts.u.cl->length == NULL + || (!resolve_charlen(c->ts.u.cl)) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); return false; } @@ -16894,8 +16914,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->attr.pointer && !c->attr.allocatable) { gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); return false; } @@ -16910,14 +16930,14 @@ resolve_component (gfc_component *c, gfc_symbol *sym) sprintf (name, "_%s_length", c->name); strlen = gfc_find_component (sym, name, true, true, NULL); if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } } if (c->ts.type == BT_DERIVED @@ -16927,27 +16947,27 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) return false; if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) { gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); + "type %s", c->name, &c->loc, sym->name); return false; } if (sym->attr.sequence) { if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { + { gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } } if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) @@ -16955,7 +16975,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) else if (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->ts.u.derived->attr.generic) CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); /* If an allocatable component derived type is of the same type as the enclosing derived type, we need a vtable generating so that @@ -16968,10 +16988,10 @@ resolve_component (gfc_component *c, gfc_symbol *sym) derived type list; even in formal namespaces, where derived type pointer components might not have been declared. */ if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) add_dt_to_dt_list (c->ts.u.derived); if (c->as && c->as->type != AS_DEFERRED @@ -16979,8 +16999,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) return false; if (c->initializer && !sym->attr.vtype diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 055698b..c31c756 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1688,6 +1688,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !(sym->attr.use_assoc || sym->attr.dummy)) gfc_defer_symbol_init (sym); + if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp) + && gfc_current_ns == sym->ns + && !(sym->attr.use_assoc || sym->attr.dummy)) + gfc_defer_symbol_init (sym); + /* Dummy PDT 'len' parameters should be checked when they are explicit. */ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) @@ -4921,7 +4926,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived - && sym->ts.u.derived->attr.pdt_type) + && (sym->ts.u.derived->attr.pdt_type || sym->ts.u.derived->attr.pdt_comp)) { is_pdt_type = true; gfc_init_block (&tmpblock); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f4e6c57..f25335d 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -7922,6 +7922,8 @@ gfc_trans_deallocate (gfc_code *code) gfc_expr *expr = gfc_copy_expr (al->expr); bool is_coarray = false, is_coarray_array = false; int caf_mode = 0; + gfc_ref * ref; + gfc_actual_arglist * param_list; gcc_assert (expr->expr_type == EXPR_VARIABLE); @@ -7937,9 +7939,18 @@ gfc_trans_deallocate (gfc_code *code) /* Deallocate PDT components that are parameterized. */ tmp = NULL; + param_list = expr->param_list; + if (!param_list && expr->symtree->n.sym->param_list) + param_list = expr->symtree->n.sym->param_list; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_DERIVED + && ref->u.c.component->ts.u.derived->attr.pdt_type + && ref->u.c.component->param_list) + param_list = ref->u.c.component->param_list; if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.pdt_type - && expr->symtree->n.sym->param_list) + && ((expr->ts.u.derived->attr.pdt_type && param_list) + || expr->ts.u.derived->attr.pdt_comp)) tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); else if (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 78e0ede..a4c4a17 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2025-09-29 YunQiang Su <yunqiang@isrc.iscas.ac.cn> + + * gcc.target/mips/pr99217-2.c: New test. + 2025-09-28 liuhongt <hongtao.liu@intel.com> * gcc.target/i386/pieces-memcmp-2.c: Remove mstore-max. diff --git a/gcc/testsuite/gfortran.dg/pdt_11.f03 b/gcc/testsuite/gfortran.dg/pdt_11.f03 index 41b506a..3ddbafe 100644 --- a/gcc/testsuite/gfortran.dg/pdt_11.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_11.f03 @@ -47,6 +47,7 @@ program test write(*,*) 'o_fdef FAIL' STOP 2 end if + deallocate (o_fdef) end program test diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03 index 4ae1983..17d4d37 100644 --- a/gcc/testsuite/gfortran.dg/pdt_15.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_15.f03 @@ -98,9 +98,9 @@ contains if (int (pop_8 (root)) .ne. 3) STOP 1 if (int (pop_8 (root)) .ne. 2) STOP 2 if (int (pop_8 (root)) .ne. 1) STOP 3 -! if (int (pop_8 (root)) .ne. 0) STOP 4 + if (int (pop_8 (root)) .ne. 0) STOP 4 end subroutine end program ch2701 ! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } } -! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } } -! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } } +! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_20.f03 b/gcc/testsuite/gfortran.dg/pdt_20.f03 index 3aa9b2e..3c4b5b8 100644 --- a/gcc/testsuite/gfortran.dg/pdt_20.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_20.f03 @@ -17,4 +17,5 @@ program p if (x%b .ne. 3) STOP 1 if (x%b .ne. size (x%r, 1)) STOP 2 if (x%r%a .ne. 1) STOP 3 +! deallocate (x) ! Segmentation fault: triggered at trans-array.cc:11009. end diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03 b/gcc/testsuite/gfortran.dg/pdt_23.f03 index c0cec9a..dadea11 100644 --- a/gcc/testsuite/gfortran.dg/pdt_23.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_23.f03 @@ -30,4 +30,5 @@ program p buffer = "lmn" read (buffer, *) x ! PDT IO was incorrect (PRs 84143/84432). if (x%c .ne. 'lmn') STOP 5 +! if (allocated (x)) deallocate (x) ! Used to seg fault - invalid memory reference. end diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 index 6800768..7359519 100644 --- a/gcc/testsuite/gfortran.dg/pdt_3.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -32,7 +32,6 @@ end module type (mytype (b=s*2)) :: mat2 end type x - real, allocatable :: matrix (:,:) type(thytype(ftype, 4, 4)) :: w type(x(ftype,ftype,256)) :: q class(mytype(ftype, :)), allocatable :: cz @@ -54,10 +53,9 @@ end module if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10 ! Now check some basic OOP with PDTs - matrix = w%d -! TODO - for some reason, using w%d directly in the source causes a seg fault. - allocate (cz, source = mytype(ftype, d_dim)( 0, matrix)) +! Using w%d directly in the source used to cause a seg fault. + allocate (cz, source = mytype(ftype, d_dim)( 0, w%d)) ! Leaks 64 bytes in 1 block. select type (cz) type is (mytype(ftype, *)) if (int (sum (cz%d)) .ne. 136) STOP 11 @@ -76,5 +74,4 @@ end module end select deallocate (cz) - deallocate (matrix) end diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03 index 7378cf5..7cfd232 100644 --- a/gcc/testsuite/gfortran.dg/pdt_39.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_39.f03 @@ -49,7 +49,7 @@ contains subroutine geta_r8(a_lhs, t_rhs) real(r8), allocatable, intent(out) :: a_lhs(:,:) class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs - a_lhs = t_rhs%m_a + a_lhs = t_rhs%m_a ! Leaks 152 bytes in 2 blocks return end subroutine geta_r8 @@ -94,7 +94,7 @@ program p if (mat_r4%c /= N) stop 2 if (mat_r4%r /= M) stop 3 mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] ) - a_r4 = mat_r4 + a_r4 = mat_r4 ! Leaks 24 bytes in 1 block. if (int (sum (a_r4)) /= 21) stop 4 N = 4 M = 4 diff --git a/gcc/testsuite/gfortran.dg/pdt_40.f03 b/gcc/testsuite/gfortran.dg/pdt_40.f03 index 4853508..673ffde 100644 --- a/gcc/testsuite/gfortran.dg/pdt_40.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_40.f03 @@ -22,4 +22,5 @@ if (bar%x%ell /= parm) stop 1 ! Then these component references failed in if (bar%x%i /= 2 * parm) stop 2 ! translation. + deallocate (foo, bar%x) end diff --git a/gcc/testsuite/gfortran.dg/pdt_49.f03 b/gcc/testsuite/gfortran.dg/pdt_49.f03 new file mode 100644 index 0000000..9ddfd14 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_49.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Check PR105380 has gone away. Used to ICE with, "internal compiler error: +! tree check: expected array_type, have record_type in ....." +! +! Contributed by Martin Liska <marxin@gcc.gnu.org> +! +program p + type t(n) + integer, len :: n + end type + type t2(m) + integer, len :: m + type(t(1)) :: a(m) + end type + type(t2(3)) :: x + + print *, x%m, size (x%a), x%a%n ! Outputs 3 3 1 as expected. +end diff --git a/gcc/testsuite/gfortran.dg/pdt_50.f03 b/gcc/testsuite/gfortran.dg/pdt_50.f03 new file mode 100644 index 0000000..9c036e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_50.f03 @@ -0,0 +1,54 @@ +! { dg-do compile } +! ! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR102241, which caused an ICE in gfc_get_derived_type. +! The test in comment 4 used to cause a spurious error. +! +! Contributed by Roland Wirth <roland_wirth@web.de> +! + MODULE mo + TYPE t1(n) + INTEGER, LEN :: n + INTEGER :: a(n) + END TYPE + + TYPE t2 + TYPE(t1(:)), allocatable :: p_t1 + END TYPE + END MODULE + +!---Check test in comment 4 now works--- + MODULE mo2 + TYPE u1(n) + INTEGER, LEN :: n + INTEGER :: a(n) + END TYPE + + TYPE u2 + TYPE(u1(2)), POINTER :: p_u1 + END TYPE + + CONTAINS + + SUBROUTINE sr + + type(u1(2)), target :: tgt + type(u2) :: pt + + tgt = u1(2)([42,84]) + pt%p_u1 => tgt + if (any (pt%p_u1%a /= [42,84])) stop 1 + END SUBROUTINE + END MODULE +!------ + + use mo + use mo2 + type(t2) :: d + d%p_t1 = t1(8)([42,43,44,45,42,43,44,45]) + if (any (d%p_t1%a /= [42,43,44,45,42,43,44,45])) stop 2 + call sr + deallocate (d%p_t1) +end +! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } } |