===================================================================
@@ -4510,10 +4510,13 @@
if Building_Static_DT (Typ) then
declare
- Save : constant Boolean := Freezing_Library_Level_Tagged_Type;
+ Saved_FLLTT : constant Boolean :=
+ Freezing_Library_Level_Tagged_Type;
+
+ Formal : Entity_Id;
+ Frnodes : List_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
- Frnodes : List_Id;
begin
Freezing_Library_Level_Tagged_Type := True;
@@ -4523,18 +4526,21 @@
Prim := Node (Prim_Elmt);
Frnodes := Freeze_Entity (Prim, Typ);
- declare
- F : Entity_Id;
+ -- We disable this check for abstract subprograms, given that
+ -- they cannot be called directly and thus the state of their
+ -- untagged formals is of no concern. The RM is unclear in any
+ -- case concerning the need for this check, and this topic may
+ -- go back to the ARG.
- begin
- F := First_Formal (Prim);
- while Present (F) loop
- Check_Premature_Freezing (Prim, Typ, Etype (F));
- Next_Formal (F);
+ if not Is_Abstract_Subprogram (Prim) then
+ Formal := First_Formal (Prim);
+ while Present (Formal) loop
+ Check_Premature_Freezing (Prim, Typ, Etype (Formal));
+ Next_Formal (Formal);
end loop;
Check_Premature_Freezing (Prim, Typ, Etype (Prim));
- end;
+ end if;
if Present (Frnodes) then
Append_List_To (Result, Frnodes);
@@ -4543,7 +4549,7 @@
Next_Elmt (Prim_Elmt);
end loop;
- Freezing_Library_Level_Tagged_Type := Save;
+ Freezing_Library_Level_Tagged_Type := Saved_FLLTT;
end;
end if;
===================================================================
@@ -1463,6 +1463,25 @@
-- actuals.
Check_Function_Writable_Actuals (N);
+
+ -- The return type of the function may be incomplete. This can be
+ -- the case if the type is a generic formal, or a limited view. It
+ -- can also happen when the function declaration appears before the
+ -- full view of the type (which is legal in Ada 2012) and the call
+ -- appears in a different unit, in which case the incomplete view
+ -- must be replaced with the full view to prevent subsequent type
+ -- errors.
+
+ if Is_Incomplete_Type (Etype (N))
+ and then Present (Full_View (Etype (N)))
+ then
+ if Is_Entity_Name (Nam) then
+ Set_Etype (Nam, Full_View (Etype (N)));
+ Set_Etype (Entity (Nam), Full_View (Etype (N)));
+ end if;
+
+ Set_Etype (N, Full_View (Etype (N)));
+ end if;
end if;
end Analyze_Call;
This patch removes a spurious error from a function call when the return type of the function is an incomplete type. This can be the case if the type is a generic formal, or a limited view. It can also happen when the function declaration appears before the full view of the type (which is legal in Ada 2012) and the call appears in a different unit, in which case the imcomplete view must be replaced with the full view to prevent subsequent type errors. The following must compile quietly: gcc -c use_case.adb --- with Itest; use Itest; procedure Use_Case is Ref_Date : Ref_I_Logical_Date; Date : I_Logical_Date'Class renames Ro (Ref_Date); Ref_Ref : Ref_I_Logical_Time_Reference := Date.Reference; Ref : I_Logical_Time_Reference'Class renames Ro (Ref_Ref); Ref_Zero : Ref_I_Logical_Date := Ref.Zero; begin null; end Use_Case; --- with Rc; package Itest is type Ref_I_Logical_Time_Factory; type Ref_I_Logical_Time_Reference; type Ref_I_Logical_Delay; type Ref_I_Logical_Date; type I_Logical_Time_Factory is limited interface; function Unit (This : I_Logical_Time_Factory) return Long_Float is abstract; function Quanta_Per_Unit (This : I_Logical_Time_Factory) return Long_Long_Integer is abstract; function New_Time_Reference (This : I_Logical_Time_Factory; Description : String; Year : Integer; Month : Integer; Day : Integer; Seconds : Long_Float) return Ref_I_Logical_Time_Reference is abstract; function New_Logical_Delay (This : I_Logical_Time_Factory; Seconds : Long_Float) return Ref_I_Logical_Delay is abstract; function New_Logical_Delay (This : I_Logical_Time_Factory; Quanta : Long_Long_Integer) return Ref_I_Logical_Delay is abstract; package Time_Factory_Rc is new Rc (Api => I_Logical_Time_Factory); type Ref_I_Logical_Time_Factory is record Ref : Time_Factory_Rc.Ref; end record; function Ro (Ref : Ref_I_Logical_Time_Factory) return I_Logical_Time_Factory'Class is (Time_Factory_Rc.Get (Ref.Ref)) with Inline; function Rw (Ref : Ref_I_Logical_Time_Factory) return not null access I_Logical_Time_Factory'Class is (Time_Factory_Rc.Get (Ref.Ref)) with Inline; function Get_Ref (This : not null access I_Logical_Time_Factory'Class) return Ref_I_Logical_Time_Factory is ((Ref => Time_Factory_Rc.Get_Ref (This))) with Inline; type I_Logical_Time_Reference is limited interface; function To_String (This : I_Logical_Time_Reference) return String is abstract; function Factory (This : I_Logical_Time_Reference) return Ref_I_Logical_Time_Factory is abstract; function Zero (This : I_Logical_Time_Reference) return Ref_I_Logical_Date is abstract; function Quanta_To_Date (This : I_Logical_Time_Reference; Quanta : Long_Long_Integer) return Ref_I_Logical_Date is abstract; package Time_Reference_Rc is new Rc (Api => I_Logical_Time_Reference); type Ref_I_Logical_Time_Reference is record Ref : Time_Reference_Rc.Ref := Time_Reference_Rc.Null_Ref; end record; function Ro (Ref : Ref_I_Logical_Time_Reference) return I_Logical_Time_Reference'Class is (Time_Reference_Rc.Get (Ref.Ref)) with Inline; function Rw (Ref : Ref_I_Logical_Time_Reference) return not null access I_Logical_Time_Reference'Class is (Time_Reference_Rc.Get (Ref.Ref)) with Inline; function Get_Ref (This : not null access I_Logical_Time_Reference'Class) return Ref_I_Logical_Time_Reference is ((Ref => Time_Reference_Rc.Get_Ref (This))) with Inline; type I_Logical_Delay is limited interface; -- IComparable function Compare_To (This : I_Logical_Delay; To : Ref_I_Logical_Delay) return Integer is abstract; -- I_Logical_Delay function To_String (This : I_Logical_Delay) return String is abstract; function Seconds (This : I_Logical_Delay) return Long_Float is abstract; function Quanta (This : I_Logical_Delay) return Long_Long_Integer is abstract; function Factory (This : I_Logical_Delay) return Ref_I_Logical_Time_Factory is abstract; package Logical_Delay_Rc is new Rc (Api => I_Logical_Delay); type Ref_I_Logical_Delay is record Ref : Logical_Delay_Rc.Ref := Logical_Delay_Rc.Null_Ref; end record; function Ro (Ref : Ref_I_Logical_Delay) return I_Logical_Delay'Class is (Logical_Delay_Rc.Get (Ref.Ref)) with Inline; function Rw (Ref : Ref_I_Logical_Delay) return not null access I_Logical_Delay'Class is (Logical_Delay_Rc.Get (Ref.Ref)) with Inline; function Get_Ref (This : not null access I_Logical_Delay'Class) return Ref_I_Logical_Delay is ((Ref => Logical_Delay_Rc.Get_Ref (This))) with Inline; type I_Logical_Date is limited interface; -- IComparable function Compare_To (This : I_Logical_Date; To : Ref_I_Logical_Date) return Integer is abstract; -- I_Logical_Date function To_String (This : I_Logical_Date) return String is abstract; function Reference (This : I_Logical_Date) return Ref_I_Logical_Time_Reference is abstract; function Delay_From (This : I_Logical_Date; From : Ref_I_Logical_Date) return Ref_I_Logical_Delay is abstract; function Add (This : I_Logical_Date; Increment : Ref_I_Logical_Delay) return Ref_I_Logical_Date is abstract; function Year (This : I_Logical_Date) return Integer is abstract; function Month (This : I_Logical_Date) return Integer is abstract; function Day (This : I_Logical_Date) return Integer is abstract; function Seconds (This : I_Logical_Date) return Long_Float is abstract; function Quanta_From_Zero (This : I_Logical_Date) return Long_Long_Integer is abstract; package Logical_Date_Rc is new Rc (Api => I_Logical_Date); type Ref_I_Logical_Date is record Ref : Logical_Date_Rc.Ref := Logical_Date_Rc.Null_Ref; end record; function Ro (Ref : Ref_I_Logical_Date) return I_Logical_Date'Class is (Logical_Date_Rc.Get (Ref.Ref)) with Inline; function Rw (Ref : Ref_I_Logical_Date) return not null access I_Logical_Date'Class is (Logical_Date_Rc.Get (Ref.Ref)) with Inline; function Get_Ref (This : not null access I_Logical_Date'Class) return Ref_I_Logical_Date is ((Ref => Logical_Date_Rc.Get_Ref (This))) with Inline; type I_Dateable is limited interface; function Local_Date (This : I_Dateable) return Ref_I_Logical_Date is abstract; end Itest; --- with Ada.Finalization; with Interfaces; generic type Api is limited interface; package Rc is type Abstract_Impl is abstract limited new Api with private; procedure Cleanup (This : in out Abstract_Impl) is abstract; type Ref is private; overriding function "=" (L, R : Ref) return Boolean; function Get (R : Ref) return Api'Class with Inline; function Get (R : Ref) return not null access Api'Class with Inline; function Get_Ref (Impl : not null access Api'Class) return Ref with Pre => (Impl.all in Abstract_Impl'Class); function Get_Ref (Impl : Api'Class) return Ref with Pre => (Impl in Abstract_Impl'Class); procedure Unref (R : in out Ref); type Weak_Ref is private; function Get (W : Weak_Ref) return access Api'Class; pragma Inline (Get); Null_Ref : constant Ref; Null_Weak_Ref : constant Weak_Ref; function Get_Weak_Ref (Impl : not null access Api'Class) return Weak_Ref with Pre => (Impl.all in Abstract_Impl'Class); private type I32_Access is access Interfaces.Integer_32; type Abstract_Impl_Access is access all Abstract_Impl'Class; type Abstract_Impl_Access_Access is access Abstract_Impl_Access; type Weak_Ref is new Ada.Finalization.Controlled with record Count : I32_Access := null; Object : Abstract_Impl_Access_Access := null; end record; overriding procedure Initialize (X : in out Weak_Ref); overriding procedure Adjust (X : in out Weak_Ref); overriding procedure Finalize (X : in out Weak_Ref); type Ref is new Ada.Finalization.Controlled with record Impl_Access : Abstract_Impl_Access := null; end record; overriding procedure Initialize (X : in out Ref) is null; overriding procedure Adjust (X : in out Ref); overriding procedure Finalize (X : in out Ref); overriding function "=" (L, R : Ref) return Boolean is (L.Impl_Access = R.Impl_Access); Null_Ref : constant Ref := (Ada.Finalization.Controlled with Impl_Access => null); Null_Weak_Ref : constant Weak_Ref := (Ada.Finalization.Controlled with null, null); type Abstract_Impl is abstract limited new Api with record Count : aliased Interfaces.Integer_32 := 0; Wr : Weak_Ref := Null_Weak_Ref; end record; end Rc; with Ada.Unchecked_Deallocation; with Alloc_Counts_Pkg; with Ada.Tags; with Ada.Text_IO; with Ada.Exceptions; package body Rc is function Atomic_Add (Ptr : access Interfaces.Integer_32; Inc : Interfaces.Integer_32) return Interfaces.Integer_32 is function Intrinsic_Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Inc : Interfaces.Integer_32) return Interfaces.Integer_32; pragma Import (Intrinsic, Intrinsic_Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); begin return Intrinsic_Sync_Add_And_Fetch (Ptr, Inc); end Atomic_Add; procedure Free is new Ada.Unchecked_Deallocation (Interfaces.Integer_32, I32_Access); --------- -- Get -- --------- function Get (R : Ref) return Api'Class is begin return R.Impl_Access.all; end Get; function Get (R : Ref) return not null access Api'Class is begin return R.Impl_Access; end Get; ------------- -- Get_Ref -- ------------- procedure Set (X : in out Ref; Impl : access Abstract_Impl'Class) is begin declare Wr : Weak_Ref; begin X.Impl_Access := Abstract_Impl_Access (Impl); if Impl.all.Wr = Null_Weak_Ref then Impl.all.Wr.Object := new Abstract_Impl_Access; Impl.all.Wr.Object.all := Abstract_Impl_Access (Impl); Alloc_Counts_Pkg.Increment (Impl.all'Tag); end if; X.Adjust; end; end Set; function Get_Ref (Impl : not null access Api'Class) return Ref is Res : Ref := Null_Ref; begin Set (Res, Abstract_Impl_Access (Impl)); return Res; end Get_Ref; function Get_Ref (Impl : Api'Class) return Ref is L_Impl : Abstract_Impl'Class renames Abstract_Impl'Class (Impl); Res : Ref := Null_Ref; begin Res.Impl_Access := L_Impl.Wr.Object.all; Res.Adjust; return Res; end Get_Ref; ----------- -- Unref -- ----------- procedure Unref (R : in out Ref) is begin R.Finalize; end Unref; --------- -- Get -- --------- function Get (W : Weak_Ref) return access Api'Class is begin if W.Object = null then return null; else return W.Object.all; end if; end Get; --------------------------------- -- Weak_Ref finalization stuff -- --------------------------------- overriding procedure Initialize (X : in out Weak_Ref) is begin X.Count := new Interfaces.Integer_32'(1); X.Object := new Abstract_Impl_Access'(null); end Initialize; overriding procedure Adjust (X : in out Weak_Ref) is Dummy : Interfaces.Integer_32; begin if X.Count /= null then Dummy := Atomic_Add (X.Count, 1); end if; end Adjust; overriding procedure Finalize (X : in out Weak_Ref) is Rc : I32_Access := X.Count; begin X.Count := null; if Rc /= null then declare use type Interfaces.Integer_32; Newrc : Interfaces.Integer_32 := Atomic_Add (Rc, -1); procedure Free is new Ada.Unchecked_Deallocation (Abstract_Impl_Access, Abstract_Impl_Access_Access); begin if Newrc = 0 then Free (X.Object); Free (Rc); end if; end; end if; end Finalize; ---------------------------- -- Ref finalization stuff -- ---------------------------- overriding procedure Adjust (X : in out Ref) is Dummy : Interfaces.Integer_32; begin if X.Impl_Access /= null then Dummy := Atomic_Add (Abstract_Impl (X.Impl_Access.all).Count'Access, 1); end if; end Adjust; overriding procedure Finalize (X : in out Ref) is Impl_Access : Abstract_Impl_Access := X.Impl_Access; use type Interfaces.Integer_32; procedure Free is new Ada.Unchecked_Deallocation (Abstract_Impl'Class, Abstract_Impl_Access); begin X.Impl_Access := null; if Impl_Access /= null then if Atomic_Add (Impl_Access.all.Count'Access, -1) = 0 then declare Tag : Ada.Tags.Tag := Impl_Access.all'Tag; Xtag : String := Ada.Tags.External_Tag (Tag); begin Alloc_Counts_Pkg.Decrement (Tag); Cleanup (Impl_Access.all); Impl_Access.all.Wr.Object.all := null; Free (Impl_Access); exception when Occ : others => Ada.Text_IO.Put_Line ("*** Rc: " & Ada.Exceptions.Exception_Name (Occ) & " on Cleanup/Free for " & Xtag); end; end if; end if; end Finalize; function Get_Weak_Ref (Impl : not null access Api'Class) return Weak_Ref is begin if Impl /= null then return Abstract_Impl'Class (Impl.all).Wr; else return Null_Weak_Ref; end if; end Get_Weak_Ref; end Rc; --- with Ada.Containers.Hashed_Maps; with Ada.Strings.Unbounded.Hash; use Ada.Strings.Unbounded; with Ada.Text_Io; with Ada.Exceptions; with GNAT.Strings; with Ada.Containers.Ordered_Maps; package body Alloc_Counts_Pkg is protected type Write_Resource is entry Seize; procedure Release; private Busy : Boolean := False; end Write_Resource; protected body Write_Resource is entry Seize when not Busy is begin Busy := True; end Seize; procedure Release is begin Busy := False; end Release; end Write_Resource; type Counts is record Inc, Dec : Integer; end record; package Count_Maps is new Ada.Containers.Ordered_Maps (Key_Type => Ada.Strings.Unbounded.Unbounded_String, Element_Type => Counts, "<" => Ada.Strings.Unbounded."<"); Cmap : Count_Maps.Map; Lock : Write_Resource; --------------- -- Increment -- --------------- procedure Increment (Tag : in Ada.Tags.Tag) is begin Lock.Seize; declare Utag : Unbounded_String := To_Unbounded_String (Ada.Tags.Expanded_Name (Tag)); Cts : Counts := (1, 0); begin if Cmap.Contains (Utag) then Cts := Cmap.Element (Utag); Cts.Inc := Cts.Inc + 1; Cmap.Replace (Utag, Cts); else Cmap.Include (Utag, Cts); end if; exception when Occ : others => Ada.Text_Io.Put_Line ("*** Alloc_Counts.Increment: " & Ada.Exceptions.Exception_Name (Occ)); end; Lock.Release; end Increment; --------------- -- Decrement -- --------------- procedure Decrement (Tag : in Ada.Tags.Tag) is begin Lock.Seize; declare Utag : Unbounded_String := To_Unbounded_String (Ada.Tags.Expanded_Name (Tag)); Cts : Counts := (0, 1); begin if Cmap.Contains (Utag) then Cts := Cmap.Element (Utag); Cts.Dec := Cts.Dec + 1; Cmap.Replace (Utag, Cts); else Cmap.Include (Utag, Cts); end if; exception when Occ : others => Ada.Text_Io.Put_Line ("*** Alloc_Counts.Decrement: " & Ada.Exceptions.Exception_Name (Occ)); end; Lock.Release; end Decrement; ---------- -- Dump -- ---------- procedure Dump is procedure Dump_Cell (C : in Count_Maps.Cursor) is Cts : Counts := Count_Maps.Element (C); Tag : String := To_String (Count_Maps.Key (C)); begin if Cts.Inc - Cts.Dec /= 0 then Ada.Text_Io.Put_Line (Tag & " " & Integer'Image (Cts.Inc) & " -" & Integer'Image (Cts.Dec) & " = " & Integer'Image (Cts.Inc - Cts.Dec)); end if; end Dump_Cell; C : Count_Maps.Cursor := Cmap.First; begin while Count_Maps.Has_Element (C) loop Dump_Cell (C); Count_Maps.Next (C); end loop; end Dump; end Alloc_Counts_Pkg; --- with Ada.Tags; package Alloc_Counts_Pkg is pragma Elaborate_Body (Alloc_Counts_Pkg); procedure Increment (Tag : in Ada.Tags.Tag); procedure Decrement (Tag : in Ada.Tags.Tag); procedure Dump; end Alloc_Counts_Pkg; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-27 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Analyze_Call): If the return type of a function is incomplete in an context in which the full view is available, replace the type of the call by the full view, to prevent spurious type errors. * exp_disp.adb (Check_Premature_Freezing): Disable check on an abstract subprogram so that compiler does not reject a parameter of a primitive operation of a tagged type being frozen, when the untagged type of that parameter cannot be frozen.