-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
-- Export pragma).
-- Can_Never_Be_Null (Flag38)
--- This flag is defined in all entities, but can only be set in an object
--- which can never have a null value. Set for constant access values
--- initialized to a non-null value. This is also set for all access
--- parameters in Ada 83 and Ada 95 modes, and for access parameters
--- that explicitly exclude null in Ada 2005.
+-- This flag is defined in all entities. It is set in an object which can
+-- never have a null value. Set for constant access values initialized to
+-- a non-null value. This is also set for all access parameters in Ada 83
+-- and Ada 95 modes, and for access parameters that explicitly exclude
+-- exclude null in Ada 2005 mode.
--
-- This is used to avoid unnecessary resetting of the Is_Known_Non_Null
-- flag for such entities. In Ada 2005 mode, this is also used when
-- determining subtype conformance of subprogram profiles to ensure
-- that two formals have the same null-exclusion status.
--
--- ??? This is also set on some access types, eg the Etype of the
--- anonymous access type of a controlling formal.
+-- This is also set on some access types, e.g. the Etype of the anonymous
+-- access type of a controlling formal.
-- Can_Use_Internal_Rep (Flag229) [base type only]
-- Defined in Access_Subprogram_Kind nodes. This flag is set by the
-- Defined in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
+---------------------------
+-- Renaming and aliasing --
+---------------------------
+
+-- Several entity attributes relate to renaming constructs, and to the use
+-- of different names to refer to the same entity. Here is a summary of
+-- these constructs and their prefered uses.
+
+-- There are three related attributes:
+--
+-- Renamed_Entity
+-- Renamed_Object
+-- Alias
+--
+-- They all overlap because they are supposed to apply to different entity
+-- kinds, and are semantically related, but they have the following intended
+-- uses:
+--
+-- a) Renamed_Entity appplies to entities in renaming declarations that rename
+-- an entity, so the value of the attribute IS an entity. This applies to
+-- generic renamings, package renamings, exception renamings, and subprograms
+-- renamings that rename a subprogram (rather than an attribute, an entry, a
+-- protected operation, etc).
+--
+-- b) Alias applies to overloadable entities, and the value is an overloadable
+-- entity. so this is a subset of the previous one. We use the term Alias to
+-- cover both renamings and inherited operations, because both cases are
+-- handled in the same way when expanding a call. namely the Alias of a given
+-- subprogram is the subprogram that will actually be called.
+
+-- Both a) and b) are set transitively, so that in fact it is not necessary to
+-- traverse chains of renamings when looking for the original entity: it's
+-- there in one step (this is done when analyzing renaming declarations other
+-- than object renamings in sem_ch8).
+
+-- c) Renamed_Object applies to constants and variables. Given that the name
+-- in an object renaming declaration is not necessarily an entity name, the
+-- value of the attribute is the tree for that name, eg AR (1).Comp. The case
+-- when that name is in fact an entity is not handled specially. This is why
+-- in a few cases we need to use a loop to trace a chain of object renamings
+-- where all of them happen to be entities. So:
+
+-- X : integer;
+-- Y : integer renames X; -- renamed object is the identifier X
+-- Z : integer renames Y; -- renamed object is the identifier Y
+
+-- The front-end does not store explicitly the fact that Z renames X.
+
--------------------------------------
-- Delayed Freezing and Elaboration --
--------------------------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
------------------------------------------------------------------------------
with Interfaces; use Interfaces;
+
with Ada.Unchecked_Conversion;
package body System.Arith_64 is
-- Local Subprograms --
-----------------------
- function "+" (A, B : Uns32) return Uns64;
- function "+" (A : Uns64; B : Uns32) return Uns64;
+ function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B));
+ function "+" (A : Uns64; B : Uns32) return Uns64 is
+ (A + Uns64 (B));
pragma Inline ("+");
-- Length doubling additions
- function "*" (A, B : Uns32) return Uns64;
+ function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B));
pragma Inline ("*");
-- Length doubling multiplication
- function "/" (A : Uns64; B : Uns32) return Uns64;
+ function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B));
pragma Inline ("/");
-- Length doubling division
- function "rem" (A : Uns64; B : Uns32) return Uns64;
- pragma Inline ("rem");
- -- Length doubling remainder
-
- function "&" (Hi, Lo : Uns32) return Uns64;
+ function "&" (Hi, Lo : Uns32) return Uns64 is
+ (Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo));
pragma Inline ("&");
-- Concatenate hi, lo values to form 64-bit result
+ function "abs" (X : Int64) return Uns64 is
+ (if X = Int64'First then 2**63 else Uns64 (Int64'(abs X)));
+ -- Convert absolute value of X to unsigned. Note that we can't just use
+ -- the expression of the Else, because it overflows for X = Int64'First.
+
+ function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B));
+ pragma Inline ("rem");
+ -- Length doubling remainder
+
function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean;
-- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3
- function Lo (A : Uns64) return Uns32;
+ function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#));
pragma Inline (Lo);
-- Low order half of 64-bit value
- function Hi (A : Uns64) return Uns32;
+ function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
pragma Inline (Hi);
-- High order half of 64-bit value
pragma No_Return (Raise_Error);
-- Raise constraint error with appropriate message
- ---------
- -- "&" --
- ---------
-
- function "&" (Hi, Lo : Uns32) return Uns64 is
- begin
- return Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo);
- end "&";
-
- ---------
- -- "*" --
- ---------
-
- function "*" (A, B : Uns32) return Uns64 is
- begin
- return Uns64 (A) * Uns64 (B);
- end "*";
-
- ---------
- -- "+" --
- ---------
-
- function "+" (A, B : Uns32) return Uns64 is
- begin
- return Uns64 (A) + Uns64 (B);
- end "+";
-
- function "+" (A : Uns64; B : Uns32) return Uns64 is
- begin
- return A + Uns64 (B);
- end "+";
-
- ---------
- -- "/" --
- ---------
-
- function "/" (A : Uns64; B : Uns32) return Uns64 is
- begin
- return A / Uns64 (B);
- end "/";
-
- -----------
- -- "rem" --
- -----------
-
- function "rem" (A : Uns64; B : Uns32) return Uns64 is
- begin
- return A rem Uns64 (B);
- end "rem";
-
--------------------------
-- Add_With_Ovflo_Check --
--------------------------
Q, R : out Int64;
Round : Boolean)
is
- Xu : constant Uns64 := To_Uns (abs X);
- Yu : constant Uns64 := To_Uns (abs Y);
+ Xu : constant Uns64 := abs X;
+ Yu : constant Uns64 := abs Y;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
- Zu : constant Uns64 := To_Uns (abs Z);
+ Zu : constant Uns64 := abs Z;
Zhi : constant Uns32 := Hi (Zu);
Zlo : constant Uns32 := Lo (Zu);
end if;
end Double_Divide;
- --------
- -- Hi --
- --------
-
- function Hi (A : Uns64) return Uns32 is
- begin
- return Uns32 (Shift_Right (A, 32));
- end Hi;
-
---------
-- Le3 --
---------
end if;
end Le3;
- --------
- -- Lo --
- --------
-
- function Lo (A : Uns64) return Uns32 is
- begin
- return Uns32 (A and 16#FFFF_FFFF#);
- end Lo;
-
-------------------------------
-- Multiply_With_Ovflo_Check --
-------------------------------
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is
- Xu : constant Uns64 := To_Uns (abs X);
+ Xu : constant Uns64 := abs X;
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
- Yu : constant Uns64 := To_Uns (abs Y);
+ Yu : constant Uns64 := abs Y;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
Q, R : out Int64;
Round : Boolean)
is
- Xu : constant Uns64 := To_Uns (abs X);
+ Xu : constant Uns64 := abs X;
Xhi : constant Uns32 := Hi (Xu);
Xlo : constant Uns32 := Lo (Xu);
- Yu : constant Uns64 := To_Uns (abs Y);
+ Yu : constant Uns64 := abs Y;
Yhi : constant Uns32 := Hi (Yu);
Ylo : constant Uns32 := Lo (Yu);
- Zu : Uns64 := To_Uns (abs Z);
+ Zu : Uns64 := abs Z;
Zhi : Uns32 := Hi (Zu);
Zlo : Uns32 := Lo (Zu);
projects / thirdparty / gcc.git / commitdiff
