From: Javier Miranda Date: Mon, 22 Jul 2019 13:58:09 +0000 (+0000) Subject: [Ada] Spurious error passing access to class-wide interface type X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=137dabdd82648ccd5f0adedea2fbb8504f6c7485;p=gcc.git [Ada] Spurious error passing access to class-wide interface type The compiler reports an spurious error when the formal parameter of a subprogram is an access to a class wide interface type and the actual parameter is an allocator of an object covering such interface type. 2019-07-22 Javier Miranda gcc/ada/ * sem_res.adb (Resolve_Actuals): Replace code that displaces the pointer to an allocated object to reference its secondary dispatch table by a type conversion (which takes care of handling all cases). gcc/testsuite/ * gnat.dg/class_wide5.adb: New testcase. From-SVN: r273690 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4b817ce9328..4711b6d3dd9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-07-22 Javier Miranda + + * sem_res.adb (Resolve_Actuals): Replace code that displaces the + pointer to an allocated object to reference its secondary + dispatch table by a type conversion (which takes care of + handling all cases). + 2019-07-22 Eric Botcazou * sprint.adb (Sprint_Node_Actual) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fd4fedc3032..b668a5102bb 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4190,17 +4190,16 @@ package body Sem_Res is DDT : constant Entity_Id := Directly_Designated_Type (Base_Type (Etype (F))); - New_Itype : Entity_Id; - begin + -- Displace the pointer to the object to reference its + -- secondary dispatch table. + if Is_Class_Wide_Type (DDT) and then Is_Interface (DDT) then - New_Itype := Create_Itype (E_Anonymous_Access_Type, A); - Set_Etype (New_Itype, Etype (A)); - Set_Directly_Designated_Type - (New_Itype, Directly_Designated_Type (Etype (A))); - Set_Etype (A, New_Itype); + Rewrite (A, Convert_To (Etype (F), Relocate_Node (A))); + Analyze_And_Resolve (A, Etype (F), + Suppress => Access_Check); end if; -- Ada 2005, AI-162:If the actual is an allocator, the diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index acc60635027..2ac298f87ce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-22 Javier Miranda + + * gnat.dg/class_wide5.adb: New testcase. + 2019-07-22 Ed Schonberg * gnat.dg/opt80.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/class_wide5.adb b/gcc/testsuite/gnat.dg/class_wide5.adb new file mode 100644 index 00000000000..008273fa0ee --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide5.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +procedure Class_Wide5 is + type B is interface; + type B_Child is new B with null record; + type B_Ptr is access B'Class; + + procedure P (Obj : B_Ptr) is begin null; end; +begin + P (new B_child); -- Test +end Class_Wide5;