+2016-10-12 Jerome Lambourg <lambourg@adacore.com>
+
+ * init.c: Make sure to call finit on x86_64-vx7 to reinitialize
+ the FPU unit.
+
+2016-10-12 Arnaud Charlet <charlet@adacore.com>
+
+ * lib-load.adb (Load_Unit): Generate an error message even when
+ Error_Node is null.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-writ.adb (Write_ALI): Disable optimization related to transitive
+ limited_with clauses for now.
+
+2016-10-12 Javier Miranda <miranda@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Generating C
+ code handle 'old located in inlined _postconditions procedures.
+ (Analyze_Attribute [Attribute_Result]): Handle 'result when
+ rewriting the attribute as a reference to the formal parameter
+ _Result of inlined _postconditions procedures.
+
+2016-10-12 Tristan Gingold <gingold@adacore.com>
+
+ * s-rident.ads (Profile_Info): Remove
+ Max_Protected_Entries restriction from GNAT_Extended_Ravenscar
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration):
+ Not a controlled type on restricted runtimes.
+
+2016-10-12 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Derive_Subprogram): Add test
+ for Is_Controlled of Parent_Type when determining whether an
+ inherited subprogram with one of the special names Initialize,
+ Adjust, or Finalize should be derived with its normal name even
+ when inherited as a private operation (which would normally
+ result in the inherited operation having a special "hidden" name).
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Call): If a function call returns a
+ limited view of a type replace it with the non-limited view,
+ which must be available when compiling call. This was already
+ done elsewhere for non-overloaded calls, but needs to be done
+ after resolution if function name is overloaded.
+
+2016-10-12 Javier Miranda <miranda@adacore.com>
+
+ * a-tags.adb (IW_Membership [private]): new overloaded
+ subprogram that factorizes the code needed to check if a
+ given type implements an interface type.
+ (IW_Membership
+ [public]): invoke the new internal IW_Membership function.
+ (Is_Descendant_At_Same_Level): Fix this routine to implement RM
+ 3.9 (12.3/3)
+
2016-10-12 Tristan Gingold <gingold@adacore.com>
* exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
+ function IW_Membership
+ (Descendant_TSD : Type_Specific_Data_Ptr;
+ T : Tag) return Boolean;
+ -- Subsidiary function of IW_Membership and CW_Membership which factorizes
+ -- the functionality needed to check if a given descendant implements an
+ -- interface tag T.
+
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated). See comment in body
-- IW_Membership --
-------------------
- -- Canonical implementation of Classwide Membership corresponding to:
-
- -- Obj in Iface'Class
-
- -- Each dispatch table contains a table with the tags of all the
- -- implemented interfaces.
-
- -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
- -- that are contained in the dispatch table referenced by Obj'Tag.
-
- function IW_Membership (This : System.Address; T : Tag) return Boolean is
+ function IW_Membership
+ (Descendant_TSD : Type_Specific_Data_Ptr;
+ T : Tag) return Boolean
+ is
Iface_Table : Interface_Data_Ptr;
- Obj_Base : System.Address;
- Obj_DT : Dispatch_Table_Ptr;
- Obj_TSD : Type_Specific_Data_Ptr;
begin
- Obj_Base := Base_Address (This);
- Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
- Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
- Iface_Table := Obj_TSD.Interfaces_Table;
+ Iface_Table := Descendant_TSD.Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
- for Id in 0 .. Obj_TSD.Idepth loop
- if Obj_TSD.Tags_Table (Id) = T then
+ for Id in 0 .. Descendant_TSD.Idepth loop
+ if Descendant_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
return False;
end IW_Membership;
+ -------------------
+ -- IW_Membership --
+ -------------------
+
+ -- Canonical implementation of Classwide Membership corresponding to:
+
+ -- Obj in Iface'Class
+
+ -- Each dispatch table contains a table with the tags of all the
+ -- implemented interfaces.
+
+ -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
+ -- that are contained in the dispatch table referenced by Obj'Tag.
+
+ function IW_Membership (This : System.Address; T : Tag) return Boolean is
+ Obj_Base : System.Address;
+ Obj_DT : Dispatch_Table_Ptr;
+ Obj_TSD : Type_Specific_Data_Ptr;
+
+ begin
+ Obj_Base := Base_Address (This);
+ Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
+ Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
+
+ return IW_Membership (Obj_TSD, T);
+ end IW_Membership;
+
-------------------
-- Expanded_Name --
-------------------
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
- D_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
- A_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
- D_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
- A_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
-
begin
- return CW_Membership (Descendant, Ancestor)
- and then D_TSD.Access_Level = A_TSD.Access_Level;
+ if Descendant = Ancestor then
+ return True;
+
+ else
+ declare
+ D_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
+ A_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
+ D_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
+ A_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
+ begin
+ return D_TSD.Access_Level = A_TSD.Access_Level
+ and then (CW_Membership (Descendant, Ancestor)
+ or else
+ IW_Membership (D_TSD, Ancestor));
+ end;
+ end if;
end Is_Descendant_At_Same_Level;
------------
#endif
#endif
-#if defined (__i386__) && !defined (VTHREADS)
+#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
/* This is used to properly initialize the FPU on an x86 for each
- process thread. Is this needed for x86_64 ??? */
+ process thread. */
asm ("finit");
#endif
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Generate message if unit required
- if Required and then Present (Error_Node) then
+ if Required then
if Is_Predefined_File_Name (Fname) then
-- This is a predefined library unit which is not present
-- the message about the restriction violation is generated,
-- if needed.
- Check_Restricted_Unit (Load_Name, Error_Node);
+ if Present (Error_Node) then
+ Check_Restricted_Unit (Load_Name, Error_Node);
+ end if;
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg -- CODEFIX
-- in the context of the parent, and their file table entries are
-- not properly decorated, they are recognized syntactically.
- if Present (Cunit_Entity (Unum))
+ -- This optimization is disabled when inline is active, because
+ -- inline may propose some bodies for inlining, and decide later
+ -- that they may lead to circularities, in which case they are
+ -- also left unanalyzed in the file table. There is no simple way
+ -- to distinguish between the two kinds of unanalyzed entries,
+ -- so simplest is to skip this step.
+
+ -- Actually, this optimization is always disabled, because it
+ -- breaks gnatfind.
+
+ if False -- ???
+ and then Present (Cunit_Entity (Unum))
and then Ekind (Cunit_Entity (Unum)) = E_Void
and then Nkind (Unit (Cunit (Unum))) /= N_Subunit
+ and then not Inline_Active
then
goto Next_Unit;
end if;
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
- Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
Value =>
(Max_Asynchronous_Select_Nesting => 0,
- Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));
-- appear on a subprogram renaming, when the renamed entity is an
-- attribute reference.
- if not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
- N_Entry_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ -- Generating C code the internally built nested _postcondition
+ -- subprograms are inlined; after expanded, inlined aspects are
+ -- located in the internal block generated by the frontend.
+
+ if Nkind (Subp_Decl) = N_Block_Statement
+ and then Modify_Tree_For_C
+ and then In_Inlined_Body
+ then
+ null;
+
+ elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
+ N_Entry_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration)
then
return;
end if;
-- Local variables
+ In_Inlined_C_Postcondition : constant Boolean :=
+ Modify_Tree_For_C and then In_Inlined_Body;
+
Legal : Boolean;
Pref_Id : Entity_Id;
Spec_Id : Entity_Id;
-- The exception to this rule is when generating C since in this case
-- postconditions are inlined.
- if No (Spec_Id)
- and then Modify_Tree_For_C
- and then In_Inlined_Body
- then
+ if No (Spec_Id) and then In_Inlined_C_Postcondition then
Spec_Id := Entity (P);
elsif not Legal then
-- Instead, rewrite the attribute as a reference to formal parameter
-- _Result of the _Postconditions procedure.
- if Chars (Spec_Id) = Name_uPostconditions then
+ if Chars (Spec_Id) = Name_uPostconditions
+ or else
+ (In_Inlined_C_Postcondition
+ and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
+ then
Rewrite (N, Make_Identifier (Loc, Name_uResult));
-- The type of formal parameter _Result is that of the function
or else Is_Internal (Parent_Subp)
or else Is_Private_Overriding
or else Is_Internal_Name (Chars (Parent_Subp))
- or else Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ or else (Is_Controlled (Parent_Type)
+ and then Nam_In (Chars (Parent_Subp), Name_Initialize,
+ Name_Adjust,
+ Name_Finalize))
then
Set_Derived_Name;
if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (T) > 1)
+ and then not Restricted_Profile
and then
(Has_Entries (T)
or else Has_Interrupt_Handler (T)
end;
else
+ -- If the function returns the limited view of type, the call must
+ -- appear in a context in which the non-limited view is available.
+ -- As is done in Try_Object_Operation, use the available view to
+ -- prevent back-end confusion.
+
+ if From_Limited_With (Etype (Nam)) then
+ Set_Etype (Nam, Available_View (Etype (Nam)));
+ end if;
+
Set_Etype (N, Etype (Nam));
end if;
projects / gcc.git / commitdiff