+2017-12-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Use the SLOC of the
+ iteration scheme throughout, except for the new loop statement(s).
+
+2017-12-05 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Gen_Assign): Do not analyze the expressionn of the
+ assignment if it is part of an Iterated_Component_Association: the
+ analysis needs to take place once the loop structure is analyzed and
+ the loop parameter made visible, because references to it typically
+ appear in the corresponding expression. This is necessary if the
+ expression is an aggregate, because previous pre-analysis of the
+ expression does not handle nested aggregates properly.
+
+2017-12-05 Bob Duff <duff@adacore.com>
+
+ * sem_res.adb (Resolve_Allocator): Avoid coextension processing for an
+ allocator that is the expansion of a build-in-place function call.
+
+2017-12-05 Olivier Hainque <hainque@adacore.com>
+
+libgnat/
+ * s-trasym__dwarf.adb (spec of Module_Name.Get): Instead of
+ possibly adjusting the lookup address by a load address, expect
+ a extra argument through which the load address can be conveyed
+ separately.
+ (Multi_Module_Symbolic_Traceback): Adjust accordingly. Pass the
+ retrieved load address to Init_Module.
+ * s-tsmona__linux.adb (Get): Honor the new interface.
+ * s-tsmona__mingw.adb (Get): Likewise.
+ * s-dwalin.ads: Adjust comments to be explicit about which
+ addresses are from module info and which are run-time addresses,
+ offsetted by the module load address.
+ * s-dwalin.adb (Set_Load_Address): Simply set C.Load_Slide.
+ Do not alter the module Low and High (relative) addresses.
+ (Is_Inside): Improve documentation regarding the kinds of addresses
+ at hand and correct the test.
+ (Symbolic_Traceback): Use separate variables with explicit names
+ for the address in traceback (run-time value) and the address to
+ lookup within the shared object (module-relative). Adjust the
+ computation of address passed to Symbolic_Address for symbolization.
+
2017-12-05 Arnaud Charlet <charlet@adacore.com>
* opt.ads (Expand_Nonbinary_Modular_Ops): New flag.
-- the analysis of non-array aggregates now in order to get the
-- value of Expansion_Delayed flag for the inner aggregate ???
- if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
+ -- In the case of an iterated component association, the analysis
+ -- of the generated loop will analyze the expression in the
+ -- proper context, in which the loop parameter is visible.
+
+ if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ)
+ and then
+ Nkind (Parent (Expr_Q)) /= N_Iterated_Component_Association
+ then
Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
Expr : Node_Id;
begin
+ if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then
+ return False;
+ end if;
+
if Present (Expressions (Aggr)) then
Expr := First (Expressions (Aggr));
while Present (Expr) loop
Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node));
Array_Dim : constant Pos := Number_Dimensions (Array_Typ);
Id : constant Entity_Id := Defining_Identifier (I_Spec);
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (Isc);
Stats : constant List_Id := Statements (N);
Core_Loop : Node_Id;
Dim1 : Int;
end if;
Core_Loop :=
- Make_Loop_Statement (Loc,
+ Make_Loop_Statement (Sloc (N),
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
-- end loop;
Core_Loop :=
- Make_Loop_Statement (Loc,
+ Make_Loop_Statement (Sloc (N),
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is
begin
- return Addr >= C.Low and Addr <= C.High;
+ return (Addr >= To_Address (To_Integer (C.Low) + C.Load_Slide)
+ and Addr <= To_Address (To_Integer (C.High) + C.Load_Slide));
end Is_Inside;
---------
procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is
begin
- if Addr = Null_Address then
- return;
- else
- C.Load_Slide :=
- To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all));
-
- C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide);
- C.High := To_Address (To_Integer (C.High) + C.Load_Slide);
- end if;
+ C.Load_Slide := To_Integer (Addr);
end Set_Load_Address;
------------------
Res : in out System.Bounded_Strings.Bounded_String)
is
use Ada.Characters.Handling;
- C : Dwarf_Context := Cin;
- Addr : Address;
+ C : Dwarf_Context := Cin;
+
+ Addr_In_Traceback : Address;
+ Addr_To_Lookup : Address;
Dir_Name : Str_Access;
File_Name : Str_Access;
-- If the buffer is full, no need to do any useless work
exit when Is_Full (Res);
- Addr := PC_For (Traceback (J));
+ Addr_In_Traceback := PC_For (Traceback (J));
+
+ Addr_To_Lookup := To_Address
+ (To_Integer (Addr_In_Traceback) - C.Load_Slide);
+
Symbolic_Address
(C,
- To_Address (To_Integer (Addr) + C.Load_Slide),
+ Addr_To_Lookup,
Dir_Name,
File_Name,
Subprg_Name,
if Suppress_Hex then
Append (Res, "...");
else
- Append_Address (Res, Addr);
+ Append_Address (Res, Addr_In_Traceback);
end if;
if Subprg_Name.Len > 0 then
function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean;
pragma Inline (Is_Inside);
- -- Return true iff Addr is within the module
+ -- Return true iff a run-time address Addr is within the module
function Low (C : Dwarf_Context) return Address;
pragma Inline (Low);
- -- Return the lowest address of C
+ -- Return the lowest address of C, from the module object file
procedure Dump (C : in out Dwarf_Context);
-- Dump each row found in the object's .debug_lines section to standard out
type Dwarf_Context (In_Exception : Boolean := False) is record
Load_Slide : System.Storage_Elements.Integer_Address := 0;
Low, High : Address;
- -- Bounds of the module
+ -- Bounds of the module, per the module object file
Obj : SOR.Object_File_Access;
-- The object file containing dwarf sections
procedure Build_Cache_For_All_Modules;
-- Create the cache for all current modules
- function Get (Addr : access System.Address) return String;
- -- Returns the module name for the given address, Addr may be updated
- -- to be set relative to a shared library. This depends on the platform.
- -- Returns an empty string for the main executable.
+ function Get (Addr : System.Address;
+ Load_Addr : access System.Address) return String;
+ -- Returns the module name for the given address Addr, or an empty
+ -- string for the main executable. Load_Addr is set to the shared
+ -- library load address if this information is available, or to
+ -- System.Null_Address otherwise.
function Is_Supported return Boolean;
pragma Inline (Is_Supported);
-- Otherwise, try a shared library
declare
- Addr : aliased System.Address := Traceback (F);
- M_Name : constant String := Module_Name.Get (Addr'Access);
+ Load_Addr : aliased System.Address;
+ M_Name : constant String :=
+ Module_Name.Get (Addr => Traceback (F),
+ Load_Addr => Load_Addr'Access);
Module : Module_Cache;
Success : Boolean;
begin
- Init_Module (Module, Success, M_Name, System.Null_Address);
+ Init_Module (Module, Success, M_Name, Load_Addr);
if Success then
Multi_Module_Symbolic_Traceback
(Traceback,
-- This is the GNU/Linux specific version of this package
with Interfaces.C; use Interfaces.C;
-with System.Address_Operations; use System.Address_Operations;
-
separate (System.Traceback.Symbolic)
package body Module_Name is
-- Get --
---------
- function Get (Addr : access System.Address) return String is
+ function Get (Addr : System.Address;
+ Load_Addr : access System.Address)
+ return String
+ is
-- Dl_info record for Linux, used to get sym reloc offset
info : aliased Dl_info;
begin
- if dladdr (Addr.all, info'Access) /= 0 then
+ Load_Addr.all := System.Null_Address;
+
+ if dladdr (Addr, info'Access) /= 0 then
-- If we have a shared library we need to adjust the address to
-- be relative to the base address of the library.
if Is_Shared_Lib (info.dli_fbase) then
- Addr.all := SubA (Addr.all, info.dli_fbase);
+ Load_Addr.all := info.dli_fbase;
end if;
return Value (info.dli_fname);
-- Get --
---------
- function Get (Addr : access System.Address) return String is
+ function Get (Addr : System.Address;
+ Load_Addr : access System.Address)
+ return String
+ is
Res : DWORD;
hModule : aliased HANDLE;
Path : String (1 .. 1_024);
begin
+ Load_Addr.all := System.Null_Address;
+
if GetModuleHandleEx
(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- Addr.all,
+ Addr,
hModule'Access) = Win32.TRUE
then
Res := GetModuleFileName (hModule, Path'Address, Path'Length);
-- statement.
if Nkind (N) = N_Allocator then
+ -- Avoid coextension processing for an allocator that is the
+ -- expansion of a build-in-place function call.
+
+ if Nkind (Original_Node (N)) = N_Allocator
+ and then Nkind (Expression (Original_Node (N))) =
+ N_Qualified_Expression
+ and then Nkind (Expression (Expression (Original_Node (N)))) =
+ N_Function_Call
+ and then Is_Expanded_Build_In_Place_Call
+ (Expression (Expression (Original_Node (N))))
+ then
+ null; -- b-i-p function call case
- -- An anonymous access discriminant is the definition of a
- -- coextension.
+ else
+ -- An anonymous access discriminant is the definition of a
+ -- coextension.
- if Ekind (Typ) = E_Anonymous_Access_Type
- and then Nkind (Associated_Node_For_Itype (Typ)) =
- N_Discriminant_Specification
- then
- declare
- Discr : constant Entity_Id :=
- Defining_Identifier (Associated_Node_For_Itype (Typ));
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Nkind (Associated_Node_For_Itype (Typ)) =
+ N_Discriminant_Specification
+ then
+ declare
+ Discr : constant Entity_Id :=
+ Defining_Identifier (Associated_Node_For_Itype (Typ));
- begin
- Check_Restriction (No_Coextensions, N);
+ begin
+ Check_Restriction (No_Coextensions, N);
- -- Ada 2012 AI05-0052: If the designated type of the allocator
- -- is limited, then the allocator shall not be used to define
- -- the value of an access discriminant unless the discriminated
- -- type is immutably limited.
+ -- Ada 2012 AI05-0052: If the designated type of the
+ -- allocator is limited, then the allocator shall not
+ -- be used to define the value of an access discriminant
+ -- unless the discriminated type is immutably limited.
- if Ada_Version >= Ada_2012
- and then Is_Limited_Type (Desig_T)
- and then not Is_Limited_View (Scope (Discr))
- then
- Error_Msg_N
- ("only immutably limited types can have anonymous "
- & "access discriminants designating a limited type", N);
- end if;
- end;
+ if Ada_Version >= Ada_2012
+ and then Is_Limited_Type (Desig_T)
+ and then not Is_Limited_View (Scope (Discr))
+ then
+ Error_Msg_N
+ ("only immutably limited types can have anonymous "
+ & "access discriminants designating a limited type",
+ N);
+ end if;
+ end;
- -- Avoid marking an allocator as a dynamic coextension if it is
- -- within a static construct.
+ -- Avoid marking an allocator as a dynamic coextension if it is
+ -- within a static construct.
- if not Is_Static_Coextension (N) then
- Set_Is_Dynamic_Coextension (N);
+ if not Is_Static_Coextension (N) then
+ Set_Is_Dynamic_Coextension (N);
- -- ??? We currently do not handle finalization and deallocation
- -- of coextensions properly so let's at least warn the user
- -- about it.
+ -- ??? We currently do not handle finalization and
+ -- deallocation of coextensions properly so let's at
+ -- least warn the user about it.
- if Is_Controlled (Desig_T) then
- Error_Msg_N
- ("??coextension will not be finalized when its "
- & "associated owner is deallocated or finalized", N);
- else
- Error_Msg_N
- ("??coextension will not be deallocated when its "
- & "associated owner is deallocated", N);
+ if Is_Controlled (Desig_T) then
+ Error_Msg_N
+ ("??coextension will not be finalized when its "
+ & "associated owner is deallocated or finalized", N);
+ else
+ Error_Msg_N
+ ("??coextension will not be deallocated when its "
+ & "associated owner is deallocated", N);
+ end if;
end if;
- end if;
- -- Cleanup for potential static coextensions
+ -- Cleanup for potential static coextensions
- else
- Set_Is_Dynamic_Coextension (N, False);
- Set_Is_Static_Coextension (N, False);
+ else
+ Set_Is_Dynamic_Coextension (N, False);
+ Set_Is_Static_Coextension (N, False);
- -- ??? It seems we also do not properly finalize anonymous
- -- access-to-controlled objects within their declared scope and
- -- instead finalize them with their associated unit. Warn the
- -- user about it here.
+ -- ??? It seems we also do not properly finalize anonymous
+ -- access-to-controlled objects within their declared scope and
+ -- instead finalize them with their associated unit. Warn the
+ -- user about it here.
- if Ekind (Typ) = E_Anonymous_Access_Type
- and then Is_Controlled_Active (Desig_T)
- then
- Error_Msg_N
- ("??object designated by anonymous access object might not "
- & "be finalized until its enclosing library unit goes out "
- & "of scope", N);
- Error_Msg_N ("\use named access type instead", N);
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Is_Controlled_Active (Desig_T)
+ then
+ Error_Msg_N
+ ("??object designated by anonymous access object might "
+ & "not be finalized until its enclosing library unit "
+ & "goes out of scope", N);
+ Error_Msg_N ("\use named access type instead", N);
+ end if;
end if;
end if;
end if;
projects / gcc.git / commitdiff