This patch handles properly a function declared in package A that returns the
limited view of a type declared in package B, when the function is called from
a context that has with_clauses on A and B. Previous to this patch such a call
would crash the compiler because of a misplaced freeze node.
The following must compile quietly:
gcc -c builder.adb
--
package body Builder is
function "+"
(Item : Wide_Wide_String) return Strings.Universal_String
renames Strings.To_Universal_String;
function Get_Document
(Self : in out JSON_Builder) return Objects.JSON_Object is
begin
return Result : Objects.JSON_Object do
Result.Insert (+"styles", Self.Styles.To_JSON_Value);
end return;
end Get_Document;
not overriding procedure Leave_Text_Span
(Self : in out JSON_Builder;
Element : not null Text_Span_Elements.ODF_Text_Span_Access) is
begin
Self.Current.Object.Insert
(+"children", Self.Current.Children.To_JSON_Value);
end Leave_Text_Span;
end Builder;
---
limited with Values;
package Arrays is
pragma Preelaborate;
type JSON_Array is tagged private;
pragma Preelaborable_Initialization (JSON_Array);
Empty_JSON_Array : constant JSON_Array;
function To_JSON_Value
(Self : JSON_Array'Class) return Values.JSON_Value;
private
type JSON_Array is tagged record
null;
end record;
Empty_JSON_Array : constant JSON_Array := (others => <>);
end Arrays;
---
with Objects;
with Arrays;
with Values;
private with Strings;
private with Text_Span_Elements;
package Builder is
type JSON_Builder is tagged limited private;
function Get_Document
(Self : in out JSON_Builder) return Objects.JSON_Object;
private
type State_Kinds is
(Initial,
Element);
type State_Record (Kind : State_Kinds := Initial) is record
case Kind is
when Initial =>
null;
when Element =>
Object : Objects.JSON_Object;
Children : Arrays.JSON_Array;
end case;
end record;
type JSON_Builder is tagged limited record
Current : State_Record;
Previous : State_Record;
Styles : Arrays.JSON_Array;
end record;
not overriding procedure Leave_Text_Span
(Self : in out JSON_Builder;
Element : not null Text_Span_Elements.ODF_Text_Span_Access);
end Builder;
---
with Strings;
limited with Values;
package Objects is
pragma Preelaborate;
type JSON_Object is tagged private;
pragma Preelaborable_Initialization (JSON_Object);
procedure Insert
(Self : in out JSON_Object'Class;
Key : Strings.Universal_String;
Value : Values.JSON_Value);
private
type JSON_Object is tagged record
null;
end record;
end Objects;
---
package Strings is
pragma Preelaborate;
type Universal_String is tagged private;
function To_Universal_String
(Item : Wide_Wide_String) return Universal_String;
private
type Universal_String is tagged record
null;
end record;
end Strings;
---
package Text_Span_Elements is
pragma Preelaborate;
type ODF_Text_Span is limited interface;
type ODF_Text_Span_Access is
access all ODF_Text_Span'Class
with Storage_Size => 0;
end Text_Span_Elements;
--
package Values is
pragma Preelaborate;
type JSON_Value is tagged private;
pragma Preelaborable_Initialization (JSON_Value);
private
type JSON_Value is tagged record
null;
end record;
end Values;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-08-04 Ed Schonberg <schonb...@adacore.com>
* freeze.adb (Late_Freeze_Subprogram): Following AI05-151,
a function can return a limited view of a type declared
elsewhere. In that case the function cannot be frozen at the end
of its enclosing package. If its first use is in a different unit,
it cannot be frozen there, but if the call is legal the full view
of the return type is available and the subprogram can now be
frozen. However the freeze node cannot be inserted at the point
of call, but rather must go in the package holding the function,
so that the backend can process it in the proper context.
Index: freeze.adb
===================================================================
--- freeze.adb (revision 213549)
+++ freeze.adb (working copy)
@@ -1815,14 +1815,19 @@
-------------------
function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Comp : Entity_Id;
+ F_Node : Node_Id;
+ Indx : Node_Id;
+ Formal : Entity_Id;
+ Atype : Entity_Id;
+
Test_E : Entity_Id := E;
- Comp : Entity_Id;
- F_Node : Node_Id;
- Indx : Node_Id;
- Formal : Entity_Id;
- Atype : Entity_Id;
+ -- This could use a comment ???
+ Late_Freezing : Boolean := False;
+ -- Used to detect attempt to freeze function declared in another unit
+
Result : List_Id := No_List;
-- List of freezing actions, left at No_List if none
@@ -1861,6 +1866,16 @@
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
+ procedure Late_Freeze_Subprogram (E : Entity_Id);
+ -- Following AI05-151, a function can return a limited view of a type
+ -- declared elsewhere. In that case the function cannot be frozen at
+ -- the end of its enclosing package. If its first use is in a different
+ -- unit, it cannot be frozen there, but if the call is legal the full
+ -- view of the return type is available and the subprogram can now be
+ -- frozen. However the freeze node cannot be inserted at the point of
+ -- call, but rather must go in the package holding the function, so that
+ -- the backend can process it in the proper context.
+
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
-- then this procedure will create a wrapper to ensure that proper run-
@@ -1885,6 +1900,7 @@
function After_Last_Declaration return Boolean is
Spec : constant Node_Id := Parent (Current_Scope);
+
begin
if Nkind (Spec) = N_Package_Specification then
if Present (Private_Declarations (Spec)) then
@@ -1894,6 +1910,7 @@
else
return False;
end if;
+
else
return False;
end if;
@@ -2013,8 +2030,7 @@
else
Error_Msg_N
("current instance must be an immutably limited "
- & "type (RM-2012, 7.5 (8.1/3))",
- Prefix (N));
+ & "type (RM-2012, 7.5 (8.1/3))", Prefix (N));
end if;
return Abandon;
@@ -2182,8 +2198,7 @@
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Arr);
Error_Msg_N
- ("pragma Pack affects convention % components #??",
- PP);
+ ("pragma Pack affects convention % components #??", PP);
Error_Msg_Name_1 := CN;
Error_Msg_N
("\array components may not have % compatible "
@@ -2260,6 +2275,7 @@
Comp_Size_C : constant Node_Id :=
Get_Attribute_Definition_Clause
(Ent, Attribute_Component_Size);
+
begin
-- Warn if we have pack and component size so that the
-- pack is ignored.
@@ -2305,11 +2321,11 @@
if Present (Pack_Pragma) then
Error_Msg_N
- ("??pragma Pack causes component size "
- & "to be ^!", Pack_Pragma);
+ ("??pragma Pack causes component size to be ^!",
+ Pack_Pragma);
Error_Msg_N
- ("\??use Component_Size to set "
- & "desired value!", Pack_Pragma);
+ ("\??use Component_Size to set desired value!",
+ Pack_Pragma);
end if;
end if;
@@ -2531,8 +2547,7 @@
Ilen :=
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Ityp, Loc),
+ Prefix => New_Occurrence_Of (Ityp, Loc),
Attribute_Name => Name_Range_Length);
Analyze_And_Resolve (Ilen);
@@ -2562,10 +2577,8 @@
if Known_RM_Size (Arr) then
declare
- SizC : constant Node_Id := Size_Clause (Arr);
-
+ SizC : constant Node_Id := Size_Clause (Arr);
Discard : Boolean;
- pragma Warnings (Off, Discard);
begin
-- It is not clear if it is possible to have no size clause
@@ -3060,6 +3073,7 @@
if Will_Be_Frozen then
Undelay_Type (Comp);
+
else
if Present (Prev) then
Set_Next_Entity (Prev, Next_Entity (Comp));
@@ -3107,8 +3121,8 @@
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Entity (Expression (Alloc)), N, Result);
- elsif
- Nkind (Expression (Alloc)) = N_Subtype_Indication
+
+ elsif Nkind (Expression (Alloc)) = N_Subtype_Indication
then
Freeze_And_Append
(Entity (Subtype_Mark (Expression (Alloc))),
@@ -3633,6 +3647,25 @@
return False;
end Has_Boolean_Aspect_Import;
+ ----------------------------
+ -- Late_Freeze_Subprogram --
+ ----------------------------
+
+ procedure Late_Freeze_Subprogram (E : Entity_Id) is
+ Spec : constant Node_Id :=
+ Specification (Unit_Declaration_Node (Scope (E)));
+ Decls : List_Id;
+
+ begin
+ if Present (Private_Declarations (Spec)) then
+ Decls := Private_Declarations (Spec);
+ else
+ Decls := Visible_Declarations (Spec);
+ end if;
+
+ Append_List (Result, Decls);
+ end Late_Freeze_Subprogram;
+
------------------------------
-- Wrap_Imported_Subprogram --
------------------------------
@@ -4165,6 +4198,16 @@
if Ekind (E) = E_Function then
+ -- Check whether function is declared elsewhere.
+
+ Late_Freezing :=
+ Get_Source_Unit (E) /= Get_Source_Unit (N)
+ and then Expander_Active
+ and then Ekind (Scope (E)) = E_Package
+ and then Nkind (Unit_Declaration_Node (Scope (E)))
+ = N_Package_Declaration
+ and then not In_Open_Scopes (Scope (E));
+
-- Freeze return type
R_Type := Etype (E);
@@ -4325,6 +4368,11 @@
Freeze_Subprogram (E);
end if;
+ if Late_Freezing then
+ Late_Freeze_Subprogram (E);
+ return No_List;
+ end if;
+
-- If warning on suspicious contracts then check for the case of
-- a postcondition other than False for a No_Return subprogram.
