Skip to content

R
riscv-gcc-1
Commit b4592168 by Gary Dismukes Committed by Arnaud Charlet
Options

sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of… 

sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of Has_Stream_Attribute_ Definition when...

2008-04-08  Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of
	Has_Stream_Attribute_ Definition when checking for available stream
	attributes on parameters of a limited type in Ada 2005. Necessary for
	proper recognition of visible stream attribute clauses.
	(Has_Stream_Attribute_Definition): If the type is derived from a
	private type, then use the derived type's underlying type for checking
	whether it has stream attributes.
	(Validate_Object_Declaration): The check for a user-defined Initialize
	procedure applies also to types with controlled components or a
	controlled ancestor.
	Reject an object declaration in a preelaborated unit if the type is a
	controlled type with an overriding Initialize procedure.
	(Validate_Remote_Access_To_Class_Wide_Type): Return without further
	checking when the parent of a dereference is a selected component and
	the name has not been analyzed.

	* sem_ch4.adb (Analyze_Selected_Component): Add checking for selected
	prefixes that are invalid explicit dereferences of remote
	access-to-class-wide values, first checking whether the selected
	component is a prefixed form of call to a tagged operation.
	(Analyze_Call): Remove code that issues an error for limited function
	calls in illegal contexts, as we now support all of the contexts that
	were forbidden here.
	Allow a function call that returns a task.and appears as the
	prefix of a selected component.
	(Analyze_Reference): Give error message if we try to make a 'Reference
	for an object that is atomic/aliased without its type having the
	corresponding attribute.
	(Analyze_Call): Remove condition checking for attributes to allow
	calls to functions with inherently limited results as prefixes of
	attributes. Remove related comment about Class attributes.
	(Analyze_Selected_Component): If the prefix is a remote type, check
	whether this is a prefixed call before reporting an error.
	(Complete_Object_Operation): If the controlling formal is an access to
	variable reject an actual that is a constant or an access to one.
	(Try_Object_Operation): If prefix is a tagged protected object,retrieve
	primitive operations from base type.

	* exp_ch4.adb (Expand_N_Indexed_Component): Test for prefix that is a
	build-in-place
	function call and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Expand_N_Selected_Component): Test for prefix that is a build-in-place
	function call and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Expand_N_Slice): Test for prefix that is a build-in-place function call
	and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Analyze_Call): Remove code that issues an error for limited function
	calls in illegal contexts, as we now support all of the contexts that
	were forbidden here.
	New calling sequence for Get_Simple_Init_Val
	(Expand_Boolean_Operator): Add call to Silly_Boolean_Array_Xor_Test
	(Expand_N_Op_Not): Add call to Silly_Boolan_Array_Not_Test

