Patchwork [Ada] Allocation of unconstrained limited type

login
register
mail settings
Submitter Arnaud Charlet
Date March 19, 2012, 4:27 p.m.
Message ID <20120319162728.GA16258@adacore.com>
Download mbox | patch
Permalink /patch/147574/
State New
Headers show

Comments

Arnaud Charlet - March 19, 2012, 4:27 p.m.
This patch adds code to detect a particular form of expansion produced by the
build-in-place machinery for the allocation of a private limited indefinite
type where the full view lacks discriminants. The allocator appears as a
qualified expression containing a build-in-place call. The patch prevents the
generation of spurious error messages related to missing initialization during
allocation.

------------
-- Source --
------------

--  types.ads

package Types is
   type Simple_Rec is limited private;
   type Fake_Indefinite_Rec (<>) is limited private;
   type Indefinite_Rec (<>) is limited private;

   function Make return Simple_Rec;
   function Make return Fake_Indefinite_Rec;
   function Make return Indefinite_Rec;

   procedure Print_Data (Obj : Simple_Rec);
   procedure Print_Data (Obj : Fake_Indefinite_Rec);
   procedure Print_Data (Obj : Indefinite_Rec);

private
   type Simple_Rec is limited record
      Data : Integer;
   end record;
   type Fake_Indefinite_Rec is limited record
      Data : Integer;
   end record;
   type Indefinite_Rec (Discr : Integer) is limited record
      Data : Integer;
   end record;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Types is
   function Make return Simple_Rec is
   begin
      return Result : Simple_Rec := Simple_Rec'(Data => 1);
   end Make;
   function Make return Fake_Indefinite_Rec is
   begin
      return Result : Fake_Indefinite_Rec := Fake_Indefinite_Rec'(Data => 2);
   end Make;
   function Make return Indefinite_Rec is
   begin
      return Result : Indefinite_Rec := Indefinite_Rec'(Discr => 3, Data => 4);
   end Make;

   procedure Print_Data (Obj : Simple_Rec) is
   begin
      Put_Line (Obj.Data'Img);
   end Print_Data;
   procedure Print_Data (Obj : Fake_Indefinite_Rec) is
   begin
      Put_Line (Obj.Data'Img);
   end Print_Data;
   procedure Print_Data (Obj : Indefinite_Rec) is
   begin
      Put_Line (Obj.Data'Img);
   end Print_Data;
end Types;

--  main.adb

with Types; use Types;

procedure Main is
   type Simple_Rec_Ptr is access all Simple_Rec;
   type Fake_Indefinite_Rec_Ptr is access all Fake_Indefinite_Rec;
   type Indefinite_Rec_Ptr is access all Indefinite_Rec;

   Obj1 : Simple_Rec_Ptr := new Simple_Rec'(Make);
   Obj2 : Fake_Indefinite_Rec_Ptr := new Fake_Indefinite_Rec'(Make);
   Obj3 : Indefinite_Rec_Ptr := new Indefinite_Rec'(Make);
begin
   Print_Data (Obj1.all);
   Print_Data (Obj2.all);
   Print_Data (Obj3.all);
end Main;

-------------------------------------
-- Compilation and expected output --
-------------------------------------

$ gnatmake -q -gnat05 main.adb
$ ./main
$  1
$  2
$  4

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-03-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch4.adb (Analyze_Allocator): Detect an allocator generated
	by the build-in-place machinery where the designated type is
	indefinite, but the underlying type is not. Do not emit errors
	related to missing initialization in this case.

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 185520)
+++ sem_ch4.adb	(working copy)
@@ -661,9 +661,22 @@ 
             if Is_Indefinite_Subtype (Type_Id)
               and then Serious_Errors_Detected = Sav_Errs
             then
-               if Is_Class_Wide_Type (Type_Id) then
+               --  The build-in-place machinery may produce an allocator when
+               --  the designated type is indefinite but the underlying type is
+               --  not. In this case the unknown discriminants are meaningless
+               --  and should not trigger error messages. Check the parent node
+               --  because the allocator is marked as coming from source.
+
+               if Present (Underlying_Type (Type_Id))
+                 and then not Is_Indefinite_Subtype (Underlying_Type (Type_Id))
+                 and then not Comes_From_Source (Parent (N))
+               then
+                  null;
+
+               elsif Is_Class_Wide_Type (Type_Id) then
                   Error_Msg_N
                     ("initialization required in class-wide allocation", N);
+
                else
                   if Ada_Version < Ada_2005
                     and then Is_Limited_Type (Type_Id)