This patch fix support for parameterless constructors. Specifically, it forbids calling the
parameterless constructor when no explicit one has been declared, and when the parameterless one has
been explicitly removed.
Furthermore, by freezing constructors as predefined operations, it is now possible to use them in
global object declarations right after the record type declaration.
gcc/ada/ChangeLog:
* exp_ch3.adb (Build_Init_Procedure): Remove call to constructors.
(Build_Default_Simple_Initialization): Implicit call to parameterless constructors in new
allocations.
(Expand_Freeze_Record_Type): Freeze constructors as we would freeze predefined operations.
(Constructor_Freeze): Freeze all constructors.
* sem_attr.adb (Analyze_Attribute): Handle missing parameterless constructors.
* sem_ch3.adb: The default constructor is now called parameterless.
* sem_util.adb (Find_Matching_Constructor): Return the constructor
matching the given condition. Before it was just checking its
existence.
(Has_Copy_Constructor): Move it upward to maintain alphabetic
order of utility subprograms.
(Has_Parameterless_Constructor): The default constructor is now called parameterless.
(Has_Explicit_Constructor): New utility to check for constructors
defined by the user. Used to understand if an implicit
parameterless constructor exists.
(Is_Copy_Constructor): Refactor easier control flow.
(Is_Parameterless_Constructor): New utility to check if a constructor has a profile
compatible with the parameterless constructor.
* sem_util.ads: Likewise.
-- Freeze entities of all predefined primitive operations. This is needed
-- because the bodies of these operations do not normally do any freezing.
+ function Constructor_Freeze (Typ : Entity_Id) return List_Id;
+ -- Freeze all constructors of the type Tag_Typ. Otherwise, constructors
+ -- would not be available at freeze point.
+
--------------------------
-- Adjust_Discriminants --
--------------------------
-- is imported or not.
if not Restriction_Active (No_Default_Initialization) then
+ -- If the type requires construction and the object being
+ -- initialized is an allocator that comes from source, then use
+ -- the parameterless constructor.
+
+ if Nkind (N) = N_Allocator
+ and then Comes_From_Source (N)
+ and then Needs_Construction (Typ)
+ then
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Make);
+ end if;
-- If the values of the components are compile-time known, use
-- their prebuilt aggregate form directly.
if Parent_Subtype_Renaming_Discrims then
Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
- elsif Needs_Construction (Rec_Type) then
- if Has_Default_Constructor (Rec_Type) then
- -- The 'Make attribute reference (with no arguments) will
- -- generate a call to the one-parameter constructor procedure.
-
- Append_To (Body_Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of
- (Defining_Identifier (First (Parameters)), Loc),
- Expression => Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Rec_Type, Loc),
- Attribute_Name => Name_Make)));
- else
- -- No constructor procedure with an appropriate profile
- -- is available, so raise Program_Error.
- --
- -- We could instead do nothing here, since the absence of a
- -- one-parameter constructor procedure should trigger other
- -- legality checks which should statically ensure that
- -- the init proc we are constructing here will never be
- -- called. So a bit of "belt and suspenders" here.
- -- If this raise statement is ever executed, that probably
- -- means that some compile-time legality check is not
- -- implemented, and that the program should have instead
- -- failed to compile.
- -- Because this raise statement should never be executed, it
- -- seems ok to pass in a dubious Reason parameter instead of
- -- declaring a new RT_Exception_Code value.
-
- Append_To (Body_Stmts,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Explicit_Raise));
- end if;
-
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
Build_Discriminant_Assignments (Body_Stmts);
-- attribute.
elsif Needs_Construction (Typ)
- and then Has_Default_Constructor (Typ)
+ and then Has_Parameterless_Constructor (Typ)
then
Set_Expression (Decl,
Make_Attribute_Reference (Loc,
Build_Untagged_Record_Equality (Typ);
end if;
+ -- Freeze constructors as predefined operations
+
+ Append_Freeze_Actions (Typ, Constructor_Freeze (Typ));
+
-- Before building the record initialization procedure, if we are
-- dealing with a concurrent record value type, then we must go through
-- the discriminants, exchanging discriminals between the concurrent
if No (Expr)
and then Constant_Present (N)
and then (not Needs_Construction (Typ)
- or else not Has_Default_Constructor (Typ))
+ or else not Has_Parameterless_Constructor (Typ))
then
return;
end if;
return Res;
end Predefined_Primitive_Freeze;
+ ------------------------
+ -- Constructor_Freeze --
+ ------------------------
+
+ function Constructor_Freeze (Typ : Entity_Id) return List_Id is
+ Res : constant List_Id := New_List;
+ Cursor : Entity_Id;
+ Frnodes : List_Id;
+
+ begin
+ if not Needs_Construction (Typ) then
+ return No_List;
+ end if;
+
+ Cursor :=
+ Get_Name_Entity_Id
+ (Direct_Attribute_Definition_Name (Typ, Name_Constructor));
+ while Present (Cursor) loop
+ Frnodes := Freeze_Entity (Cursor, Typ);
+
+ if Present (Frnodes) then
+ Append_List_To (Res, Frnodes);
+ end if;
+
+ Cursor := Homonym (Cursor);
+ end loop;
+
+ return Res;
+ end Constructor_Freeze;
+
-------------------------
-- Stream_Operation_OK --
-------------------------
Next (Expr);
end loop;
- if not Is_Copy_Constructor_Call (N)
- and then not Needs_Construction (Entity (P))
- then
+ if not Needs_Construction (Entity (P)) then
Error_Msg_NE ("no available constructor for&", N, Entity (P));
end if;
- elsif not Has_Default_Constructor (Entity (P)) then
- Error_Msg_NE ("no default constructor for&", N, Entity (P));
+ elsif not Needs_Construction (Entity (P))
+ or else not Has_Parameterless_Constructor (Entity (P))
+ then
+ Error_Msg_NE ("no parameterless constructor for&", N, Entity (P));
+
+ -- In case the parameterless constructor was explicitly removed, a
+ -- more specific error message is provided.
+
+ if Has_Parameterless_Constructor (Entity (P),
+ Allow_Removed => True)
+ then
+ declare
+ function Find_Parameterless_Constructor
+ is new Find_Matching_Constructor
+ (Is_Parameterless_Constructor);
+
+ Removed_Parameterless : constant Entity_Id :=
+ Find_Parameterless_Constructor (Entity (P),
+ Allow_Removed => True);
+ begin
+ Error_Msg_NE ("//explicitly removed at#",
+ N, Removed_Parameterless);
+ end;
+ end if;
end if;
end;
elsif Needs_Construction (T)
and then not Has_Init_Expression (N)
- and then not Has_Default_Constructor (T)
+ and then not Has_Parameterless_Constructor (T)
and then not Suppress_Initialization (Id)
and then Comes_From_Source (N)
then
- Error_Msg_NE ("no default constructor for&",
+ Error_Msg_NE ("no parameterless constructor for&",
Object_Definition (N), T);
end if;
raise Program_Error;
end Find_Loop_In_Conditional_Block;
+ -------------------------------
+ -- Find_Matching_Constructor --
+ -------------------------------
+
+ function Find_Matching_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean) return Entity_Id
+ is
+ Cursor : Entity_Id;
+ begin
+ pragma Assert (Is_Type (Typ));
+ if not Needs_Construction (Typ) then
+ return Empty;
+ end if;
+
+ -- Iterate through all constructors to find at least one constructor
+ -- that matches the given condition.
+
+ Cursor :=
+ Get_Name_Entity_Id
+ (Direct_Attribute_Definition_Name (Typ, Name_Constructor));
+ while Present (Cursor) loop
+ if (if not Allow_Removed then not Is_Abstract_Subprogram (Cursor))
+ and then Is_Constructor (Cursor)
+ and then Condition (Cursor)
+ then
+ return Cursor;
+ end if;
+
+ Cursor := Homonym (Cursor);
+ end loop;
+
+ return Empty;
+ end Find_Matching_Constructor;
+
--------------------------
-- Find_Overlaid_Entity --
--------------------------
Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
end Has_Compatible_Alignment;
+ --------------------------
+ -- Has_Copy_Constructor --
+ --------------------------
+
+ function Has_Copy_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean
+ is
+ function Find_Copy_Constructor
+ is new Find_Matching_Constructor (Is_Copy_Constructor);
+ begin
+ return Present (Find_Copy_Constructor (Typ, Allow_Removed));
+ end Has_Copy_Constructor;
+
----------------------
-- Has_Declarations --
----------------------
(First_Discriminant (Typ)));
end Has_Defaulted_Discriminants;
- -----------------------------
- -- Has_Default_Constructor --
- -----------------------------
-
- function Has_Default_Constructor
- (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean
- is
- function No_Next_Formal (N : Entity_Id) return Boolean
- is (No (Next_Formal (First_Formal (N))));
-
- function Internal_Has_Default_Constructor
- is new Has_Matching_Constructor (No_Next_Formal);
- begin
- return Internal_Has_Default_Constructor (Typ, Allow_Removed);
- end Has_Default_Constructor;
-
-------------------
-- Has_Denormals --
-------------------
end if;
end Has_Enabled_Property;
- --------------------------
- -- Has_Copy_Constructor --
- --------------------------
+ ------------------------------
+ -- Has_Explicit_Constructor --
+ ------------------------------
- function Has_Copy_Constructor
+ function Has_Explicit_Constructor
(Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean
is
- function Internal_Has_Copy_Constructor
- is new Has_Matching_Constructor (Is_Copy_Constructor);
+ function Find_Explicit_Constructor
+ is new Find_Matching_Constructor (Comes_From_Source);
begin
- return Internal_Has_Copy_Constructor (Typ, Allow_Removed);
- end Has_Copy_Constructor;
+ return Present (Find_Explicit_Constructor (Typ, Allow_Removed));
+ end Has_Explicit_Constructor;
-------------------------------------
-- Has_Full_Default_Initialization --
Present (Get_Pragma (Id, Pragma_Max_Entry_Queue_Length)));
end Has_Max_Queue_Length;
- ------------------------------
- -- Has_Matching_Constructor --
- ------------------------------
-
- function Has_Matching_Constructor
- (Typ : Entity_Id; Allow_Removed : Boolean) return Boolean
- is
- Cursor : Entity_Id;
- begin
- pragma Assert (Is_Type (Typ));
- if not Needs_Construction (Typ) then
- return False;
- end if;
-
- -- Iterate through all constructors to find at least one constructor
- -- that matches the given condition.
-
- Cursor :=
- Get_Name_Entity_Id
- (Direct_Attribute_Definition_Name (Typ, Name_Constructor));
- while Present (Cursor) loop
- if (if not Allow_Removed then not Is_Abstract_Subprogram (Cursor))
- and then Is_Constructor (Cursor)
- and then Condition (Cursor)
- then
- return True;
- end if;
-
- Cursor := Homonym (Cursor);
- end loop;
-
- return False;
- end Has_Matching_Constructor;
-
---------------------------------
-- Has_No_Obvious_Side_Effects --
---------------------------------
-- More formals with default values are allowed afterwards
declare
- All_Defaults : Boolean := True;
- Formal : Entity_Id :=
+ Formal : Entity_Id :=
Next_Formal (Next_Formal (First_Formal (Spec_Id)));
begin
while Present (Formal) loop
if No (Default_Value (Formal)) then
- All_Defaults := False;
- exit;
+ return False;
end if;
Next_Formal (Formal);
end loop;
-
- if All_Defaults then
- return True;
- end if;
end;
+ return True;
end if;
-
return False;
end Is_Copy_Constructor;
Is_Ignored (N) and then not GNATprove_Mode and then not CodePeer_Mode;
end Is_Ignored_In_Codegen;
+ -----------------------------------
+ -- Has_Parameterless_Constructor --
+ -----------------------------------
+
+ function Has_Parameterless_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean
+ is
+ function Find_Default_Constructor
+ is new Find_Matching_Constructor (Is_Parameterless_Constructor);
+ begin
+ return Present (Find_Default_Constructor (Typ, Allow_Removed));
+ end Has_Parameterless_Constructor;
+
---------------------------------
-- Side_Effect_Free_Statements --
---------------------------------
and then Nkind (Node (First_Elmt (Constits))) = N_Null;
end Has_Null_Refinement;
+ ----------------------------------
+ -- Is_Parameterless_Constructor --
+ ----------------------------------
+
+ function Is_Parameterless_Constructor
+ (Spec_Id : Entity_Id) return Boolean is
+ begin
+ if Is_Constructor (Spec_Id) then
+ -- More formals with default values are allowed afterwards
+
+ declare
+ Formal : Entity_Id := Next_Formal (First_Formal (Spec_Id));
+ begin
+ while Present (Formal) loop
+ if No (Default_Value (Formal)) then
+ return False;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+ end;
+ return True;
+ end if;
+ return False;
+ end Is_Parameterless_Constructor;
+
------------------------------------------
-- Has_Nonstatic_Class_Wide_Pre_Or_Post --
------------------------------------------
-- attribute 'Loop_Entry are transformed into blocks. Parts of the original
-- loop are nested within the block.
+ generic
+ with function Condition (E : Entity_Id) return Boolean;
+ function Find_Matching_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean) return Entity_Id;
+ -- Find a constructor whose profile matches the condition specified by the
+ -- generic Condition function. If Allow_Removed is True, constructors that
+ -- have been removed by marking them abstract are considered as well in the
+ -- search.
+
procedure Find_Overlaid_Entity
(N : Node_Id;
Ent : out Entity_Id;
-- appropriate reaction of a caller to Known_Incompatible is to treat it as
-- Unknown, but issue a warning that there may be an alignment error.
+ function Has_Copy_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean;
+ -- Return True if a copy constructor has been explicitly declared by the
+ -- user, or the implicit copy constructor has been generated by the
+ -- compiler. If Allow_Removed is true, then also abstract constructors are
+ -- considered valid during the search.
+
function Has_Declarations (N : Node_Id) return Boolean;
-- Determines if the node can have declarations
function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean;
-- Simple predicate to test for defaulted discriminants
- function Has_Default_Constructor
- (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean;
- -- Determine whether Typ has a constructor with only one formal parameter.
- -- If Allow_Removed is true, then also abstract constructors are considered
- -- valid during the search.
-
function Has_Denormals (E : Entity_Id) return Boolean;
-- Determines if the floating-point type E supports denormal numbers.
-- Returns False if E is not a floating-point type.
-- parameter for reading or returns an effectively volatile value for
-- reading.
- function Has_Copy_Constructor
+ function Has_Explicit_Constructor
(Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean;
- -- Return True if a copy constructor has been explicitly declared by the
- -- user, or the implicit copy constructor has been generated by the
- -- compiler. If Allow_Removed is true, then also abstract constructors are
- -- considered valid during the search.
+ -- Return True if a constructor has been explicitly declared by the user
+ -- for type Typ. If Allow_Removed is true, then also abstract constructors
+ -- are considered valid during the search.
function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean;
-- Determine whether type Typ defines "full default initialization" as
-- Determine whether Id is subject to pragma Max_Queue_Length. It is
-- assumed that Id denotes an entry.
- generic
- with function Condition (E : Entity_Id) return Boolean;
- function Has_Matching_Constructor
- (Typ : Entity_Id; Allow_Removed : Boolean) return Boolean;
- -- Determine whether Typ has a constructor whose profile matches the
- -- condition specified by the generic Condition function. If
- -- Allow_Removed is True, constructors that have been removed by marking
- -- them abstract are considered as well in the search.
-
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
-- This is a simple minded function for determining whether an expression
-- has no obvious side effects. It is used only for determining whether
function Has_Non_Null_Statements (L : List_Id) return Boolean;
-- Return True if L has non-null statements
+ function Has_Parameterless_Constructor
+ (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean;
+ -- Determine whether Typ has a constructor with only one formal parameter.
+ -- If Allow_Removed is true, then also abstract constructors are considered
+ -- valid during the search.
+
function Side_Effect_Free_Statements (L : List_Id) return Boolean;
-- Return True if L has no statements with side effects
-- Context_Requires_NC = False; in that case, "Might_Be_Newly_Constructed"
-- might be a more accurate name.
+ function Is_Parameterless_Constructor (Spec_Id : Entity_Id) return Boolean;
+ -- Return True if the specification Spec_Id denotes a parameterless
+ -- constructor: a constructor procedure with a single 'in out' formal
+ -- parameter of the underlying type. Many additional defaulted parameters
+ -- are permitted.
+
function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Subp : Entity_Id) return Boolean;
-- Return True if Subp is a primitive of an abstract type, where the
projects / thirdparty / gcc.git / commitdiff
