diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2685b585eb4..695747b7817 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,66 @@ +2015-01-06 Robert Dewar + + * 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 + + * 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 + + * gnat1drv.adb: Minor: complete previous change. + +2015-01-06 Olivier Hainque + + * 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 + + * 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 * sem_ch6.adb (New_Overloaded_Entity): In GNATprove mode, a diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb index 1f8f58b203f..c7115f65768 100644 --- a/gcc/ada/a-tiflau.adb +++ b/gcc/ada/a-tiflau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -124,7 +124,8 @@ package body Ada.Text_IO.Float_Aux is 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); diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb index 58ba0918267..5d08dc09f7c 100644 --- a/gcc/ada/a-tiinau.adb +++ b/gcc/ada/a-tiinau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -166,7 +166,8 @@ package body Ada.Text_IO.Integer_Aux is 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); diff --git a/gcc/ada/a-timoau.adb b/gcc/ada/a-timoau.adb index 7b204c85dda..2fceb8a96ac 100644 --- a/gcc/ada/a-timoau.adb +++ b/gcc/ada/a-timoau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -173,6 +173,10 @@ package body Ada.Text_IO.Modular_Aux is 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 diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb index 419ea7066bc..718ec660bfa 100644 --- a/gcc/ada/a-wtflau.adb +++ b/gcc/ada/a-wtflau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -124,7 +124,8 @@ package body Ada.Wide_Text_IO.Float_Aux is 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); diff --git a/gcc/ada/a-wtinau.adb b/gcc/ada/a-wtinau.adb index 41163850605..8b4b1e65a1e 100644 --- a/gcc/ada/a-wtinau.adb +++ b/gcc/ada/a-wtinau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -165,6 +165,10 @@ package body Ada.Wide_Text_IO.Integer_Aux is 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 diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb index 0bc22a329eb..25c72ecfcd7 100644 --- a/gcc/ada/a-wtmoau.adb +++ b/gcc/ada/a-wtmoau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -173,6 +173,10 @@ package body Ada.Wide_Text_IO.Modular_Aux is 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 diff --git a/gcc/ada/a-ztflau.adb b/gcc/ada/a-ztflau.adb index 5e91a9c1b61..55dd2da5484 100644 --- a/gcc/ada/a-ztflau.adb +++ b/gcc/ada/a-ztflau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -124,7 +124,8 @@ package body Ada.Wide_Wide_Text_IO.Float_Aux is 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); diff --git a/gcc/ada/a-ztinau.adb b/gcc/ada/a-ztinau.adb index 743e5590d49..735e51fc4e3 100644 --- a/gcc/ada/a-ztinau.adb +++ b/gcc/ada/a-ztinau.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -165,6 +165,10 @@ package body Ada.Wide_Wide_Text_IO.Integer_Aux is 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 diff --git a/gcc/ada/a-ztmoau.adb b/gcc/ada/a-ztmoau.adb index f8d72955aa6..dbcf37808ee 100644 --- a/gcc/ada/a-ztmoau.adb +++ b/gcc/ada/a-ztmoau.adb @@ -173,6 +173,10 @@ package body Ada.Wide_Wide_Text_IO.Modular_Aux is 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 diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 2032b9b4c03..a86397cb9ba 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -504,45 +504,26 @@ package body CStand is 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 diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb index 9dde22bebf6..e1dfb26ff2d 100644 --- a/gcc/ada/get_targ.adb +++ b/gcc/ada/get_targ.adb @@ -126,42 +126,6 @@ package body Get_Targ is 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 -- ---------------------- diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 457575eddd9..62333b9dfea 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -68,15 +68,6 @@ package Get_Targ is 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 diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index b4e74f4fcc0..adb145c7445 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -182,10 +182,11 @@ procedure Gnat1drv is 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 diff --git a/gcc/ada/s-valllu.adb b/gcc/ada/s-valllu.adb index c37781fca2e..3315b1d7c7f 100644 --- a/gcc/ada/s-valllu.adb +++ b/gcc/ada/s-valllu.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -119,9 +119,10 @@ package body System.Val_LLU is 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; diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb index e8debff1e46..5d6960df1d5 100644 --- a/gcc/ada/s-valrea.adb +++ b/gcc/ada/s-valrea.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -183,9 +183,10 @@ package body System.Val_Real is 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; diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb index 84da2b16e08..44754cf39b9 100644 --- a/gcc/ada/s-valuns.adb +++ b/gcc/ada/s-valuns.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -119,9 +119,10 @@ package body System.Val_Uns is 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; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 06460fd5ecb..e03d00ebfc8 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -86,10 +86,10 @@ package body Sem_Cat is -- 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 @@ -544,30 +544,39 @@ package body Sem_Cat is 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; - -- 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; + 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. + + return True; + end In_RCI_Visible_Declarations; ----------------------- -- In_RT_Declaration -- @@ -1371,7 +1380,7 @@ package body Sem_Cat is -- 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 @@ -1609,7 +1618,7 @@ package body Sem_Cat is -- 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; @@ -1652,12 +1661,10 @@ package body Sem_Cat is -- 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 @@ -1680,8 +1687,15 @@ package body Sem_Cat is 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; @@ -1698,8 +1712,8 @@ package body Sem_Cat is -- 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; @@ -1721,7 +1735,7 @@ package body Sem_Cat is 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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8443daf6fcd..f489cb8d814 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1699,15 +1699,26 @@ package body Sem_Ch13 is -- 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 @@ -3556,6 +3567,8 @@ package body Sem_Ch13 is 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 @@ -4794,6 +4807,7 @@ package body Sem_Ch13 is when Attribute_Default_Iterator => Default_Iterator : declare Func : Entity_Id; + Typ : Entity_Id; begin if not Is_Tagged_Type (U_Ent) then @@ -4813,9 +4827,26 @@ package body Sem_Ch13 is 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; @@ -4832,9 +4863,8 @@ package body Sem_Ch13 is 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; diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 8c201ea3992..0f063e52bb8 100755 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -159,8 +159,64 @@ package body Set_Targ is -- 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 -- @@ -169,12 +225,33 @@ package body Set_Targ is 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 -- ------------------------- @@ -281,14 +358,23 @@ package body Set_Targ is -- 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; @@ -801,6 +887,13 @@ begin 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 @@ -832,11 +925,8 @@ begin 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; @@ -849,9 +939,29 @@ begin 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; diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads index d3ae3d838ff..f3eccfbfa7e 100755 --- a/gcc/ada/set_targ.ads +++ b/gcc/ada/set_targ.ads @@ -37,6 +37,7 @@ -- 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 @@ -107,6 +108,15 @@ 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