This is a (benign) assertion failure on the mainline for the new Finalizable
aspect put on a tagged record type, when not all the primitives are declared.
This compiles and runs on the 15 branch because assertions are disabled.
Tested on x86-64/Linux, applied on the mainline and 15 branch.
2025-05-05 Eric Botcazou <ebotca...@adacore.com>
PR ada/120104
* exp_ch3.adb (Expand_Freeze_Record_Type): For a controlled tagged
type, freeze only the controlled primitives that are present.
2025-05-05 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/specs/finalizable1.ads: New test.
--
Eric Botcazoudiff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 0dfd8102df1..bc46fd37e0c 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6321,19 +6321,27 @@ package body Exp_Ch3 is
-- frozen inside.
if Is_Controlled (Typ) then
- Append_Freeze_Actions (Typ,
- Freeze_Entity
- (Find_Controlled_Prim_Op (Typ, Name_Initialize), Typ));
+ declare
+ Prim : Entity_Id;
- if not Is_Limited_Type (Typ) then
- Append_Freeze_Actions (Typ,
- Freeze_Entity
- (Find_Controlled_Prim_Op (Typ, Name_Adjust), Typ));
- end if;
+ begin
+ Prim := Find_Controlled_Prim_Op (Typ, Name_Initialize);
+ if Present (Prim) then
+ Append_Freeze_Actions (Typ, Freeze_Entity (Prim, Typ));
+ end if;
- Append_Freeze_Actions (Typ,
- Freeze_Entity
- (Find_Controlled_Prim_Op (Typ, Name_Finalize), Typ));
+ if not Is_Limited_Type (Typ) then
+ Prim := Find_Controlled_Prim_Op (Typ, Name_Adjust);
+ if Present (Prim) then
+ Append_Freeze_Actions (Typ, Freeze_Entity (Prim, Typ));
+ end if;
+ end if;
+
+ Prim := Find_Controlled_Prim_Op (Typ, Name_Finalize);
+ if Present (Prim) then
+ Append_Freeze_Actions (Typ, Freeze_Entity (Prim, Typ));
+ end if;
+ end;
end if;
-- Freeze rest of primitive operations. There is no need to handle
diff --git a/gcc/testsuite/gcc.dg/guality/guality.exp b/gcc/testsuite/gcc.dg/guality/guality.exp
deleted file mode 100644
index 0dc8f10762d..00000000000
--- a/gcc/testsuite/gcc.dg/guality/guality.exp
+++ /dev/null
@@ -1,120 +0,0 @@
-# This harness is for tests that should be run at all optimisation levels.
-
-load_lib gcc-dg.exp
-load_lib gcc-gdb-test.exp
-
-# Disable on darwin until radr://7264615 is resolved.
-if { [istarget *-*-darwin*] } {
- return
-}
-
-if { [istarget hppa*-*-hpux*] } {
- return
-}
-
-if { [istarget "powerpc-ibm-aix*"] } {
- set torture_execute_xfail "powerpc-ibm-aix*"
- return
-}
-
-proc check_guality {args} {
- # Don't count check_guality as PASS, or FAIL etc., that would make
- # the total PASS count dependent on how many parallel runtest invocations
- # ran guality.exp. So save the counts first and restore them afterwards.
- global test_counts
- array set saved_test_counts [array get test_counts]
- set result [eval check_compile guality_check executable $args "-g -O0"]
- set lines [lindex $result 0]
- set output [lindex $result 1]
- set ret 0
- if {[string match "" $lines]} {
- set execout [gcc_load "./$output"]
- set ret [string match "*1 PASS, 0 FAIL, 0 UNRESOLVED*" $execout]
- }
- remote_file build delete $output
- array set test_counts [array get saved_test_counts]
- return $ret
-}
-
-dg-init
-torture-init
-
-global GDB
-if ![info exists ::env(GUALITY_GDB_NAME)] {
- if [info exists GDB] {
- set guality_gdb_name "$GDB"
- } elseif { [info exists rootme] && [file exists $rootme/../gdb/gdb] } {
- # If we're doing a combined build, and gdb is available, use it.
- set guality_gdb_name "$rootme/../gdb/gdb"
- } else {
- set guality_gdb_name "[transform gdb]"
- }
- setenv GUALITY_GDB_NAME "$guality_gdb_name"
-}
-
-if [info exists ::env(DEBUGINFOD_URLS)] {
- set orig_debuginfod_urls "$::env(DEBUGINFOD_URLS)"
- setenv DEBUGINFOD_URLS ""
-}
-
-report_gdb $::env(GUALITY_GDB_NAME) [info script]
-
-proc guality_transform_options { args } {
- set res [list]
- foreach opt [lindex $args 0] {
- #
- if { ! [regexp -- "-O0" $opt] } {
- set opt "$opt -DPREVENT_OPTIMIZATION"
- }
- lappend res $opt
- }
-
- return $res
-}
-
-global DG_TORTURE_OPTIONS
-set guality_dg_torture_options [guality_minimal_options $DG_TORTURE_OPTIONS]
-set guality_dg_torture_options [guality_transform_options $guality_dg_torture_options]
-set guality_lto_torture_options [guality_transform_options $LTO_TORTURE_OPTIONS]
-set-torture-options \
- $guality_dg_torture_options \
- [list {}] \
- $guality_lto_torture_options
-
-if {[check_guality "
- #include \"$srcdir/$subdir/guality.h\"
- volatile long int varl = 6;
- int main (int argc, char *argv\[\])
- {
- GUALCHKVAL (varl);
- return 0;
- }
-"]} {
- set general [list]
- set Og [list]
- foreach file [lsort [glob $srcdir/c-c++-common/guality/*.c]] {
- switch -glob -- [file tail $file] {
- Og-* { lappend Og $file }
- * { lappend general $file }
- }
- }
-
- gcc-dg-runtest [lsort [glob $srcdir/$subdir/*.c]] "" ""
- gcc-dg-runtest $general "" "-Wc++-compat"
- set-torture-options \
- [list "-O0" "-Og"] \
- [list {}] \
- [list "-Og -flto"]
- gcc-dg-runtest $Og "" "-Wc++-compat"
-}
-
-if [info exists guality_gdb_name] {
- unsetenv GUALITY_GDB_NAME
-}
-
-if [info exists ::env(DEBUGINFOD_URLS)] {
- setenv DEBUGINFOD_URLS "$orig_debuginfod_urls"
-}
-
-torture-finish
-dg-finish
-- { dg-do compile }
-- { dg-options "-gnatX0" }
package Finalizable1 is
type Root is abstract tagged null record
with Finalizable => (Finalize => Finalize);
procedure Finalize (This : in out Root) is abstract;
end Finalizable1;
