s-geveop$(objext) \
s-gloloc$(objext) \
s-htable$(objext) \
+ s-imad32$(objext) \
+ s-imad64$(objext) \
+ s-imagea$(objext) \
s-imageb$(objext) \
s-imaged$(objext) \
s-imagef$(objext) \
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;
function Build_Set_Size_Function
(Loc : Source_Ptr;
- Tag_Node : Node_Id;
- Size_Func : Entity_Id) return Node_Id is
+ Typ : Entity_Id;
+ Size_Func : Entity_Id) return Node_Id
+ is
+ F_Nod : constant Node_Id := Freeze_Node (Typ);
+
+ Act : Node_Id;
+
begin
pragma Assert (Chars (Size_Func) = Name_uSize
- and then RTE_Record_Component_Available (RE_Size_Func));
+ and then RTE_Record_Component_Available (RE_Size_Func)
+ and then Present (F_Nod));
+
+ -- Find the declaration of the TSD object in the freeze actions
+
+ Act := First (Actions (F_Nod));
+ while Present (Act) loop
+ if Nkind (Act) = N_Object_Declaration
+ and then Nkind (Object_Definition (Act)) = N_Subtype_Indication
+ and then Is_Entity_Name (Subtype_Mark (Object_Definition (Act)))
+ and then Is_RTE (Entity (Subtype_Mark (Object_Definition (Act))),
+ RE_Type_Specific_Data)
+ then
+ exit;
+ end if;
+
+ Next (Act);
+ end loop;
+
+ pragma Assert (Present (Act));
+
+ -- Generate:
+ -- TSD.Size_Func := Size_Ptr!(Size_Func'Unrestricted_Access);
+
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Build_TSD (Loc,
- Unchecked_Convert_To (RTE (RE_Address), Tag_Node))),
+ Prefix =>
+ New_Occurrence_Of (Defining_Identifier (Act), Loc),
Selector_Name =>
New_Occurrence_Of
(RTE_Record_Component (RE_Size_Func), Loc)),
function Build_Set_Size_Function
(Loc : Source_Ptr;
- Tag_Node : Node_Id;
+ Typ : Entity_Id;
Size_Func : Entity_Id) return Node_Id;
- -- Build code that saves in the TSD the address of the function
+ -- Build code that saves in the TSD of Typ the address of the function
-- calculating _size of the object.
function Build_Set_Static_Offset_To_Top
with Strub; use Strub;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
package body Exp_Disp is
Chars => New_External_Name (Tname, 'A'));
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (First_Subtype (Typ));
- Str1_Id : String_Id;
- Str2_Id : String_Id;
+
+ Address_Image : RE_Id;
+ Str1_Id : String_Id;
+ Str2_Id : String_Id;
begin
-- Generate:
-- Exname : constant String :=
-- Str1 & Address_Image (Tag) & Str2;
- if RTE_Available (RE_Address_Image) then
+ -- We use Address_Image64 for Morello because Integer_Address
+ -- is 64-bit large even though Address is 128-bit large.
+
+ case System_Address_Size is
+ when 32 => Address_Image := RE_Address_Image32;
+ when 64 => Address_Image := RE_Address_Image64;
+ when 128 => Address_Image := RE_Address_Image64;
+ when others => raise Program_Error;
+ end case;
+
+ if RTE_Available (Address_Image) then
Append_To (Result,
Make_Object_Declaration (Loc,
Defining_Identifier => Exname,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
- (RTE (RE_Address_Image), Loc),
+ (RTE (Address_Image), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (DT_Ptr, Loc)))),
if Chars (Prim) = Name_uSize
and then RTE_Record_Component_Available (RE_Size_Func)
then
- DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
- Append_To (L,
- Build_Set_Size_Function (Loc,
- Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
- Size_Func => Prim));
+ Append_To (L, Build_Set_Size_Function (Loc, Tag_Typ, Prim));
end if;
else
ada/libgnat/s-excmac.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
+ ada/libgnat/s-imad32.o \
+ ada/libgnat/s-imad64.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
type Prim_Ptr is access procedure;
type Address_Array is array (Positive range <>) of Prim_Ptr;
+ pragma Suppress_Initialization (Address_Array);
subtype Dispatch_Table is Address_Array (1 .. 1);
-- Used by GDB to identify the _tags and traverse the run-time structure
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
+with System.Img_Address_32;
+with System.Img_Address_64;
function System.Address_Image (A : Address) return String is
-
- Result : String (1 .. 2 * Address'Size / Storage_Unit);
-
- type Byte is mod 2 ** 8;
- for Byte'Size use 8;
-
- Hexdigs :
- constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF";
-
- type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte;
- for Bytes'Size use Address'Size;
-
- function To_Bytes is new Ada.Unchecked_Conversion (Address, Bytes);
-
- Byte_Sequence : constant Bytes := To_Bytes (A);
-
- LE : constant := Standard'Default_Bit_Order;
- BE : constant := 1 - LE;
- -- Set to 1/0 for True/False for Little-Endian/Big-Endian
-
- Start : constant Natural := BE * (1) + LE * (Bytes'Length);
- Incr : constant Integer := BE * (1) + LE * (-1);
- -- Start and increment for accessing characters of address string
-
- Ptr : Natural;
- -- Scan address string
-
begin
- Ptr := Start;
- for N in Bytes'Range loop
- Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16);
- Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16);
- Ptr := Ptr + Incr;
- end loop;
-
- return Result;
-
+ -- We use Address_Image64 for Morello because Integer_Address is 64-bit
+ -- large even though Address is 128-bit large.
+
+ case Address'Size is
+ when 32 => return String (System.Img_Address_32.Address_Image32 (A));
+ when 64 => return String (System.Img_Address_64.Address_Image64 (A));
+ when 128 => return String (System.Img_Address_64.Address_Image64 (A));
+ when others => raise Program_Error;
+ end case;
end System.Address_Image;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ A D D R E S S _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with System.Image_A;
+
+package System.Img_Address_32 is
+ pragma Pure;
+
+ package Impl is new Image_A (Interfaces.Unsigned_32);
+
+ function Address_Image32 (A : Address) return Impl.Address_String
+ renames Impl.Address_Image;
+
+end System.Img_Address_32;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ A D D R E S S _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+with System.Image_A;
+
+package System.Img_Address_64 is
+ pragma Pure;
+
+ package Impl is new Image_A (Interfaces.Unsigned_64);
+
+ function Address_Image64 (A : Address) return Impl.Address_String
+ renames Impl.Address_Image;
+
+end System.Img_Address_64;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ A --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2024, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body System.Image_A is
+
+ -------------------
+ -- Address_Image --
+ -------------------
+
+ function Address_Image (A : Address) return Address_String is
+ Result : Address_String;
+
+ type Byte is mod 2 ** 8;
+ for Byte'Size use 8;
+
+ Hexdigs :
+ constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF";
+
+ type Bytes is array (1 .. Uns'Size / Storage_Unit) of Byte;
+
+ function To_Bytes is new Ada.Unchecked_Conversion (Uns, Bytes);
+
+ Byte_Sequence : constant Bytes := To_Bytes (Uns (Integer_Address (A)));
+
+ LE : constant := Standard'Default_Bit_Order;
+ BE : constant := 1 - LE;
+ -- Set to 1/0 for True/False for Little-Endian/Big-Endian
+
+ Start : constant Natural := BE * (1) + LE * (Bytes'Length);
+ Incr : constant Integer := BE * (1) + LE * (-1);
+ -- Start and increment for accessing characters of address string
+
+ Ptr : Natural;
+ -- Scan address string
+
+ begin
+ Ptr := Start;
+
+ for N in Bytes'Range loop
+ Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16);
+ Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16);
+ Ptr := Ptr + Incr;
+ end loop;
+
+ return Result;
+ end Address_Image;
+
+end System.Image_A;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M A G E _ A --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2024, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+generic
+
+ type Uns is mod <>;
+
+package System.Image_A is
+ pragma Pure;
+
+ subtype Address_String is String (1 .. 2 * Uns'Size / Storage_Unit);
+
+ function Address_Image (A : Address) return Address_String;
+ -- Return a string made up of hexadecimal digits with upper case letters
+ -- and without prefix representing the (lower part of) address A.
+
+end System.Image_A;
range Interfaces_C_Strings .. Interfaces_C_Strings;
subtype System_Descendant is RTU_Id
- range System_Address_Image .. System_Tasking_Stages;
+ range System_Address_To_Access_Conversions .. System_Tasking_Stages;
subtype System_Atomic_Operations_Descendant is System_Descendant
range System_Atomic_Operations_Test_And_Set ..
-- Children of System
- System_Address_Image,
System_Address_To_Access_Conversions,
System_Arith_64,
System_Arith_128,
System_Fore_Fixed_64,
System_Fore_Fixed_128,
System_Fore_Real,
+ System_Img_Address_32,
+ System_Img_Address_64,
System_Img_Bool,
System_Img_Char,
System_Img_Decimal_32,
RE_Null_Address, -- System
RE_Priority, -- System
- RE_Address_Image, -- System.Address_Image
+ RE_Address_Image32, -- System.Img_Address_32
+ RE_Address_Image64, -- System.Img_Address_64
RE_Add_With_Ovflo_Check64, -- System.Arith_64
RE_Double_Divide64, -- System.Arith_64
RE_Null_Address => System,
RE_Priority => System,
- RE_Address_Image => System_Address_Image,
+ RE_Address_Image32 => System_Img_Address_32,
+ RE_Address_Image64 => System_Img_Address_64,
RE_Add_With_Ovflo_Check64 => System_Arith_64,
RE_Double_Divide64 => System_Arith_64,
git://gcc.gnu.org / gcc.git / commitdiff