From-SVN: r134026
parent fc534c1c
Showing with 497 additions and 325 deletions
gcc/ada/exp_ch4.adb
......@@ -1852,6 +1852,10 @@ package body Exp_Ch4 is
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
if Nkind (N) = N_Op_Xor then
Silly_Boolean_Array_Xor_Test (N, Etype (L));
end if;
if Nkind (Parent (N)) = N_Assignment_Statement
and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
then
......@@ -1860,7 +1864,7 @@ package body Exp_Ch4 is
elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And
and then
Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
then
return;
else
......@@ -2812,7 +2816,7 @@ package body Exp_Ch4 is
function Needs_Initialization_Call (N : Node_Id) return Boolean;
-- Determine whether node N is a subtype indicator allocator which
-- asts a coextension. Such coextensions need initialization.
-- acts a coextension. Such coextensions need initialization.
-------------------------------
-- Inside_A_Return_Statement --
......@@ -2943,27 +2947,34 @@ package body Exp_Ch4 is
Ref := New_Copy_Tree (Coext);
end if;
-- Generate:
-- initialize (Ref)
-- attach_to_final_list (Ref, Flist, 2)
-- No initialization call if not allowed
if Needs_Initialization_Call (Coext) then
Insert_Actions (N,
Make_Init_Call (
Ref => Ref,
Typ => Etype (Coext),
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, Uint_2)));
Check_Restriction (No_Default_Initialization, N);
-- Generate:
-- attach_to_final_list (Ref, Flist, 2)
if not Restriction_Active (No_Default_Initialization) then
else
Insert_Action (N,
Make_Attach_Call (
Obj_Ref => Ref,
Flist_Ref => New_Copy_Tree (Flist),
With_Attach => Make_Integer_Literal (Loc, Uint_2)));
-- Generate:
-- initialize (Ref)
-- attach_to_final_list (Ref, Flist, 2)
if Needs_Initialization_Call (Coext) then
Insert_Actions (N,
Make_Init_Call (
Ref => Ref,
Typ => Etype (Coext),
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, Uint_2)));
-- Generate:
-- attach_to_final_list (Ref, Flist, 2)
else
Insert_Action (N,
Make_Attach_Call (
Obj_Ref => Ref,
Flist_Ref => New_Copy_Tree (Flist),
With_Attach => Make_Integer_Literal (Loc, Uint_2)));
end if;
end if;
Next_Elmt (Coext_Elmt);
......@@ -3174,10 +3185,11 @@ package body Exp_Ch4 is
-- Case of simple initialization required
if Needs_Simple_Initialization (T) then
Check_Restriction (No_Default_Initialization, N);
Rewrite (Expression (N),
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Expression => Get_Simple_Init_Val (T, Loc)));
Expression => Get_Simple_Init_Val (T, N)));
Analyze_And_Resolve (Expression (Expression (N)), T);
Analyze_And_Resolve (Expression (N), T);
......@@ -3193,292 +3205,299 @@ package body Exp_Ch4 is
-- Case of initialization procedure present, must be called
else
Init := Base_Init_Proc (T);
Nod := N;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- Construct argument list for the initialization routine call
Arg1 :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
Temp_Type := PtrT;
Check_Restriction (No_Default_Initialization, N);
-- The initialization procedure expects a specific type. if the
-- context is access to class wide, indicate that the object being
-- allocated has the right specific type.
if not Restriction_Active (No_Default_Initialization) then
Init := Base_Init_Proc (T);
Nod := N;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Is_Class_Wide_Type (Dtyp) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
-- If designated type is a concurrent type or if it is private
-- type whose definition is a concurrent type, the first argument
-- in the Init routine has to be unchecked conversion to the
-- corresponding record type. If the designated type is a derived
-- type, we also convert the argument to its root type.
if Is_Concurrent_Type (T) then
Arg1 :=
Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
-- Construct argument list for the initialization routine call
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 :=
Unchecked_Convert_To
(Corresponding_Record_Type (Full_View (T)), Arg1);
elsif Etype (First_Formal (Init)) /= Base_Type (T) then
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
Temp_Type := PtrT;
begin
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
Set_Etype (Arg1, Ftyp);
end;
end if;
-- The initialization procedure expects a specific type. if the
-- context is access to class wide, indicate that the object
-- being allocated has the right specific type.
Args := New_List (Arg1);
if Is_Class_Wide_Type (Dtyp) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
-- For the task case, pass the Master_Id of the access type as
-- the value of the _Master parameter, and _Chain as the value
-- of the _Chain parameter (_Chain will be defined as part of
-- the generated code for the allocator).
-- If designated type is a concurrent type or if it is private
-- type whose definition is a concurrent type, the first
-- argument in the Init routine has to be unchecked conversion
-- to the corresponding record type. If the designated type is
-- a derived type, we also convert the argument to its root
-- type.
-- In Ada 2005, the context may be a function that returns an
-- anonymous access type. In that case the Master_Id has been
-- created when expanding the function declaration.
if Is_Concurrent_Type (T) then
Arg1 :=
Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 :=
Unchecked_Convert_To
(Corresponding_Record_Type (Full_View (T)), Arg1);
-- If we have a non-library level task with the restriction
-- No_Task_Hierarchy set, then no point in expanding.
elsif Etype (First_Formal (Init)) /= Base_Type (T) then
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
begin
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
Set_Etype (Arg1, Ftyp);
end;
end if;
if not Is_Library_Level_Entity (T)
and then Restriction_Active (No_Task_Hierarchy)
then
return;
end if;
Args := New_List (Arg1);
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
-- For the task case, pass the Master_Id of the access type as
-- the value of the _Master parameter, and _Chain as the value
-- of the _Chain parameter (_Chain will be defined as part of
-- the generated code for the allocator).
pragma Assert (Present (Parent (Base_Type (PtrT))));
Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT)));
end if;
-- In Ada 2005, the context may be a function that returns an
-- anonymous access type. In that case the Master_Id has been
-- created when expanding the function declaration.
-- If the context of the allocator is a declaration or an
-- assignment, we can generate a meaningful image for it,
-- even though subsequent assignments might remove the
-- connection between task and entity. We build this image
-- when the left-hand side is a simple variable, a simple
-- indexed assignment or a simple selected component.
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
if Nkind (Parent (N)) = N_Assignment_Statement then
declare
Nam : constant Node_Id := Name (Parent (N));
-- If we have a non-library level task with restriction
-- No_Task_Hierarchy set, then no point in expanding.
begin
if Is_Entity_Name (Nam) then
Decls :=
Build_Task_Image_Decls (
Loc,
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif Nkind_In
(Nam, N_Indexed_Component, N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
if not Is_Library_Level_Entity (T)
and then Restriction_Active (No_Task_Hierarchy)
then
Decls :=
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
return;
end if;
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then
Decls :=
Build_Task_Image_Decls (
Loc, Defining_Identifier (Parent (N)), T);
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
pragma Assert (Present (Parent (Base_Type (PtrT))));
Expand_N_Full_Type_Declaration
(Parent (Base_Type (PtrT)));
end if;
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
-- If the context of the allocator is a declaration or an
-- assignment, we can generate a meaningful image for it,
-- even though subsequent assignments might remove the
-- connection between task and entity. We build this image
-- when the left-hand side is a simple variable, a simple
-- indexed assignment or a simple selected component.
if Nkind (Parent (N)) = N_Assignment_Statement then
declare
Nam : constant Node_Id := Name (Parent (N));
begin
if Is_Entity_Name (Nam) then
Decls :=
Build_Task_Image_Decls
(Loc,
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif Nkind_In
(Nam, N_Indexed_Component, N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
end;
-- Has_Task is false, Decls not used
elsif Nkind (Parent (N)) = N_Object_Declaration then
Decls :=
Build_Task_Image_Decls
(Loc, Defining_Identifier (Parent (N)), T);
else
Decls := No_List;
end if;
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
-- Add discriminants if discriminated type
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
declare
Dis : Boolean := False;
Typ : Entity_Id;
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
begin
if Has_Discriminants (T) then
Dis := True;
Typ := T;
-- Has_Task is false, Decls not used
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Dis := True;
Typ := Full_View (T);
else
Decls := No_List;
end if;
if Dis then
-- If the allocated object will be constrained by the
-- default values for discriminants, then build a
-- subtype with those defaults, and change the allocated
-- subtype to that. Note that this happens in fewer
-- cases in Ada 2005 (AI-363).
if not Is_Constrained (Typ)
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_05
or else not Has_Constrained_Partial_View (Typ))
-- Add discriminants if discriminated type
declare
Dis : Boolean := False;
Typ : Entity_Id;
begin
if Has_Discriminants (T) then
Dis := True;
Typ := T;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
Dis := True;
Typ := Full_View (T);
end if;
Discr := First_Elmt (Discriminant_Constraint (Typ));
while Present (Discr) loop
Nod := Node (Discr);
Append (New_Copy_Tree (Node (Discr)), Args);
if Dis then
-- AI-416: when the discriminant constraint is an
-- anonymous access type make sure an accessibility
-- check is inserted if necessary (3.10.2(22.q/2))
-- If the allocated object will be constrained by the
-- default values for discriminants, then build a
-- subtype with those defaults, and change the allocated
-- subtype to that. Note that this happens in fewer
-- cases in Ada 2005 (AI-363).
if Ada_Version >= Ada_05
and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type
if not Is_Constrained (Typ)
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_05
or else
not Has_Constrained_Partial_View (Typ))
then
Apply_Accessibility_Check (Nod, Typ);
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
end if;
Next_Elmt (Discr);
end loop;
end if;
end;
Discr := First_Elmt (Discriminant_Constraint (Typ));
while Present (Discr) loop
Nod := Node (Discr);
Append (New_Copy_Tree (Node (Discr)), Args);
-- We set the allocator as analyzed so that when we analyze the
-- expression actions node, we do not get an unwanted recursive
-- expansion of the allocator expression.
-- AI-416: when the discriminant constraint is an
-- anonymous access type make sure an accessibility
-- check is inserted if necessary (3.10.2(22.q/2))
Set_Analyzed (N, True);
Nod := Relocate_Node (N);
if Ada_Version >= Ada_05
and then
Ekind (Etype (Nod)) = E_Anonymous_Access_Type
then
Apply_Accessibility_Check (Nod, Typ);
end if;
-- Here is the transformation:
-- input: new T
-- output: Temp : constant ptr_T := new T;
-- Init (Temp.all, ...);
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
Next_Elmt (Discr);
end loop;
end if;
end;
-- Here ptr_T is the pointer type for the allocator, and is the
-- subtype of the allocator.
-- We set the allocator as analyzed so that when we analyze the
-- expression actions node, we do not get an unwanted recursive
-- expansion of the allocator expression.
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Nod);
Set_Analyzed (N, True);
Nod := Relocate_Node (N);
Set_Assignment_OK (Temp_Decl);
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
-- Here is the transformation:
-- input: new T
-- output: Temp : constant ptr_T := new T;
-- Init (Temp.all, ...);
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
-- If the designated type is a task type or contains tasks,
-- create block to activate created tasks, and insert
-- declaration for Task_Image variable ahead of call.
-- Here ptr_T is the pointer type for the allocator, and is the
-- subtype of the allocator.
if Has_Task (T) then
declare
L : constant List_Id := New_List;
Blk : Node_Id;
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Nod);
begin
Build_Task_Allocate_Block (L, Nod, Args);
Blk := Last (L);
Set_Assignment_OK (Temp_Decl);
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
Insert_List_Before (First (Declarations (Blk)), Decls);
Insert_Actions (N, L);
end;
-- If the designated type is a task type or contains tasks,
-- create block to activate created tasks, and insert
-- declaration for Task_Image variable ahead of call.
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
if Has_Task (T) then
declare
L : constant List_Id := New_List;
Blk : Node_Id;
begin
Build_Task_Allocate_Block (L, Nod, Args);
Blk := Last (L);
Insert_List_Before (First (Declarations (Blk)), Decls);
Insert_Actions (N, L);
end;
if Controlled_Type (T) then
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
-- Postpone the generation of a finalization call for the
-- current allocator if it acts as a coextension.
if Controlled_Type (T) then
if Is_Dynamic_Coextension (N) then
if No (Coextensions (N)) then
Set_Coextensions (N, New_Elmt_List);
end if;
-- Postpone the generation of a finalization call for the
-- current allocator if it acts as a coextension.
Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
if Is_Dynamic_Coextension (N) then
if No (Coextensions (N)) then
Set_Coextensions (N, New_Elmt_List);
end if;
else
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
else
Flist :=
Get_Allocator_Final_List (N, Base_Type (T), PtrT);
-- Anonymous access types created for access parameters
-- are attached to an explicitly constructed controller,
-- which ensures that they can be finalized properly, even
-- if their deallocation might not happen. The list
-- associated with the controller is doubly-linked. For
-- other anonymous access types, the object may end up
-- on the global final list which is singly-linked.
-- Work needed for access discriminants in Ada 2005 ???
-- Anonymous access types created for access parameters
-- are attached to an explicitly constructed controller,
-- which ensures that they can be finalized properly,
-- even if their deallocation might not happen. The list
-- associated with the controller is doubly-linked. For
-- other anonymous access types, the object may end up
-- on the global final list which is singly-linked.
-- Work needed for access discriminants in Ada 2005 ???
if Ekind (PtrT) = E_Anonymous_Access_Type
if Ekind (PtrT) = E_Anonymous_Access_Type
and then
Nkind (Associated_Node_For_Itype (PtrT))
not in N_Subprogram_Specification
then
Attach_Level := Uint_1;
else
Attach_Level := Uint_2;
end if;
not in N_Subprogram_Specification
then
Attach_Level := Uint_1;
else
Attach_Level := Uint_2;
end if;
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal
(Loc, Attach_Level)));
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc,
Intval => Attach_Level)));
end if;
end if;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
end if;
end if;
end;
......@@ -4110,6 +4129,15 @@ package body Exp_Ch4 is
return;
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
end if;
-- If the prefix is an access type, then we unconditionally rewrite
-- if as an explicit deference. This simplifies processing for several
-- cases, including packed array cases and certain cases in which
......@@ -6236,6 +6264,7 @@ package body Exp_Ch4 is
Convert_To_Actual_Subtype (Opnd);
Arr := Etype (Opnd);
Ensure_Defined (Arr, N);
Silly_Boolean_Array_Not_Test (N, Arr);
if Nkind (Parent (N)) = N_Assignment_Statement then
if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
......@@ -6758,6 +6787,15 @@ package body Exp_Ch4 is
Generate_Discriminant_Check (N);
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
end if;
-- Gigi cannot handle unchecked conversions that are the prefix of a
-- selected component with discriminants. This must be checked during
-- expansion, because during analysis the type of the selector is not
......@@ -7025,6 +7063,15 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Pfx, Ptp);
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Pfx)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
end if;
-- Range checks are potentially also needed for cases involving
-- a slice indexed by a subtype indication, but Do_Range_Check
-- can currently only be set for expressions ???
......@@ -9072,7 +9119,8 @@ package body Exp_Ch4 is
-- configurable run time setting.
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT ("abstract interface types", N);
Error_Msg_CRT
("dynamic membership test on interface types", N);
return Empty;
end if;
......
gcc/ada/sem_cat.adb
......@@ -219,7 +219,7 @@ package body Sem_Cat is
-- unit generating the message is an internal unit. This is the
-- situation in which such messages would be ignored in any case,
-- so it is convenient not to generate them (since it causes
-- annoying inteference with debugging)
-- annoying interference with debugging).
if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit))
......@@ -332,8 +332,21 @@ package body Sem_Cat is
Nam : TSS_Name_Type;
At_Any_Place : Boolean := False) return Boolean
is
Rep_Item : Node_Id;
Rep_Item : Node_Id;
Full_Type : Entity_Id := Typ;
begin
-- In the case of a type derived from a private view, any specified
-- stream attributes will be attached to the derived type's underlying
-- type rather the derived type entity itself (which is itself private).
if Is_Private_Type (Typ)
and then Is_Derived_Type (Typ)
and then Present (Full_View (Typ))
then
Full_Type := Underlying_Type (Typ);
end if;
-- We start from the declaration node and then loop until the end of
-- the list until we find the requested attribute definition clause.
-- In Ada 2005 mode, clauses are ignored if they are not currently
......@@ -341,7 +354,7 @@ package body Sem_Cat is
-- inserted by the expander at the point where the clause occurs),
-- unless At_Any_Place is true.
Rep_Item := First_Rep_Item (Typ);
Rep_Item := First_Rep_Item (Full_Type);
while Present (Rep_Item) loop
if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
case Chars (Rep_Item) is
......@@ -1251,7 +1264,9 @@ package body Sem_Cat is
end;
end if;
-- Non-static discriminant not allowed in preelaborayted unit
-- Non-static discriminant not allowed in preelaborated unit
-- Controlled object of a type with a user-defined Initialize
-- is forbidden as well.
if Is_Record_Type (Etype (Id)) then
declare
......@@ -1274,7 +1289,14 @@ package body Sem_Cat is
PEE);
end if;
end if;
if Has_Overriding_Initialize (ET) then
Error_Msg_NE
("controlled type& does not have"
& " preelaborable initialization", N, ET);
end if;
end;
end if;
end if;
......@@ -1552,9 +1574,9 @@ package body Sem_Cat is
Error_Node);
end if;
-- For limited private type parameter, we check only the private
-- For a limited private type parameter, we check only the private
-- declaration and ignore full type declaration, unless this is
-- the only declaration for the type, eg. as a limited record.
-- the only declaration for the type, e.g., as a limited record.
elsif Is_Limited_Type (Param_Type)
and then (Nkind (Type_Decl) = N_Private_Type_Declaration
......@@ -1569,7 +1591,7 @@ package body Sem_Cat is
if No (Full_View (Param_Type))
and then Ekind (Param_Type) /= E_Record_Type
then
-- Type does not have completion yet, so if declared in in
-- Type does not have completion yet, so if declared in
-- the current RCI scope it is illegal, and will be flagged
-- subsequently.
......@@ -1585,7 +1607,11 @@ package body Sem_Cat is
-- contract model for privacy, but we support both semantics
-- for now for compatibility (note that ACATS test BXE2009
-- checks a case that conforms to the Ada 95 rules but is
-- illegal in Ada 2005).
-- illegal in Ada 2005). In the Ada 2005 case we check for the
-- possibilities of visible TSS stream subprograms or explicit
-- stream attribute definitions because the TSS subprograms
-- can be hidden in the private part while the attribute
-- definitions are still be available from the visible part.
Base_Param_Type := Base_Type (Param_Type);
Base_Under_Type := Base_Type (Underlying_Type
......@@ -1609,7 +1635,13 @@ package body Sem_Cat is
or else
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read))
or else
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write))))
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))
and then
(not Has_Stream_Attribute_Definition
(Base_Param_Type, TSS_Stream_Read)
or else
not Has_Stream_Attribute_Definition
(Base_Param_Type, TSS_Stream_Write)))
then
if K = N_Subprogram_Declaration then
Error_Node := Param_Spec;
......@@ -1761,12 +1793,15 @@ package body Sem_Cat is
-- This subprogram also enforces the checks in E.2.2(13). A value of
-- such type must not be dereferenced unless as controlling operand of
-- a dispatching call.
-- a dispatching call. Explicit dereferences not coming from source are
-- exempted from this checking because the expander produces them in
-- some cases (such as for tag checks on dispatching calls with multiple
-- controlling operands). However we do check in the case of an implicit
-- dereference that is expanded to an explicit dereference (hence the
-- test of whether Original_Node (N) comes from source).
elsif K = N_Explicit_Dereference
and then (Comes_From_Source (N)
or else (Nkind (Original_Node (N)) = N_Selected_Component
and then Comes_From_Source (Original_Node (N))))
and then Comes_From_Source (Original_Node (N))
then
E := Etype (Prefix (N));
......@@ -1788,9 +1823,12 @@ package body Sem_Cat is
-- If we are just within a procedure or function call and the
-- dereference has not been analyzed, return because this procedure
-- will be called again from sem_res Resolve_Actuals.
-- will be called again from sem_res Resolve_Actuals. The same can
-- apply in the case of dereference that is the prefix of a selected
-- component, which can be a call given in prefixed form.
if Is_Actual_Parameter (N)
if (Is_Actual_Parameter (N)
or else PK = N_Selected_Component)
and then not Analyzed (N)
then
return;
......@@ -1806,25 +1844,8 @@ package body Sem_Cat is
return;
end if;
-- The following code is needed for expansion of RACW Write
-- attribute, since such expressions can appear in the expanded
-- code.
if not Comes_From_Source (N)
and then
(PK = N_In
or else PK = N_Attribute_Reference
or else
(PK = N_Type_Conversion
and then Present (Parent (N))
and then Present (Parent (Parent (N)))
and then
Nkind (Parent (Parent (N))) = N_Selected_Component))
then
return;
end if;
Error_Msg_N ("incorrect dereference of remote type", N);
Error_Msg_N
("invalid dereference of a remote access-to-class-wide value", N);
end if;
end Validate_Remote_Access_To_Class_Wide_Type;
......
gcc/ada/sem_ch4.adb
......@@ -73,7 +73,7 @@ package body Sem_Ch4 is
-- function, and if so must be converted into an explicit call node
-- and analyzed as such. This deproceduring must be done during the first
-- pass of overload resolution, because otherwise a procedure call with
-- overloaded actuals may fail to resolve. See 4327-001 for an example.
-- overloaded actuals may fail to resolve.
procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
-- Analyze a call of the form "+"(x, y), etc. The prefix of the call
......@@ -268,6 +268,11 @@ package body Sem_Ch4 is
function Try_Object_Operation (N : Node_Id) return Boolean;
-- Ada 2005 (AI-252): Support the object.operation notation
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
-- Used for debugging: obtain list of primitive operations even if
-- type is not frozen and dispatch table is not built yet.
------------------------
-- Ambiguous_Operands --
------------------------
......@@ -366,7 +371,6 @@ package body Sem_Ch4 is
if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Find_Type (Subtype_Mark (E));
-- Analyze the qualified expression, and apply the name resolution
......@@ -491,7 +495,6 @@ package body Sem_Ch4 is
Type_Id := Process_Subtype (E, N);
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N);
......@@ -971,26 +974,6 @@ package body Sem_Ch4 is
End_Interp_List;
end if;
-- Check for not-yet-implemented cases of AI-318. We only need to check
-- for inherently limited types, because other limited types will be
-- returned by copy, which works just fine.
-- If the context is an attribute reference 'Class, this is really a
-- type conversion, which is illegal, and will be caught elsewhere.
if Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
and then Is_Inherently_Limited_Type (Etype (N))
and then (Nkind_In (Parent (N), N_Selected_Component,
N_Indexed_Component,
N_Slice)
or else
(Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) /= Name_Class))
then
Error_Msg_N ("(Ada 2005) limited function call in this context" &
" is not yet implemented", N);
end if;
end Analyze_Call;
---------------------------
......@@ -1444,7 +1427,6 @@ package body Sem_Ch4 is
-- where the prefix might include functions that return access to
-- subprograms and others that return a regular type. Disambiguation
-- of those has to take place in Resolve.
-- See e.g. 7117-014 and E317-001.
New_N :=
Make_Function_Call (Loc,
......@@ -2716,7 +2698,10 @@ package body Sem_Ch4 is
procedure Check_Common_Type (T1, T2 : Entity_Id) is
begin
if Covers (T1, T2) or else Covers (T2, T1) then
if Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1)
then
if T1 = Universal_Integer
or else T1 = Universal_Real
or else T1 = Any_Character
......@@ -2808,12 +2793,50 @@ package body Sem_Ch4 is
procedure Analyze_Reference (N : Node_Id) is
P : constant Node_Id := Prefix (N);
E : Entity_Id;
T : Entity_Id;
Acc_Type : Entity_Id;
begin
Analyze (P);
-- An interesting error check, if we take the 'Reference of an object
-- for which a pragma Atomic or Volatile has been given, and the type
-- of the object is not Atomic or Volatile, then we are in trouble. The
-- problem is that no trace of the atomic/volatile status will remain
-- for the backend to respect when it deals with the resulting pointer,
-- since the pointer type will not be marked atomic (it is a pointer to
-- the base type of the object).
-- It is not clear if that can ever occur, but in case it does, we will
-- generate an error message. Not clear if this message can ever be
-- generated, and pretty clear that it represents a bug if it is, still
-- seems worth checking!
T := Etype (P);
if Is_Entity_Name (P)
and then Is_Object_Reference (P)
then
E := Entity (P);
T := Etype (P);
if (Has_Atomic_Components (E)
and then not Has_Atomic_Components (T))
or else
(Has_Volatile_Components (E)
and then not Has_Volatile_Components (T))
or else (Is_Atomic (E) and then not Is_Atomic (T))
or else (Is_Volatile (E) and then not Is_Volatile (T))
then
Error_Msg_N ("cannot take reference to Atomic/Volatile object", N);
end if;
end if;
-- Carry on with normal processing
Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Set_Etype (Acc_Type, Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Etype (P));
Set_Etype (N, Acc_Type);
end Analyze_Reference;
......@@ -2845,7 +2868,8 @@ package body Sem_Ch4 is
-- It is known that the parent of N denotes a subprogram call. Comp
-- is an overloadable component of the concurrent type of the prefix.
-- Determine whether all formals of the parent of N and Comp are mode
-- conformant.
-- conformant. If the parent node is not analyzed yet it may be an
-- indexed component rather than a function call.
------------------------------
-- Has_Mode_Conformant_Spec --
......@@ -2858,7 +2882,13 @@ package body Sem_Ch4 is
begin
Comp_Param := First_Formal (Comp);
Param := First (Parameter_Associations (Parent (N)));
if Nkind (Parent (N)) = N_Indexed_Component then
Param := First (Expressions (Parent (N)));
else
Param := First (Parameter_Associations (Parent (N)));
end if;
while Present (Comp_Param)
and then Present (Param)
loop
......@@ -2908,14 +2938,19 @@ package body Sem_Ch4 is
-- A RACW object can never be used as prefix of a selected
-- component since that means it is dereferenced without
-- being a controlling operand of a dispatching operation
-- (RM E.2.2(15)).
-- (RM E.2.2(16/1)). Before reporting an error, we must check
-- whether this is actually a dispatching call in prefix form.
if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
and then Comes_From_Source (N)
then
Error_Msg_N
("invalid dereference of a remote access to class-wide value",
N);
if Try_Object_Operation (N) then
return;
else
Error_Msg_N
("invalid dereference of a remote access-to-class-wide value",
N);
end if;
-- Normal case of selected component applied to access type
......@@ -2932,6 +2967,27 @@ package body Sem_Ch4 is
Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
end if;
-- If we have an explicit dereference of a remote access-to-class-wide
-- value, then issue an error (see RM-E.2.2(16/1)). However we first
-- have to check for the case of a prefix that is a controlling operand
-- of a prefixed dispatching call, as the dereference is legal in that
-- case. Normally this condition is checked in Validate_Remote_Access_
-- To_Class_Wide_Type, but we have to defer the checking for selected
-- component prefixes because of the prefixed dispatching call case.
-- Note that implicit dereferences are checked for this just above.
elsif Nkind (Name) = N_Explicit_Dereference
and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
and then Comes_From_Source (N)
then
if Try_Object_Operation (N) then
return;
else
Error_Msg_N
("invalid dereference of a remote access-to-class-wide value",
N);
end if;
end if;
-- (Ada 2005): if the prefix is the limited view of a type, and
......@@ -3256,7 +3312,8 @@ package body Sem_Ch4 is
if Is_Tagged_Type (Prefix_Type)
and then
Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call)
N_Function_Call,
N_Indexed_Component)
and then Has_Mode_Conformant_Spec (Comp)
then
Has_Candidate := True;
......@@ -3322,6 +3379,7 @@ package body Sem_Ch4 is
-- the controlling formal is implicit ???
elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then Nkind (Parent (N)) /= N_Indexed_Component
and then Try_Object_Operation (N)
then
return;
......@@ -3899,7 +3957,9 @@ package body Sem_Ch4 is
if Is_Numeric_Type (T1)
and then Is_Numeric_Type (T2)
and then (Covers (T1, T2) or else Covers (T2, T1))
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if;
......@@ -3938,7 +3998,9 @@ package body Sem_Ch4 is
elsif Is_Numeric_Type (T1)
and then Is_Numeric_Type (T2)
and then (Covers (T1, T2) or else Covers (T2, T1))
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
......@@ -3983,7 +4045,9 @@ package body Sem_Ch4 is
-- already set (case of operation constructed by Exp_Fixed).
if Is_Integer_Type (T1)
and then (Covers (T1, T2) or else Covers (T2, T1))
and then (Covers (T1 => T1, T2 => T2)
or else
Covers (T1 => T2, T2 => T1))
then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if;
......@@ -4414,7 +4478,7 @@ package body Sem_Ch4 is
if Nkind (L) = N_Aggregate
and then Nkind (R) /= N_Aggregate
then
Find_Comparison_Types (R, L, Op_Id, N);
Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return;
end if;
......@@ -4632,7 +4696,7 @@ package body Sem_Ch4 is
if Nkind (L) = N_Aggregate
and then Nkind (R) /= N_Aggregate
then
Find_Equality_Types (R, L, Op_Id, N);
Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return;
end if;
......@@ -5653,8 +5717,8 @@ package body Sem_Ch4 is
(Call_Node : Node_Id;
Node_To_Replace : Node_Id)
is
Formal_Type : constant Entity_Id :=
Etype (First_Formal (Entity (Subprog)));
Control : constant Entity_Id := First_Formal (Entity (Subprog));
Formal_Type : constant Entity_Id := Etype (Control);
First_Actual : Node_Id;
begin
......@@ -5716,6 +5780,19 @@ package body Sem_Ch4 is
elsif Is_Access_Type (Formal_Type)
and then not Is_Access_Type (Etype (Obj))
then
-- A special case: A.all'access is illegal if A is an access to a
-- constant and the context requires an access to a variable.
if not Is_Access_Constant (Formal_Type) then
if (Nkind (Obj) = N_Explicit_Dereference
and then Is_Access_Constant (Etype (Prefix (Obj))))
or else not Is_Variable (Obj)
then
Error_Msg_NE
("actual for& must be a variable", Obj, Control);
end if;
end if;
Rewrite (First_Actual,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access,
......@@ -6288,10 +6365,10 @@ package body Sem_Ch4 is
-- must be identical, and the kind of call indicates the expected
-- kind of operation (function or procedure). If the type is a
-- (tagged) synchronized type, the primitive ops are attached to the
-- corresponding record type.
-- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then
Corr_Type := Corresponding_Record_Type (Obj_Type);
Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
Elmt := First_Elmt (Primitive_Operations (Corr_Type));
elsif not Is_Generic_Type (Obj_Type) then
......@@ -6480,4 +6557,30 @@ package body Sem_Ch4 is
end if;
end Try_Object_Operation;
---------
-- wpo --
---------
procedure wpo (T : Entity_Id) is
Op : Entity_Id;
E : Elmt_Id;
begin
if not Is_Tagged_Type (T) then
return;
end if;
E := First_Elmt (Primitive_Operations (Base_Type (T)));
while Present (E) loop
Op := Node (E);
Write_Int (Int (Op));
Write_Str (" === ");
Write_Name (Chars (Op));
Write_Str (" in ");
Write_Name (Chars (Scope (Op)));
Next_Elmt (E);
Write_Eol;
end loop;
end wpo;
end Sem_Ch4;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment