* s-valllu.adb, a-tiinau.adb, a-timoau.adb, a-ztinau.adb, a-ztmoau.adb,
s-valuns.adb, s-valrea.adb, a-wtflau.adb, a-tiflau.adb, a-ztflau.adb,
a-wtinau.adb, a-wtmoau.adb: Document recognition of : in place of #.
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): For aspects
that specify stream subprograms, if the prefix is a class-wide
type then the generated attribute definition clause must apply
to the same class-wide type.
(Default_Iterator): An iterator defined by an aspect of some
container type T must have a first parameter of type T, T'class,
or an access to such (from code reading RM 5.5.1 (2/3)).
2015-01-06 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb: Minor: complete previous change.
2015-01-06 Olivier Hainque <hainque@adacore.com>
* set_targ.ads (C_Type_For): New function. Return the name of
a C type supported by the back-end and suitable as a basis to
construct the standard Ada floating point type identified by
the T parameter. This is used as a common ground to feed both
ttypes values and the GNAT tree nodes for the standard floating
point types.
* set_targ.adb (Long_Double_Index): The index at which "long
double" gets registered in the FPT_Mode_Table. This is useful to
know whether we have a "long double" available at all and get at
it's characteristics without having to search the FPT_Mode_Table
when we need to decide which C type should be used as the
basis for Long_Long_Float in Ada.
(Register_Float_Type): Fill Long_Double_Index.
(FPT_Mode_Index_For): New function. Return the index in
FPT_Mode_Table that designates the entry corresponding to the
provided C type name.
(FPT_Mode_Index_For): New function. Return the index in
FPT_Mode_Table that designates the entry for a back-end type
suitable as a basis to construct the standard Ada floating point
type identified by the input T parameter.
(elaboration code): Register_Back_End_Types unconditionally,
so C_Type_For can operate regardless of -gnateT. Do it
early so we can query it for the floating point sizes, via
FPT_Mode_Index_For. Initialize Float_Size, Double_Size and
Long_Double_Size from the FPT_Mode_Table, as cstand will do.
* cstand.adb (Create_Float_Types): Use C_Type_For to determine
which C type should be used as the basis for the construction
of the Standard Ada floating point types.
* get_targ.ads (Get_Float_Size, Get_Double_Size,
Get_Long_Double_Size): Remove.
* get_targ.adb: Likewise.
2015-01-06 Thomas Quinot <quinot@adacore.com>
* sem_cat.adb (In_RCI_Declaration): Remove unnecessary
parameter and rename to...
(In_RCI_Visible_Declarations): Fix handling of private part of nested
package.
(Validate_RCI_Subprogram_Declaration): Reject illegal function
returning anonymous access in RCI unit.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219233
138bc75d-0d04-0410-961f-
82ee72b054a4
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * s-valllu.adb, a-tiinau.adb, a-timoau.adb, a-ztinau.adb, a-ztmoau.adb,
+ s-valuns.adb, s-valrea.adb, a-wtflau.adb, a-tiflau.adb, a-ztflau.adb,
+ a-wtinau.adb, a-wtmoau.adb: Document recognition of : in place of #.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): For aspects
+ that specify stream subprograms, if the prefix is a class-wide
+ type then the generated attribute definition clause must apply
+ to the same class-wide type.
+ (Default_Iterator): An iterator defined by an aspect of some
+ container type T must have a first parameter of type T, T'class,
+ or an access to such (from code reading RM 5.5.1 (2/3)).
+
+2015-01-06 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: Minor: complete previous change.
+
+2015-01-06 Olivier Hainque <hainque@adacore.com>
+
+ * set_targ.ads (C_Type_For): New function. Return the name of
+ a C type supported by the back-end and suitable as a basis to
+ construct the standard Ada floating point type identified by
+ the T parameter. This is used as a common ground to feed both
+ ttypes values and the GNAT tree nodes for the standard floating
+ point types.
+ * set_targ.adb (Long_Double_Index): The index at which "long
+ double" gets registered in the FPT_Mode_Table. This is useful to
+ know whether we have a "long double" available at all and get at
+ it's characteristics without having to search the FPT_Mode_Table
+ when we need to decide which C type should be used as the
+ basis for Long_Long_Float in Ada.
+ (Register_Float_Type): Fill Long_Double_Index.
+ (FPT_Mode_Index_For): New function. Return the index in
+ FPT_Mode_Table that designates the entry corresponding to the
+ provided C type name.
+ (FPT_Mode_Index_For): New function. Return the index in
+ FPT_Mode_Table that designates the entry for a back-end type
+ suitable as a basis to construct the standard Ada floating point
+ type identified by the input T parameter.
+ (elaboration code): Register_Back_End_Types unconditionally,
+ so C_Type_For can operate regardless of -gnateT. Do it
+ early so we can query it for the floating point sizes, via
+ FPT_Mode_Index_For. Initialize Float_Size, Double_Size and
+ Long_Double_Size from the FPT_Mode_Table, as cstand will do.
+ * cstand.adb (Create_Float_Types): Use C_Type_For to determine
+ which C type should be used as the basis for the construction
+ of the Standard Ada floating point types.
+ * get_targ.ads (Get_Float_Size, Get_Double_Size,
+ Get_Long_Double_Size): Remove.
+ * get_targ.adb: Likewise.
+
+2015-01-06 Thomas Quinot <quinot@adacore.com>
+
+ * sem_cat.adb (In_RCI_Declaration): Remove unnecessary
+ parameter and rename to...
+ (In_RCI_Visible_Declarations): Fix handling of private part of nested
+ package.
+ (Validate_RCI_Subprogram_Declaration): Reject illegal function
+ returning anonymous access in RCI unit.
+
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (New_Overloaded_Entity): In GNATprove mode, a
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
return;
end if;
- -- Based cases
+ -- Based cases. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
if Loaded then
- -- Deal with based literal (note : is ok replacement for #)
+ -- Deal with based literal. We recognize either the standard '#' or
+ -- the allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
return;
end if;
- -- Based cases
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
return;
end if;
- -- Based cases
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, 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- --
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
+
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
+
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
Copy_Float_Type
(Standard_Short_Float,
- Find_Back_End_Float_Type ("float"));
+ Find_Back_End_Float_Type (C_Type_For (S_Short_Float)));
Set_Is_Implementation_Defined (Standard_Short_Float);
Copy_Float_Type (Standard_Float, Standard_Short_Float);
- Copy_Float_Type (Standard_Long_Float,
- Find_Back_End_Float_Type ("double"));
+ Copy_Float_Type
+ (Standard_Long_Float,
+ Find_Back_End_Float_Type (C_Type_For (S_Long_Float)));
+
+ Copy_Float_Type
+ (Standard_Long_Long_Float,
+ Find_Back_End_Float_Type (C_Type_For (S_Long_Long_Float)));
+ Set_Is_Implementation_Defined (Standard_Long_Long_Float);
Predefined_Float_Types := New_Elmt_List;
+
Append_Elmt (Standard_Short_Float, Predefined_Float_Types);
Append_Elmt (Standard_Float, Predefined_Float_Types);
Append_Elmt (Standard_Long_Float, Predefined_Float_Types);
-
- -- ??? For now, we don't have a good way to tell the widest float
- -- type with hardware support. Basically, GCC knows the size of that
- -- type, but on x86-64 there often are two or three 128-bit types,
- -- one double extended that has 18 decimal digits, a 128-bit quad
- -- precision type with 33 digits and possibly a 128-bit decimal float
- -- type with 34 digits. As a workaround, we define Long_Long_Float as
- -- C's "long double" if that type exists and has at most 18 digits,
- -- or otherwise the same as Long_Float.
-
- declare
- Max_HW_Digs : constant := 18;
- -- Maximum hardware digits supported
-
- LLF : Entity_Id := Find_Back_End_Float_Type ("long double");
- -- Entity for long double type
-
- begin
- if No (LLF) or else Digits_Value (LLF) > Max_HW_Digs then
- LLF := Standard_Long_Float;
- end if;
-
- Set_Is_Implementation_Defined (Standard_Long_Long_Float);
- Copy_Float_Type (Standard_Long_Long_Float, LLF);
-
- Append_Elmt (Standard_Long_Long_Float, Predefined_Float_Types);
- end;
+ Append_Elmt (Standard_Long_Long_Float, Predefined_Float_Types);
-- Any other back end types are appended at the end of the list of
-- predefined float types, and will only be selected if the none of
return C_Get_Long_Long_Size;
end Get_Long_Long_Size;
- --------------------
- -- Get_Float_Size --
- --------------------
-
- function Get_Float_Size return Pos is
- function C_Get_Float_Size return Pos;
- pragma Import (C, C_Get_Float_Size,
- "get_target_float_size");
- begin
- return C_Get_Float_Size;
- end Get_Float_Size;
-
- ---------------------
- -- Get_Double_Size --
- ---------------------
-
- function Get_Double_Size return Pos is
- function C_Get_Double_Size return Pos;
- pragma Import (C, C_Get_Double_Size,
- "get_target_double_size");
- begin
- return C_Get_Double_Size;
- end Get_Double_Size;
-
- --------------------------
- -- Get_Long_Double_Size --
- --------------------------
-
- function Get_Long_Double_Size return Pos is
- function C_Get_Long_Double_Size return Pos;
- pragma Import (C, C_Get_Long_Double_Size,
- "get_target_long_double_size");
- begin
- return C_Get_Long_Double_Size;
- end Get_Long_Double_Size;
-
----------------------
-- Get_Pointer_Size --
----------------------
function Get_Long_Long_Size return Pos;
-- Size of Standard.Long_Long_Integer
- function Get_Float_Size return Pos;
- -- Size of Standard.Float
-
- function Get_Double_Size return Pos;
- -- Size of Standard.Long_Float
-
- function Get_Long_Double_Size return Pos;
- -- Size of Standard.Long_Long_Float
-
function Get_Pointer_Size return Pos;
-- Size of System.Address
if CodePeer_Mode then
- -- Turn off gnatprove mode (if set via e.g. -gnatd.F), not compatible
- -- with CodePeer mode.
+ -- Turn off gnatprove mode (which can be set via e.g. -gnatd.F), not
+ -- compatible with CodePeer mode.
GNATprove_Mode := False;
+ Debug_Flag_Dot_FF := False;
-- Turn off inlining, confuses CodePeer output and gains nothing
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, 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- --
Ptr.all := P;
- -- Deal with based case
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
- if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
+ if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
Base_Char := Str (P);
P := P + 1;
Base := Uval;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, 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- --
Bad_Value (Str);
end if;
- -- Deal with based case
+ -- Deal with based case. We reognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
- if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
+ if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
declare
Base_Char : constant Character := Str (P);
Digit : Natural;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, 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- --
Ptr.all := P;
- -- Deal with based case
+ -- Deal with based case. We recognize either the standard '#' or the
+ -- allowed alternative replacement ':' (see RM J.2(3)).
- if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
+ if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
Base_Char := Str (P);
P := P + 1;
Base := Uval;
-- Return True if the entity or one of its subcomponents does not support
-- external streaming.
- function In_RCI_Declaration (N : Node_Id) return Boolean;
- -- Determines if a declaration is within the visible part of a Remote
- -- Call Interface compilation unit, for semantic checking purposes only
- -- (returns false within an instance and within the package body).
+ function In_RCI_Visible_Declarations return Boolean;
+ -- Determines if the visible part of a remote call interface library unit
+ -- is being compiled, for semantic checking purposes (returns False within
+ -- an instance and within the package body).
function In_RT_Declaration return Boolean;
-- Determines if current scope is within the declaration of a Remote Types
return Is_Pure (Current_Scope);
end In_Pure_Unit;
- ------------------------
- -- In_RCI_Declaration --
- ------------------------
+ ---------------------------------
+ -- In_RCI_Visible_Declarations --
+ ---------------------------------
- function In_RCI_Declaration (N : Node_Id) return Boolean is
- Unit_Entity : constant Entity_Id := Current_Scope;
+ function In_RCI_Visible_Declarations return Boolean is
+ Unit_Entity : Entity_Id := Current_Scope;
Unit_Kind : constant Node_Kind :=
Nkind (Unit (Cunit (Current_Sem_Unit)));
begin
- -- There are no restrictions on the private part or body
- -- of an RCI unit.
+ -- There are no restrictions on the private part or body of an RCI unit
- return Is_Remote_Call_Interface (Unit_Entity)
+ if not (Is_Remote_Call_Interface (Unit_Entity)
and then Is_Package_Or_Generic_Package (Unit_Entity)
and then Unit_Kind /= N_Package_Body
- and then List_Containing (N) =
- Visible_Declarations (Package_Specification (Unit_Entity))
- and then not In_Package_Body (Unit_Entity)
- and then not In_Instance;
+ and then not In_Instance)
+ then
+ return False;
+ end if;
+
+ while Unit_Entity /= Standard_Standard loop
+ if In_Private_Part (Unit_Entity) then
+ return False;
+ end if;
+
+ Unit_Entity := Scope (Unit_Entity);
+ end loop;
+
+ -- Here if in RCI declaration, and not in private part of any open
+ -- scope.
- -- What about the case of a nested package in the visible part???
- -- This case is missed by the List_Containing check above???
- end In_RCI_Declaration;
+ return True;
+ end In_RCI_Visible_Declarations;
-----------------------
-- In_RT_Declaration --
-- The visible part of an RCI library unit must not contain the
-- declaration of a variable (RM E.1.3(9))
- elsif In_RCI_Declaration (N) then
+ elsif In_RCI_Visible_Declarations then
Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N);
-- The visible part of a Shared Passive library unit must not contain
-- 1. from Analyze_Subprogram_Declaration.
-- 2. from Validate_Object_Declaration (access to subprogram).
- if not (Comes_From_Source (N) and then In_RCI_Declaration (N)) then
+ if not (Comes_From_Source (N) and then In_RCI_Visible_Declarations) then
return;
end if;
-- Report error only if declaration is in source program
- if Comes_From_Source
- (Defining_Entity (Specification (N)))
- then
+ if Comes_From_Source (Id) then
Error_Msg_N
("subprogram in 'R'C'I unit cannot have access parameter",
- Error_Node);
+ Error_Node);
end if;
-- For a limited private type parameter, we check only the private
Next (Param_Spec);
end loop;
+ end if;
- -- No check on return type???
+ if Ekind (Id) = E_Function
+ and then Ekind (Etype (Id)) = E_Anonymous_Access_Type
+ and then Comes_From_Source (Id)
+ then
+ Error_Msg_N
+ ("function in 'R'C'I unit cannot have access result",
+ Error_Node);
end if;
end Validate_RCI_Subprogram_Declaration;
-- the given node is N_Access_To_Object_Definition.
if not Comes_From_Source (T)
- or else (not In_RCI_Declaration (Parent (T))
- and then not In_RT_Declaration)
+ or else (not In_RCI_Visible_Declarations
+ and then not In_RT_Declaration)
then
return;
end if;
if Ekind (T) /= E_General_Access_Type
or else not Is_Class_Wide_Type (Designated_Type (T))
then
- if In_RCI_Declaration (Parent (T)) then
+ if In_RCI_Visible_Declarations then
Error_Msg_N
("error in access type in Remote_Call_Interface unit", T);
else
-- illegal specification of this aspect for a subtype now,
-- to prevent malformed rep_item chains.
- if (A_Id = Aspect_Input or else
- A_Id = Aspect_Output or else
- A_Id = Aspect_Read or else
- A_Id = Aspect_Write)
- and not Is_First_Subtype (E)
+ if A_Id = Aspect_Input or else
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write
then
- Error_Msg_N
- ("local name must be a first subtype", Aspect);
- goto Continue;
+ if not Is_First_Subtype (E) then
+ Error_Msg_N
+ ("local name must be a first subtype", Aspect);
+ goto Continue;
+
+ -- If stream aspect applies to the class-wide type,
+ -- the generated attribute definition applies to the
+ -- class-wide type as well.
+
+ elsif Class_Present (Aspect) then
+ Ent :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Ent,
+ Attribute_Name => Name_Class);
+ end if;
end if;
-- Construct the attribute definition clause
if Base_Type (Typ) = Base_Type (Ent)
or else (Is_Class_Wide_Type (Typ)
and then Typ = Class_Wide_Type (Base_Type (Ent)))
+ or else (Is_Class_Wide_Type (Ent)
+ and then Ent = Class_Wide_Type (Base_Type (Typ)))
then
null;
else
when Attribute_Default_Iterator => Default_Iterator : declare
Func : Entity_Id;
+ Typ : Entity_Id;
begin
if not Is_Tagged_Type (U_Ent) then
Func := Entity (Expr);
end if;
- if No (First_Formal (Func))
- or else Etype (First_Formal (Func)) /= U_Ent
+ -- The type of the first parameter must be T, T'class, or a
+ -- corresponding access type (5.5.1 (8/3)
+
+ if No (First_Formal (Func)) then
+ Typ := Empty;
+ else
+ Typ := Etype (First_Formal (Func));
+ end if;
+
+ if Typ = U_Ent
+ or else Typ = Class_Wide_Type (U_Ent)
+ or else (Is_Access_Type (Typ)
+ and then Designated_Type (Typ) = U_Ent)
+ or else (Is_Access_Type (Typ)
+ and then Designated_Type (Typ) =
+ Class_Wide_Type (U_Ent))
then
+ null;
+
+ else
Error_Msg_NE
("Default Iterator must be a primitive of&", Func, U_Ent);
end if;
if From_Aspect_Specification (N) then
if not Is_Task_Type (U_Ent) then
- Error_Msg_N ("Dispatching_Domain can only be defined" &
- "for task",
- Nam);
+ Error_Msg_N
+ ("Dispatching_Domain can only be defined for task", Nam);
elsif Duplicate_Clause then
null;
-- floating-point type, and Precision, Size and Alignment are the precision
-- size and alignment in bits.
--
- -- So to summarize, the only types that are actually registered have Digs
- -- non-zero, Complex zero (false), and Count zero (not a vector).
+ -- The only types that are actually registered have Digs non-zero, Complex
+ -- zero (false), and Count zero (not a vector). The Long_Double_Index
+ -- variable below is updated to indicate the index at which a "long double"
+ -- type can be found if it gets registered at all.
+
+ Long_Double_Index : Integer := -1;
+ -- Once all the back-end types have been registered, the index in
+ -- FPT_Mode_Table at which "long double" can be found, if anywhere. A
+ -- negative value means that no "long double" has been registered. This
+ -- is useful to know whether we have a "long double" available at all and
+ -- get at it's characteristics without having to search the FPT_Mode_Table
+ -- when we need to decide which C type should be used as the basis for
+ -- Long_Long_Float in Ada.
+
+ function FPT_Mode_Index_For (Name : String) return Natural;
+ -- Return the index in FPT_Mode_Table that designates the entry
+ -- corresponding to the C type named Name. Raise Program_Error if
+ -- there is no such entry.
+
+ function FPT_Mode_Index_For (T : S_Float_Types) return Natural;
+ -- Return the index in FPT_Mode_Table that designates the entry for
+ -- a back-end type suitable as a basis to construct the standard Ada
+ -- floating point type identified by T.
+
+ ----------------
+ -- C_Type_For --
+ ----------------
+
+ function C_Type_For (T : S_Float_Types) return String is
+
+ -- ??? For now, we don't have a good way to tell the widest float
+ -- type with hardware support. Basically, GCC knows the size of that
+ -- type, but on x86-64 there often are two or three 128-bit types,
+ -- one double extended that has 18 decimal digits, a 128-bit quad
+ -- precision type with 33 digits and possibly a 128-bit decimal float
+ -- type with 34 digits. As a workaround, we define Long_Long_Float as
+ -- C's "long double" if that type exists and has at most 18 digits,
+ -- or otherwise the same as Long_Float.
+
+ Max_HW_Digs : constant := 18;
+ -- Maximum hardware digits supported
+
+ begin
+ case T is
+ when S_Short_Float | S_Float =>
+ return "float";
+ when S_Long_Float =>
+ return "double";
+ when S_Long_Long_Float =>
+ if Long_Double_Index >= 0
+ and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs
+ then
+ return "long double";
+ else
+ return "double";
+ end if;
+ end case;
+ end C_Type_For;
----------
-- Fail --
procedure Fail (E : String) is
E_Fatal : constant := 4;
-- Code for fatal error
+
begin
Write_Str (E);
Write_Eol;
OS_Exit (E_Fatal);
end Fail;
+ ------------------------
+ -- FPT_Mode_Index_For --
+ ------------------------
+
+ function FPT_Mode_Index_For (Name : String) return Natural is
+ begin
+ for J in FPT_Mode_Table'First .. Num_FPT_Modes loop
+ if FPT_Mode_Table (J).NAME.all = Name then
+ return J;
+ end if;
+ end loop;
+
+ raise Program_Error;
+ end FPT_Mode_Index_For;
+
+ function FPT_Mode_Index_For (T : S_Float_Types) return Natural is
+ begin
+ return FPT_Mode_Index_For (C_Type_For (T));
+ end FPT_Mode_Index_For;
+
-------------------------
-- Register_Float_Type --
-------------------------
-- Acquire entry if non-vector non-complex fpt type (digits non-zero)
if Digs > 0 and then not Complex and then Count = 0 then
- Num_FPT_Modes := Num_FPT_Modes + 1;
- FPT_Mode_Table (Num_FPT_Modes) :=
- (NAME => new String'(T (1 .. Last)),
- DIGS => Digs,
- FLOAT_REP => Float_Rep,
- PRECISION => Precision,
- SIZE => Size,
- ALIGNMENT => Alignment);
+
+ declare
+ This_Name : constant String := T (1 .. Last);
+ begin
+ Num_FPT_Modes := Num_FPT_Modes + 1;
+ FPT_Mode_Table (Num_FPT_Modes) :=
+ (NAME => new String'(This_Name),
+ DIGS => Digs,
+ FLOAT_REP => Float_Rep,
+ PRECISION => Precision,
+ SIZE => Size,
+ ALIGNMENT => Alignment);
+
+ if Long_Double_Index < 0 and then This_Name = "long double" then
+ Long_Double_Index := Num_FPT_Modes;
+ end if;
+ end;
end if;
end Register_Float_Type;
end loop;
end;
+ -- Register floating-point types from the back end. We do this
+ -- unconditionally so C_Type_For may be called regardless of -gnateT, for
+ -- which cstand has a use, and early so we can use FPT_Mode_Table below to
+ -- compute some FP attributes.
+
+ Register_Back_End_Types (Register_Float_Type'Access);
+
-- Case of reading the target dependent values from file
-- This is bit more complex than might be expected, because it has to be
Char_Size := Get_Char_Size;
Double_Float_Alignment := Get_Double_Float_Alignment;
Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
- Double_Size := Get_Double_Size;
- Float_Size := Get_Float_Size;
Float_Words_BE := Get_Float_Words_BE;
Int_Size := Get_Int_Size;
- Long_Double_Size := Get_Long_Double_Size;
Long_Long_Size := Get_Long_Long_Size;
Long_Size := Get_Long_Size;
Maximum_Alignment := Get_Maximum_Alignment;
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
- -- Register floating-point types from the back end
+ -- Compute the sizes of floating point types
+
+ declare
+ T : FPT_Mode_Entry renames
+ FPT_Mode_Table (FPT_Mode_Index_For (S_Float));
+ begin
+ Float_Size := Int (T.SIZE);
+ end;
+
+ declare
+ T : FPT_Mode_Entry renames
+ FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float));
+ begin
+ Double_Size := Int (T.SIZE);
+ end;
+
+ declare
+ T : FPT_Mode_Entry renames
+ FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float));
+ begin
+ Long_Double_Size := Int (T.SIZE);
+ end;
- Register_Back_End_Types (Register_Float_Type'Access);
end if;
end;
end if;
-- size of wchar_t, since this corresponds to expected Ada usage.
with Einfo; use Einfo;
+with Stand; use Stand;
with Types; use Types;
package Set_Targ is
-- Subprograms --
-----------------
+ subtype S_Float_Types is
+ Standard_Entity_Type range S_Short_Float .. S_Long_Long_Float;
+
+ function C_Type_For (T : S_Float_Types) return String;
+ -- Return the name of a C type supported by the back-end and suitable as
+ -- a basis to construct the standard Ada floating point type identified by
+ -- T. This is used as a common ground to feed both ttypes values and the
+ -- GNAT tree nodes for the standard floating point types.
+
procedure Write_Target_Dependent_Values;
-- This routine writes the file target.atp in the current directory with
-- the values of the global target parameters as listed above, and as set
projects / platform / upstream / linaro-gcc.git / commitdiff