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 ...@@ -1852,6 +1852,10 @@ package body Exp_Ch4 is
Ensure_Defined (Etype (R), N); Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L)); 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 if Nkind (Parent (N)) = N_Assignment_Statement
and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
then then
...@@ -1860,7 +1864,7 @@ package body Exp_Ch4 is ...@@ -1860,7 +1864,7 @@ package body Exp_Ch4 is
elsif Nkind (Parent (N)) = N_Op_Not elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And and then Nkind (N) = N_Op_And
and then 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 then
return; return;
else else
...@@ -2812,7 +2816,7 @@ package body Exp_Ch4 is ...@@ -2812,7 +2816,7 @@ package body Exp_Ch4 is
function Needs_Initialization_Call (N : Node_Id) return Boolean; function Needs_Initialization_Call (N : Node_Id) return Boolean;
-- Determine whether node N is a subtype indicator allocator which -- 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 -- -- Inside_A_Return_Statement --
...@@ -2943,27 +2947,34 @@ package body Exp_Ch4 is ...@@ -2943,27 +2947,34 @@ package body Exp_Ch4 is
Ref := New_Copy_Tree (Coext); Ref := New_Copy_Tree (Coext);
end if; end if;
-- Generate: -- No initialization call if not allowed
-- initialize (Ref)
-- attach_to_final_list (Ref, Flist, 2)
if Needs_Initialization_Call (Coext) then Check_Restriction (No_Default_Initialization, N);
Insert_Actions (N,
Make_Init_Call (
Ref => Ref,
Typ => Etype (Coext),
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, Uint_2)));
-- Generate: if not Restriction_Active (No_Default_Initialization) then
-- attach_to_final_list (Ref, Flist, 2)
else -- Generate:
Insert_Action (N, -- initialize (Ref)
Make_Attach_Call ( -- attach_to_final_list (Ref, Flist, 2)
Obj_Ref => Ref,
Flist_Ref => New_Copy_Tree (Flist), if Needs_Initialization_Call (Coext) then
With_Attach => Make_Integer_Literal (Loc, Uint_2))); 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; end if;
Next_Elmt (Coext_Elmt); Next_Elmt (Coext_Elmt);
...@@ -3174,10 +3185,11 @@ package body Exp_Ch4 is ...@@ -3174,10 +3185,11 @@ package body Exp_Ch4 is
-- Case of simple initialization required -- Case of simple initialization required
if Needs_Simple_Initialization (T) then if Needs_Simple_Initialization (T) then
Check_Restriction (No_Default_Initialization, N);
Rewrite (Expression (N), Rewrite (Expression (N),
Make_Qualified_Expression (Loc, Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (T, 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 (Expression (N)), T);
Analyze_And_Resolve (Expression (N), T); Analyze_And_Resolve (Expression (N), T);
...@@ -3193,292 +3205,299 @@ package body Exp_Ch4 is ...@@ -3193,292 +3205,299 @@ package body Exp_Ch4 is
-- Case of initialization procedure present, must be called -- Case of initialization procedure present, must be called
else else
Init := Base_Init_Proc (T); Check_Restriction (No_Default_Initialization, N);
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;
-- The initialization procedure expects a specific type. if the if not Restriction_Active (No_Default_Initialization) then
-- context is access to class wide, indicate that the object being Init := Base_Init_Proc (T);
-- allocated has the right specific type. Nod := N;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Is_Class_Wide_Type (Dtyp) then -- Construct argument list for the initialization routine call
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);
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 := Arg1 :=
Unchecked_Convert_To Make_Explicit_Dereference (Loc,
(Corresponding_Record_Type (Full_View (T)), Arg1); Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
elsif Etype (First_Formal (Init)) /= Base_Type (T) then Temp_Type := PtrT;
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
begin -- The initialization procedure expects a specific type. if the
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); -- context is access to class wide, indicate that the object
Set_Etype (Arg1, Ftyp); -- being allocated has the right specific type.
end;
end if;
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 -- If designated type is a concurrent type or if it is private
-- the value of the _Master parameter, and _Chain as the value -- type whose definition is a concurrent type, the first
-- of the _Chain parameter (_Chain will be defined as part of -- argument in the Init routine has to be unchecked conversion
-- the generated code for the allocator). -- 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 if Is_Concurrent_Type (T) then
-- anonymous access type. In that case the Master_Id has been Arg1 :=
-- created when expanding the function declaration. Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
if Has_Task (T) then elsif Is_Private_Type (T)
if No (Master_Id (Base_Type (PtrT))) then 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 elsif Etype (First_Formal (Init)) /= Base_Type (T) then
-- No_Task_Hierarchy set, then no point in expanding. 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) Args := New_List (Arg1);
and then Restriction_Active (No_Task_Hierarchy)
then
return;
end if;
-- The designated type was an incomplete type, and the -- For the task case, pass the Master_Id of the access type as
-- access type did not get expanded. Salvage it now. -- 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)))); -- In Ada 2005, the context may be a function that returns an
Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); -- anonymous access type. In that case the Master_Id has been
end if; -- created when expanding the function declaration.
-- If the context of the allocator is a declaration or an if Has_Task (T) then
-- assignment, we can generate a meaningful image for it, if No (Master_Id (Base_Type (PtrT))) then
-- 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 -- If we have a non-library level task with restriction
declare -- No_Task_Hierarchy set, then no point in expanding.
Nam : constant Node_Id := Name (Parent (N));
begin if not Is_Library_Level_Entity (T)
if Is_Entity_Name (Nam) then and then Restriction_Active (No_Task_Hierarchy)
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 then
Decls := return;
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if; end if;
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then -- The designated type was an incomplete type, and the
Decls := -- access type did not get expanded. Salvage it now.
Build_Task_Image_Decls (
Loc, Defining_Identifier (Parent (N)), T);
else pragma Assert (Present (Parent (Base_Type (PtrT))));
Decls := Build_Task_Image_Decls (Loc, T, T); Expand_N_Full_Type_Declaration
end if; (Parent (Base_Type (PtrT)));
end if;
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Decl := Last (Decls); -- If the context of the allocator is a declaration or an
Append_To (Args, -- assignment, we can generate a meaningful image for it,
New_Occurrence_Of (Defining_Identifier (Decl), Loc)); -- 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 else
Decls := No_List; Decls := Build_Task_Image_Decls (Loc, T, T);
end if; 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 Decl := Last (Decls);
Dis : Boolean := False; Append_To (Args,
Typ : Entity_Id; New_Occurrence_Of (Defining_Identifier (Decl), Loc));
begin -- Has_Task is false, Decls not used
if Has_Discriminants (T) then
Dis := True;
Typ := T;
elsif Is_Private_Type (T) else
and then Present (Full_View (T)) Decls := No_List;
and then Has_Discriminants (Full_View (T))
then
Dis := True;
Typ := Full_View (T);
end if; end if;
if Dis then -- Add discriminants if discriminated type
-- If the allocated object will be constrained by the
-- default values for discriminants, then build a declare
-- subtype with those defaults, and change the allocated Dis : Boolean := False;
-- subtype to that. Note that this happens in fewer Typ : Entity_Id;
-- cases in Ada 2005 (AI-363).
begin
if not Is_Constrained (Typ) if Has_Discriminants (T) then
and then Present (Discriminant_Default_Value Dis := True;
(First_Discriminant (Typ))) Typ := T;
and then (Ada_Version < Ada_05
or else not Has_Constrained_Partial_View (Typ)) elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then then
Typ := Build_Default_Subtype (Typ, N); Dis := True;
Set_Expression (N, New_Reference_To (Typ, Loc)); Typ := Full_View (T);
end if; end if;
Discr := First_Elmt (Discriminant_Constraint (Typ)); if Dis then
while Present (Discr) loop
Nod := Node (Discr);
Append (New_Copy_Tree (Node (Discr)), Args);
-- AI-416: when the discriminant constraint is an -- If the allocated object will be constrained by the
-- anonymous access type make sure an accessibility -- default values for discriminants, then build a
-- check is inserted if necessary (3.10.2(22.q/2)) -- 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 if not Is_Constrained (Typ)
and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_05
or else
not Has_Constrained_Partial_View (Typ))
then then
Apply_Accessibility_Check (Nod, Typ); Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
end if; end if;
Next_Elmt (Discr); Discr := First_Elmt (Discriminant_Constraint (Typ));
end loop; while Present (Discr) loop
end if; Nod := Node (Discr);
end; Append (New_Copy_Tree (Node (Discr)), Args);
-- We set the allocator as analyzed so that when we analyze the -- AI-416: when the discriminant constraint is an
-- expression actions node, we do not get an unwanted recursive -- anonymous access type make sure an accessibility
-- expansion of the allocator expression. -- check is inserted if necessary (3.10.2(22.q/2))
Set_Analyzed (N, True); if Ada_Version >= Ada_05
Nod := Relocate_Node (N); and then
Ekind (Etype (Nod)) = E_Anonymous_Access_Type
then
Apply_Accessibility_Check (Nod, Typ);
end if;
-- Here is the transformation: Next_Elmt (Discr);
-- input: new T end loop;
-- output: Temp : constant ptr_T := new T; end if;
-- Init (Temp.all, ...); end;
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
-- Here ptr_T is the pointer type for the allocator, and is the -- We set the allocator as analyzed so that when we analyze the
-- subtype of the allocator. -- expression actions node, we do not get an unwanted recursive
-- expansion of the allocator expression.
Temp_Decl := Set_Analyzed (N, True);
Make_Object_Declaration (Loc, Nod := Relocate_Node (N);
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Nod);
Set_Assignment_OK (Temp_Decl); -- Here is the transformation:
Insert_Action (N, Temp_Decl, Suppress => All_Checks); -- 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, -- Here ptr_T is the pointer type for the allocator, and is the
-- create block to activate created tasks, and insert -- subtype of the allocator.
-- declaration for Task_Image variable ahead of call.
if Has_Task (T) then Temp_Decl :=
declare Make_Object_Declaration (Loc,
L : constant List_Id := New_List; Defining_Identifier => Temp,
Blk : Node_Id; Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Nod);
begin Set_Assignment_OK (Temp_Decl);
Build_Task_Allocate_Block (L, Nod, Args); Insert_Action (N, Temp_Decl, Suppress => All_Checks);
Blk := Last (L);
Insert_List_Before (First (Declarations (Blk)), Decls); -- If the designated type is a task type or contains tasks,
Insert_Actions (N, L); -- create block to activate created tasks, and insert
end; -- declaration for Task_Image variable ahead of call.
else if Has_Task (T) then
Insert_Action (N, declare
Make_Procedure_Call_Statement (Loc, L : constant List_Id := New_List;
Name => New_Reference_To (Init, Loc), Blk : Node_Id;
Parameter_Associations => Args)); begin
end if; 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 if Controlled_Type (T) then
-- current allocator if it acts as a coextension.
if Is_Dynamic_Coextension (N) then -- Postpone the generation of a finalization call for the
if No (Coextensions (N)) then -- current allocator if it acts as a coextension.
Set_Coextensions (N, New_Elmt_List);
end if;
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 Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
else
Flist :=
Get_Allocator_Final_List (N, Base_Type (T), PtrT);
-- Anonymous access types created for access parameters -- Anonymous access types created for access parameters
-- are attached to an explicitly constructed controller, -- are attached to an explicitly constructed controller,
-- which ensures that they can be finalized properly, even -- which ensures that they can be finalized properly,
-- if their deallocation might not happen. The list -- even if their deallocation might not happen. The list
-- associated with the controller is doubly-linked. For -- associated with the controller is doubly-linked. For
-- other anonymous access types, the object may end up -- other anonymous access types, the object may end up
-- on the global final list which is singly-linked. -- on the global final list which is singly-linked.
-- Work needed for access discriminants in Ada 2005 ??? -- Work needed for access discriminants in Ada 2005 ???
if Ekind (PtrT) = E_Anonymous_Access_Type if Ekind (PtrT) = E_Anonymous_Access_Type
and then and then
Nkind (Associated_Node_For_Itype (PtrT)) Nkind (Associated_Node_For_Itype (PtrT))
not in N_Subprogram_Specification not in N_Subprogram_Specification
then then
Attach_Level := Uint_1; Attach_Level := Uint_1;
else else
Attach_Level := Uint_2; Attach_Level := Uint_2;
end if; end if;
Insert_Actions (N, Insert_Actions (N,
Make_Init_Call ( Make_Init_Call (
Ref => New_Copy_Tree (Arg1), Ref => New_Copy_Tree (Arg1),
Typ => T, Typ => T,
Flist_Ref => Flist, Flist_Ref => Flist,
With_Attach => Make_Integer_Literal With_Attach => Make_Integer_Literal (Loc,
(Loc, Attach_Level))); Intval => Attach_Level)));
end if;
end if; end if;
end if;
Rewrite (N, New_Reference_To (Temp, Loc)); Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT); Analyze_And_Resolve (N, PtrT);
end if;
end if; end if;
end; end;
...@@ -4110,6 +4129,15 @@ package body Exp_Ch4 is ...@@ -4110,6 +4129,15 @@ package body Exp_Ch4 is
return; return;
end if; 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 the prefix is an access type, then we unconditionally rewrite
-- if as an explicit deference. This simplifies processing for several -- if as an explicit deference. This simplifies processing for several
-- cases, including packed array cases and certain cases in which -- cases, including packed array cases and certain cases in which
...@@ -6236,6 +6264,7 @@ package body Exp_Ch4 is ...@@ -6236,6 +6264,7 @@ package body Exp_Ch4 is
Convert_To_Actual_Subtype (Opnd); Convert_To_Actual_Subtype (Opnd);
Arr := Etype (Opnd); Arr := Etype (Opnd);
Ensure_Defined (Arr, N); Ensure_Defined (Arr, N);
Silly_Boolean_Array_Not_Test (N, Arr);
if Nkind (Parent (N)) = N_Assignment_Statement then if Nkind (Parent (N)) = N_Assignment_Statement then
if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
...@@ -6758,6 +6787,15 @@ package body Exp_Ch4 is ...@@ -6758,6 +6787,15 @@ package body Exp_Ch4 is
Generate_Discriminant_Check (N); Generate_Discriminant_Check (N);
end if; 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 -- Gigi cannot handle unchecked conversions that are the prefix of a
-- selected component with discriminants. This must be checked during -- selected component with discriminants. This must be checked during
-- expansion, because during analysis the type of the selector is not -- expansion, because during analysis the type of the selector is not
...@@ -7025,6 +7063,15 @@ package body Exp_Ch4 is ...@@ -7025,6 +7063,15 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Pfx, Ptp); Analyze_And_Resolve (Pfx, Ptp);
end if; 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 -- Range checks are potentially also needed for cases involving
-- a slice indexed by a subtype indication, but Do_Range_Check -- a slice indexed by a subtype indication, but Do_Range_Check
-- can currently only be set for expressions ??? -- can currently only be set for expressions ???
...@@ -9072,7 +9119,8 @@ package body Exp_Ch4 is ...@@ -9072,7 +9119,8 @@ package body Exp_Ch4 is
-- configurable run time setting. -- configurable run time setting.
if not RTE_Available (RE_IW_Membership) then 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; return Empty;
end if; end if;
......
gcc/ada/sem_cat.adb
...@@ -219,7 +219,7 @@ package body Sem_Cat is ...@@ -219,7 +219,7 @@ package body Sem_Cat is
-- unit generating the message is an internal unit. This is the -- unit generating the message is an internal unit. This is the
-- situation in which such messages would be ignored in any case, -- situation in which such messages would be ignored in any case,
-- so it is convenient not to generate them (since it causes -- 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)) if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit)) and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit))
...@@ -332,8 +332,21 @@ package body Sem_Cat is ...@@ -332,8 +332,21 @@ package body Sem_Cat is
Nam : TSS_Name_Type; Nam : TSS_Name_Type;
At_Any_Place : Boolean := False) return Boolean At_Any_Place : Boolean := False) return Boolean
is is
Rep_Item : Node_Id; Rep_Item : Node_Id;
Full_Type : Entity_Id := Typ;
begin 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 -- We start from the declaration node and then loop until the end of
-- the list until we find the requested attribute definition clause. -- the list until we find the requested attribute definition clause.
-- In Ada 2005 mode, clauses are ignored if they are not currently -- In Ada 2005 mode, clauses are ignored if they are not currently
...@@ -341,7 +354,7 @@ package body Sem_Cat is ...@@ -341,7 +354,7 @@ package body Sem_Cat is
-- inserted by the expander at the point where the clause occurs), -- inserted by the expander at the point where the clause occurs),
-- unless At_Any_Place is true. -- unless At_Any_Place is true.
Rep_Item := First_Rep_Item (Typ); Rep_Item := First_Rep_Item (Full_Type);
while Present (Rep_Item) loop while Present (Rep_Item) loop
if Nkind (Rep_Item) = N_Attribute_Definition_Clause then if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
case Chars (Rep_Item) is case Chars (Rep_Item) is
...@@ -1251,7 +1264,9 @@ package body Sem_Cat is ...@@ -1251,7 +1264,9 @@ package body Sem_Cat is
end; end;
end if; 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 if Is_Record_Type (Etype (Id)) then
declare declare
...@@ -1274,7 +1289,14 @@ package body Sem_Cat is ...@@ -1274,7 +1289,14 @@ package body Sem_Cat is
PEE); PEE);
end if; end if;
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;
end if; end if;
end if; end if;
...@@ -1552,9 +1574,9 @@ package body Sem_Cat is ...@@ -1552,9 +1574,9 @@ package body Sem_Cat is
Error_Node); Error_Node);
end if; 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 -- 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) elsif Is_Limited_Type (Param_Type)
and then (Nkind (Type_Decl) = N_Private_Type_Declaration and then (Nkind (Type_Decl) = N_Private_Type_Declaration
...@@ -1569,7 +1591,7 @@ package body Sem_Cat is ...@@ -1569,7 +1591,7 @@ package body Sem_Cat is
if No (Full_View (Param_Type)) if No (Full_View (Param_Type))
and then Ekind (Param_Type) /= E_Record_Type and then Ekind (Param_Type) /= E_Record_Type
then 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 -- the current RCI scope it is illegal, and will be flagged
-- subsequently. -- subsequently.
...@@ -1585,7 +1607,11 @@ package body Sem_Cat is ...@@ -1585,7 +1607,11 @@ package body Sem_Cat is
-- contract model for privacy, but we support both semantics -- contract model for privacy, but we support both semantics
-- for now for compatibility (note that ACATS test BXE2009 -- for now for compatibility (note that ACATS test BXE2009
-- checks a case that conforms to the Ada 95 rules but is -- 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_Param_Type := Base_Type (Param_Type);
Base_Under_Type := Base_Type (Underlying_Type Base_Under_Type := Base_Type (Underlying_Type
...@@ -1609,7 +1635,13 @@ package body Sem_Cat is ...@@ -1609,7 +1635,13 @@ package body Sem_Cat is
or else or else
Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read)) Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read))
or else 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 then
if K = N_Subprogram_Declaration then if K = N_Subprogram_Declaration then
Error_Node := Param_Spec; Error_Node := Param_Spec;
...@@ -1761,12 +1793,15 @@ package body Sem_Cat is ...@@ -1761,12 +1793,15 @@ package body Sem_Cat is
-- This subprogram also enforces the checks in E.2.2(13). A value of -- 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 -- 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 elsif K = N_Explicit_Dereference
and then (Comes_From_Source (N) and then Comes_From_Source (Original_Node (N))
or else (Nkind (Original_Node (N)) = N_Selected_Component
and then Comes_From_Source (Original_Node (N))))
then then
E := Etype (Prefix (N)); E := Etype (Prefix (N));
...@@ -1788,9 +1823,12 @@ package body Sem_Cat is ...@@ -1788,9 +1823,12 @@ package body Sem_Cat is
-- If we are just within a procedure or function call and the -- If we are just within a procedure or function call and the
-- dereference has not been analyzed, return because this procedure -- 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) and then not Analyzed (N)
then then
return; return;
...@@ -1806,25 +1844,8 @@ package body Sem_Cat is ...@@ -1806,25 +1844,8 @@ package body Sem_Cat is
return; return;
end if; end if;
-- The following code is needed for expansion of RACW Write Error_Msg_N
-- attribute, since such expressions can appear in the expanded ("invalid dereference of a remote access-to-class-wide value", N);
-- 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);
end if; end if;
end Validate_Remote_Access_To_Class_Wide_Type; end Validate_Remote_Access_To_Class_Wide_Type;
......
gcc/ada/sem_ch4.adb
...@@ -73,7 +73,7 @@ package body Sem_Ch4 is ...@@ -73,7 +73,7 @@ package body Sem_Ch4 is
-- function, and if so must be converted into an explicit call node -- function, and if so must be converted into an explicit call node
-- and analyzed as such. This deproceduring must be done during the first -- and analyzed as such. This deproceduring must be done during the first
-- pass of overload resolution, because otherwise a procedure call with -- 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); 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 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call
...@@ -268,6 +268,11 @@ package body Sem_Ch4 is ...@@ -268,6 +268,11 @@ package body Sem_Ch4 is
function Try_Object_Operation (N : Node_Id) return Boolean; function Try_Object_Operation (N : Node_Id) return Boolean;
-- Ada 2005 (AI-252): Support the object.operation notation -- 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 -- -- Ambiguous_Operands --
------------------------ ------------------------
...@@ -366,7 +371,6 @@ package body Sem_Ch4 is ...@@ -366,7 +371,6 @@ package body Sem_Ch4 is
if Nkind (E) = N_Qualified_Expression then if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N); Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type); Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Find_Type (Subtype_Mark (E)); Find_Type (Subtype_Mark (E));
-- Analyze the qualified expression, and apply the name resolution -- Analyze the qualified expression, and apply the name resolution
...@@ -491,7 +495,6 @@ package body Sem_Ch4 is ...@@ -491,7 +495,6 @@ package body Sem_Ch4 is
Type_Id := Process_Subtype (E, N); Type_Id := Process_Subtype (E, N);
Acc_Type := Create_Itype (E_Allocator_Type, N); Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type); Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Type_Id); Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N); Check_Fully_Declared (Type_Id, N);
...@@ -971,26 +974,6 @@ package body Sem_Ch4 is ...@@ -971,26 +974,6 @@ package body Sem_Ch4 is
End_Interp_List; End_Interp_List;
end if; 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; end Analyze_Call;
--------------------------- ---------------------------
...@@ -1444,7 +1427,6 @@ package body Sem_Ch4 is ...@@ -1444,7 +1427,6 @@ package body Sem_Ch4 is
-- where the prefix might include functions that return access to -- where the prefix might include functions that return access to
-- subprograms and others that return a regular type. Disambiguation -- subprograms and others that return a regular type. Disambiguation
-- of those has to take place in Resolve. -- of those has to take place in Resolve.
-- See e.g. 7117-014 and E317-001.
New_N := New_N :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
...@@ -2716,7 +2698,10 @@ package body Sem_Ch4 is ...@@ -2716,7 +2698,10 @@ package body Sem_Ch4 is
procedure Check_Common_Type (T1, T2 : Entity_Id) is procedure Check_Common_Type (T1, T2 : Entity_Id) is
begin 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 if T1 = Universal_Integer
or else T1 = Universal_Real or else T1 = Universal_Real
or else T1 = Any_Character or else T1 = Any_Character
...@@ -2808,12 +2793,50 @@ package body Sem_Ch4 is ...@@ -2808,12 +2793,50 @@ package body Sem_Ch4 is
procedure Analyze_Reference (N : Node_Id) is procedure Analyze_Reference (N : Node_Id) is
P : constant Node_Id := Prefix (N); P : constant Node_Id := Prefix (N);
E : Entity_Id;
T : Entity_Id;
Acc_Type : Entity_Id; Acc_Type : Entity_Id;
begin begin
Analyze (P); 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); Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type); Set_Etype (Acc_Type, Acc_Type);
Init_Size_Align (Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Etype (P)); Set_Directly_Designated_Type (Acc_Type, Etype (P));
Set_Etype (N, Acc_Type); Set_Etype (N, Acc_Type);
end Analyze_Reference; end Analyze_Reference;
...@@ -2845,7 +2868,8 @@ package body Sem_Ch4 is ...@@ -2845,7 +2868,8 @@ package body Sem_Ch4 is
-- It is known that the parent of N denotes a subprogram call. Comp -- It is known that the parent of N denotes a subprogram call. Comp
-- is an overloadable component of the concurrent type of the prefix. -- is an overloadable component of the concurrent type of the prefix.
-- Determine whether all formals of the parent of N and Comp are mode -- 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 -- -- Has_Mode_Conformant_Spec --
...@@ -2858,7 +2882,13 @@ package body Sem_Ch4 is ...@@ -2858,7 +2882,13 @@ package body Sem_Ch4 is
begin begin
Comp_Param := First_Formal (Comp); 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) while Present (Comp_Param)
and then Present (Param) and then Present (Param)
loop loop
...@@ -2908,14 +2938,19 @@ package body Sem_Ch4 is ...@@ -2908,14 +2938,19 @@ package body Sem_Ch4 is
-- A RACW object can never be used as prefix of a selected -- A RACW object can never be used as prefix of a selected
-- component since that means it is dereferenced without -- component since that means it is dereferenced without
-- being a controlling operand of a dispatching operation -- 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) if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
and then Comes_From_Source (N) and then Comes_From_Source (N)
then then
Error_Msg_N if Try_Object_Operation (N) then
("invalid dereference of a remote access to class-wide value", return;
N); 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 -- Normal case of selected component applied to access type
...@@ -2932,6 +2967,27 @@ package body Sem_Ch4 is ...@@ -2932,6 +2967,27 @@ package body Sem_Ch4 is
Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
end if; 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; end if;
-- (Ada 2005): if the prefix is the limited view of a type, and -- (Ada 2005): if the prefix is the limited view of a type, and
...@@ -3256,7 +3312,8 @@ package body Sem_Ch4 is ...@@ -3256,7 +3312,8 @@ package body Sem_Ch4 is
if Is_Tagged_Type (Prefix_Type) if Is_Tagged_Type (Prefix_Type)
and then and then
Nkind_In (Parent (N), N_Procedure_Call_Statement, Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call) N_Function_Call,
N_Indexed_Component)
and then Has_Mode_Conformant_Spec (Comp) and then Has_Mode_Conformant_Spec (Comp)
then then
Has_Candidate := True; Has_Candidate := True;
...@@ -3322,6 +3379,7 @@ package body Sem_Ch4 is ...@@ -3322,6 +3379,7 @@ package body Sem_Ch4 is
-- the controlling formal is implicit ??? -- the controlling formal is implicit ???
elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then Nkind (Parent (N)) /= N_Indexed_Component
and then Try_Object_Operation (N) and then Try_Object_Operation (N)
then then
return; return;
...@@ -3899,7 +3957,9 @@ package body Sem_Ch4 is ...@@ -3899,7 +3957,9 @@ package body Sem_Ch4 is
if Is_Numeric_Type (T1) if Is_Numeric_Type (T1)
and then Is_Numeric_Type (T2) 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 then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if; end if;
...@@ -3938,7 +3998,9 @@ package body Sem_Ch4 is ...@@ -3938,7 +3998,9 @@ package body Sem_Ch4 is
elsif Is_Numeric_Type (T1) elsif Is_Numeric_Type (T1)
and then Is_Numeric_Type (T2) 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 then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
...@@ -3983,7 +4045,9 @@ package body Sem_Ch4 is ...@@ -3983,7 +4045,9 @@ package body Sem_Ch4 is
-- already set (case of operation constructed by Exp_Fixed). -- already set (case of operation constructed by Exp_Fixed).
if Is_Integer_Type (T1) 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 then
Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
end if; end if;
...@@ -4414,7 +4478,7 @@ package body Sem_Ch4 is ...@@ -4414,7 +4478,7 @@ package body Sem_Ch4 is
if Nkind (L) = N_Aggregate if Nkind (L) = N_Aggregate
and then Nkind (R) /= N_Aggregate and then Nkind (R) /= N_Aggregate
then then
Find_Comparison_Types (R, L, Op_Id, N); Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return; return;
end if; end if;
...@@ -4632,7 +4696,7 @@ package body Sem_Ch4 is ...@@ -4632,7 +4696,7 @@ package body Sem_Ch4 is
if Nkind (L) = N_Aggregate if Nkind (L) = N_Aggregate
and then Nkind (R) /= N_Aggregate and then Nkind (R) /= N_Aggregate
then then
Find_Equality_Types (R, L, Op_Id, N); Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return; return;
end if; end if;
...@@ -5653,8 +5717,8 @@ package body Sem_Ch4 is ...@@ -5653,8 +5717,8 @@ package body Sem_Ch4 is
(Call_Node : Node_Id; (Call_Node : Node_Id;
Node_To_Replace : Node_Id) Node_To_Replace : Node_Id)
is is
Formal_Type : constant Entity_Id := Control : constant Entity_Id := First_Formal (Entity (Subprog));
Etype (First_Formal (Entity (Subprog))); Formal_Type : constant Entity_Id := Etype (Control);
First_Actual : Node_Id; First_Actual : Node_Id;
begin begin
...@@ -5716,6 +5780,19 @@ package body Sem_Ch4 is ...@@ -5716,6 +5780,19 @@ package body Sem_Ch4 is
elsif Is_Access_Type (Formal_Type) elsif Is_Access_Type (Formal_Type)
and then not Is_Access_Type (Etype (Obj)) and then not Is_Access_Type (Etype (Obj))
then 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, Rewrite (First_Actual,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Attribute_Name => Name_Access, Attribute_Name => Name_Access,
...@@ -6288,10 +6365,10 @@ package body Sem_Ch4 is ...@@ -6288,10 +6365,10 @@ package body Sem_Ch4 is
-- must be identical, and the kind of call indicates the expected -- must be identical, and the kind of call indicates the expected
-- kind of operation (function or procedure). If the type is a -- kind of operation (function or procedure). If the type is a
-- (tagged) synchronized type, the primitive ops are attached to the -- (tagged) synchronized type, the primitive ops are attached to the
-- corresponding record type. -- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then 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)); Elmt := First_Elmt (Primitive_Operations (Corr_Type));
elsif not Is_Generic_Type (Obj_Type) then elsif not Is_Generic_Type (Obj_Type) then
...@@ -6480,4 +6557,30 @@ package body Sem_Ch4 is ...@@ -6480,4 +6557,30 @@ package body Sem_Ch4 is
end if; end if;
end Try_Object_Operation; 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; 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