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 <schonb...@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.
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 247293)
+++ exp_disp.adb (working copy)
@@ -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;
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 247295)
+++ sem_ch4.adb (working copy)
@@ -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;
