with Elists; use Elists;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
-with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
-- T is a derived tagged type. Check whether the type extension is null.
-- If the parent type is fully initialized, T can be treated as such.
- procedure Mark_Non_ALFA_Subprogram_Unconditional
- (Msg : String;
- N : Node_Id);
- -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the
- -- latter to be small and inlined. If the subprogram being marked as not in
- -- ALFA is annotated with Formal_Proof being On, then an error is issued
- -- with message Msg on node N.
-
------------------------------
-- Abstract_Interface_List --
------------------------------
end if;
end Cannot_Raise_Constraint_Error;
+ --------------------------------
+ -- Check_Implicit_Dereference --
+ --------------------------------
+
+ procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id)
+ is
+ Disc : Entity_Id;
+ Desig : Entity_Id;
+
+ begin
+ if Ada_Version < Ada_2012
+ or else not Has_Implicit_Dereference (Base_Type (Typ))
+ then
+ return;
+
+ elsif not Comes_From_Source (Nam) then
+ return;
+
+ elsif Is_Entity_Name (Nam)
+ and then Is_Type (Entity (Nam))
+ then
+ null;
+
+ else
+ Disc := First_Discriminant (Typ);
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Desig := Designated_Type (Etype (Disc));
+ Add_One_Interp (Nam, Disc, Desig);
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ end Check_Implicit_Dereference;
+
---------------------------------------
-- Check_Later_Vs_Basic_Declarations --
---------------------------------------
return;
end if;
- -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
+ -- Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested
-- calls within a construct have been collected. If one of them is
-- writable and overlaps with another one, evaluation of the enclosing
-- construct is nondeterministic. This is illegal in Ada 2012, but is
end if;
end Current_Subprogram;
- ------------------------------
- -- Mark_Non_ALFA_Subprogram --
- ------------------------------
-
- procedure Mark_Non_ALFA_Subprogram (Msg : String; N : Node_Id) is
- begin
- -- Isolate marking of the current subprogram body so that the body of
- -- Mark_Non_ALFA_Subprogram is small and inlined.
-
- if ALFA_Mode then
- Mark_Non_ALFA_Subprogram_Unconditional (Msg, N);
- end if;
- end Mark_Non_ALFA_Subprogram;
-
- --------------------------------------------
- -- Mark_Non_ALFA_Subprogram_Unconditional --
- --------------------------------------------
-
- procedure Mark_Non_ALFA_Subprogram_Unconditional
- (Msg : String;
- N : Node_Id)
- is
- Cur_Subp : constant Entity_Id := Current_Subprogram;
-
- begin
- if Present (Cur_Subp)
- and then (Is_Subprogram (Cur_Subp)
- or else Is_Generic_Subprogram (Cur_Subp))
- then
- -- If the subprogram has been annotated with Formal_Proof being On,
- -- then an error must be issued to notify the user that this
- -- subprogram unexpectedly falls outside the ALFA subset.
-
- if Formal_Proof_On (Cur_Subp) then
- Error_Msg_F (Msg, N);
- end if;
-
- -- If the non-ALFA construct is in a precondition or postcondition,
- -- then mark the subprogram as not in ALFA, because neither the
- -- subprogram nor its callers can be proved formally.
-
- -- If the non-ALFA construct is in a regular piece of code inside the
- -- body of the subprogram, then mark the subprogram body as not in
- -- ALFA, because the subprogram cannot be proved formally, but its
- -- callers could.
-
- if In_Pre_Post_Expression then
- Set_Is_In_ALFA (Cur_Subp, False);
- else
- Set_Body_Is_In_ALFA (Cur_Subp, False);
- end if;
- end if;
- end Mark_Non_ALFA_Subprogram_Unconditional;
-
---------------------
-- Defining_Entity --
---------------------
end if;
end Get_Actual_Subtype_If_Available;
+ ------------------------
+ -- Get_Body_From_Stub --
+ ------------------------
+
+ function Get_Body_From_Stub (N : Node_Id) return Node_Id is
+ begin
+ return Proper_Body (Unit (Library_Unit (N)));
+ end Get_Body_From_Stub;
+
-------------------------------
-- Get_Default_External_Name --
-------------------------------
Strval => String_From_Name_Buffer);
end Get_Default_External_Name;
+ --------------------------
+ -- Get_Enclosing_Object --
+ --------------------------
+
+ function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
+ begin
+ if Is_Entity_Name (N) then
+ return Entity (N);
+ else
+ case Nkind (N) is
+ when N_Indexed_Component |
+ N_Slice |
+ N_Selected_Component =>
+
+ -- If not generating code, a dereference may be left implicit.
+ -- In thoses cases, return Empty.
+
+ if Is_Access_Type (Etype (Prefix (N))) then
+ return Empty;
+ else
+ return Get_Enclosing_Object (Prefix (N));
+ end if;
+
+ when N_Type_Conversion =>
+ return Get_Enclosing_Object (Expression (N));
+
+ when others =>
+ return Empty;
+ end case;
+ end if;
+ end Get_Enclosing_Object;
+
---------------------------
-- Get_Enum_Lit_From_Pos --
---------------------------
end if;
end Get_Enum_Lit_From_Pos;
+ ---------------------------------------
+ -- Get_Ensures_From_Test_Case_Pragma --
+ ---------------------------------------
+
+ function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
+ Args : constant List_Id := Pragma_Argument_Associations (N);
+ Res : Node_Id;
+
+ begin
+ if List_Length (Args) = 4 then
+ Res := Pick (Args, 4);
+
+ else
+ Res := Pick (Args, 3);
+ if Chars (Res) /= Name_Ensures then
+ Res := Empty;
+ end if;
+ end if;
+
+ return Res;
+ end Get_Ensures_From_Test_Case_Pragma;
+
------------------------
-- Get_Generic_Entity --
------------------------
return Entity_Id (Get_Name_Table_Info (Id));
end Get_Name_Entity_Id;
+ ------------------------------------
+ -- Get_Name_From_Test_Case_Pragma --
+ ------------------------------------
+
+ function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
+ Arg : constant Node_Id :=
+ Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
+ begin
+ return Strval (Expr_Value_S (Arg));
+ end Get_Name_From_Test_Case_Pragma;
+
-------------------
-- Get_Pragma_Id --
-------------------
return R;
end Get_Renamed_Entity;
+ ----------------------------------------
+ -- Get_Requires_From_Test_Case_Pragma --
+ ----------------------------------------
+
+ function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
+ Args : constant List_Id := Pragma_Argument_Associations (N);
+ Res : Node_Id;
+
+ begin
+ Res := Pick (Args, 3);
+ if Chars (Res) /= Name_Requires then
+ Res := Empty;
+ end if;
+
+ return Res;
+ end Get_Requires_From_Test_Case_Pragma;
+
-------------------------
-- Get_Subprogram_Body --
-------------------------
begin
-- Verify that prefix is analyzed and has the proper form. Note that
- -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also
- -- produce the address of an entity, do not analyze their prefix
- -- because they denote entities that are not necessarily visible.
+ -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
+ -- which also produce the address of an entity, do not analyze their
+ -- prefix because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
return Ada_Version >= Ada_2005
or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement;
+ --------------------------------------------------
+ -- Is_Subprogram_Stub_Without_Prior_Declaration --
+ --------------------------------------------------
+
+ function Is_Subprogram_Stub_Without_Prior_Declaration
+ (N : Node_Id) return Boolean is
+
+ begin
+ -- A subprogram stub without prior declaration serves as declaration for
+ -- the actual subprogram body. As such, it has an attached defining
+ -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
+
+ return Nkind (N) = N_Subprogram_Body_Stub
+ and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
+ end Is_Subprogram_Stub_Without_Prior_Declaration;
+
---------------------------------
-- Is_Synchronized_Tagged_Type --
---------------------------------
elsif Is_Record_Type (Btype) then
Component := First_Entity (Btype);
- while Present (Component) loop
-
+ while Present (Component)
+ and then Comes_From_Source (Component)
+ loop
-- Skip anonymous types generated by constrained components
if not Is_Type (Component) then
-- subprogram bodies. Detect those cases by testing whether
-- Process_End_Label was called for a body (Typ = 't') or a package.
- if (SPARK_Mode or else Restriction_Check_Required (SPARK))
+ if Restriction_Check_Required (SPARK)
and then (Typ = 't' or else Ekind (Ent) = E_Package)
then
Error_Msg_Node_1 := Endl;
-- Set_Current_Entity --
------------------------
- -- The given entity is to be set as the currently visible definition
- -- of its associated name (i.e. the Node_Id associated with its name).
- -- All we have to do is to get the name from the identifier, and
- -- then set the associated Node_Id to point to the given entity.
+ -- The given entity is to be set as the currently visible definition of its
+ -- associated name (i.e. the Node_Id associated with its name). All we have
+ -- to do is to get the name from the identifier, and then set the
+ -- associated Node_Id to point to the given entity.
procedure Set_Current_Entity (E : Entity_Id) is
begin
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
+ ------------------------------------
+ -- Type_Without_Stream_Operation --
+ ------------------------------------
+
+ function Type_Without_Stream_Operation
+ (T : Entity_Id;
+ Op : TSS_Name_Type := TSS_Null) return Entity_Id
+ is
+ BT : constant Entity_Id := Base_Type (T);
+ Op_Missing : Boolean;
+
+ begin
+ if not Restriction_Active (No_Default_Stream_Attributes) then
+ return Empty;
+ end if;
+
+ if Is_Elementary_Type (T) then
+ if Op = TSS_Null then
+ Op_Missing :=
+ No (TSS (BT, TSS_Stream_Read))
+ or else No (TSS (BT, TSS_Stream_Write));
+
+ else
+ Op_Missing := No (TSS (BT, Op));
+ end if;
+
+ if Op_Missing then
+ return T;
+ else
+ return Empty;
+ end if;
+
+ elsif Is_Array_Type (T) then
+ return Type_Without_Stream_Operation (Component_Type (T), Op);
+
+ elsif Is_Record_Type (T) then
+ declare
+ Comp : Entity_Id;
+ C_Typ : Entity_Id;
+
+ begin
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
+
+ if Present (C_Typ) then
+ return C_Typ;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return Empty;
+ end;
+
+ elsif Is_Private_Type (T)
+ and then Present (Full_View (T))
+ then
+ return Type_Without_Stream_Operation (Full_View (T), Op);
+ else
+ return Empty;
+ end if;
+ end Type_Without_Stream_Operation;
+
+ ----------------------------
+ -- Unique_Defining_Entity --
+ ----------------------------
+
+ function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
+ begin
+ case Nkind (N) is
+ when N_Package_Body =>
+ return Corresponding_Spec (N);
+
+ when N_Subprogram_Body =>
+ if Acts_As_Spec (N) then
+ return Defining_Entity (N);
+ else
+ return Corresponding_Spec (N);
+ end if;
+
+ when others =>
+ return Defining_Entity (N);
+ end case;
+ end Unique_Defining_Entity;
+
+ -----------------
+ -- Unique_Name --
+ -----------------
+
+ function Unique_Name (E : Entity_Id) return String is
+
+ function Get_Scoped_Name (E : Entity_Id) return String;
+ -- Return the name of E prefixed by all the names of the scopes to which
+ -- E belongs, except for Standard.
+
+ ---------------------
+ -- Get_Scoped_Name --
+ ---------------------
+
+ function Get_Scoped_Name (E : Entity_Id) return String is
+ Name : constant String := Get_Name_String (Chars (E));
+ begin
+ if Has_Fully_Qualified_Name (E)
+ or else Scope (E) = Standard_Standard
+ then
+ return Name;
+ else
+ return Get_Scoped_Name (Scope (E)) & "__" & Name;
+ end if;
+ end Get_Scoped_Name;
+
+ -- Start of processing for Unique_Name
+
+ begin
+ if E = Standard_Standard then
+ return Get_Name_String (Name_Standard);
+
+ elsif Scope (E) = Standard_Standard
+ and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
+ then
+ return Get_Name_String (Name_Standard) & "__" &
+ Get_Name_String (Chars (E));
+
+ else
+ return Get_Scoped_Name (E);
+ end if;
+ end Unique_Name;
+
--------------------------
-- Unit_Declaration_Node --
--------------------------
-- Start of processing for Unit_Is_Visible
begin
- -- The currrent unit is directly visible.
+ -- The currrent unit is directly visible
if Curr = U then
return True;
elsif Unit_In_Context (Curr) then
return True;
- -- If the current unit is a body, check the context of the spec.
+ -- If the current unit is a body, check the context of the spec
elsif Nkind (Unit (Curr)) = N_Package_Body
or else
end if;
end if;
- -- If the spec is a child unit, examine the parents.
+ -- If the spec is a child unit, examine the parents
if Is_Child_Unit (Curr_Entity) then
if Nkind (Unit (Curr)) in N_Unit_Body then
----------------
procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
- Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
- Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+ Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
+ Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
Matching_Field : Entity_Id;
-- Entity to give a more precise suggestion on how to write a one-
if Comes_From_Source (Expec_Type) then
Matching_Field := Expec_Type;
- -- For an assignment, use name of target.
+ -- For an assignment, use name of target
elsif Nkind (Parent (Expr)) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parent (Expr)))