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
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
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 --
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);
-- 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);
-- 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;
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
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
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
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 ???
-- 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;
-- 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))
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
-- 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
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
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;
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
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.
-- 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
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;
-- 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));
-- 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;
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;
-- 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
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 --
------------------------
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
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);
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;
---------------------------
-- 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,
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
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;
-- 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 --
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
-- 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
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
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;
-- 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;
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;
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));
-- 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;
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;
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;
(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
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,
-- 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
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;
projects / gcc.git / commitdiff