From: Robert Dewar Date: Thu, 13 Dec 2007 10:27:21 +0000 (+0100) Subject: gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7b76e80551f4445f2557d9f20bc29f06adb7b4e1;p=gcc.git gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target 2007-12-06 Robert Dewar Ed Schonberg * gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target * layout.adb (Resolve_Attribute, case 'Access): If designated type of context is a limited view, use non-limited view when available. If the non-limited view is an unconstrained array, this enforces consistency requirements in 3.10.2 (27). (Layout_Type): For an access type whose designated type is a limited view, examine its declaration to determine if it is an unconstrained array, and size the access type accordingly. (Layout_Type): Do not force 32-bits for convention c subprogram pointers in -gnatdm mode, only if real vms target. * sem_attr.adb (Analyze_Access_Attribute): Use new flag Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined (Analyze_Access_Attribute,Attribute_Address): Remove checks for violations of the No_Implicit_Dynamic_Code restriction. (Resolve_Attribute, case 'Access): If designated type of context is a limited view, use non-limited view when available. If the non-limited view is an unconstrained array, this enforces consistency requirements in 3.10.2 (27). (Layout_Type): For an access type whose designated type is a limited view, examine its declaration to determine if it is an unconstrained array, and size the access type accordingly. From-SVN: r130840 --- diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 743520ee799..dda21ce8e98 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -370,6 +370,12 @@ begin Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; end if; + -- Deal with forcing OpenVMS switches Ture if debug flag M is set, but + -- record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target + -- before doing this. + + Opt.True_VMS_Target := Targparm.OpenVMS_On_Target; + if Debug_Flag_M then Targparm.OpenVMS_On_Target := True; Hostparm.OpenVMS := True; diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index f92a37d4d02..a3ed7579451 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -2300,6 +2300,8 @@ package body Layout is ----------------- procedure Layout_Type (E : Entity_Id) is + Desig_Type : Entity_Id; + begin -- For string literal types, for now, kill the size always, this -- is because gigi does not like or need the size to be set ??? @@ -2321,6 +2323,18 @@ package body Layout is if Is_Access_Type (E) then + Desig_Type := Underlying_Type (Designated_Type (E)); + + -- If we only have a limited view of the type, see whether the + -- non-limited view is available. + + if From_With_Type (Designated_Type (E)) + and then Ekind (Designated_Type (E)) = E_Incomplete_Type + and then Present (Non_Limited_View (Designated_Type (E))) + then + Desig_Type := Non_Limited_View (Designated_Type (E)); + end if; + -- If Esize already set (e.g. by a size clause), then nothing -- further to be done here. @@ -2344,11 +2358,10 @@ package body Layout is -- a fat pointer is used (pointer-to-unconstrained array case), -- twice the address size to accommodate a fat pointer. - elsif Present (Underlying_Type (Designated_Type (E))) - and then Is_Array_Type (Underlying_Type (Designated_Type (E))) - and then not Is_Constrained (Underlying_Type (Designated_Type (E))) - and then not Has_Completion_In_Body (Underlying_Type - (Designated_Type (E))) + elsif Present (Desig_Type) + and then Is_Array_Type (Desig_Type) + and then not Is_Constrained (Desig_Type) + and then not Has_Completion_In_Body (Desig_Type) and then not Debug_Flag_6 then Init_Size (E, 2 * System_Address_Size); @@ -2365,6 +2378,19 @@ package body Layout is ("?this access type does not correspond to C pointer", E); end if; + -- If the designated type is a limited view it is unanalyzed. We + -- can examine the declaration itself to determine whether it will + -- need a fat pointer. + + elsif Present (Desig_Type) + and then Present (Parent (Desig_Type)) + and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Parent (Desig_Type))) + = N_Unconstrained_Array_Definition + then + Init_Size (E, 2 * System_Address_Size); + -- When the target is AAMP, access-to-subprogram types are fat -- pointers consisting of the subprogram address and a static -- link (with the exception of library-level access types, @@ -2395,7 +2421,10 @@ package body Layout is -- for this purpose, since it would be weird not to inherit the size -- in this case. - if OpenVMS_On_Target + -- We do NOT do this if we are in -gnatdm mode on a non-VMS target + -- since in that case we want the normal pointer representation. + + if Opt.True_VMS_Target and then (Convention (E) = Convention_C or else Convention (E) = Convention_CPP) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1a0b0c82d4f..4bfce0c6cb9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -534,14 +534,7 @@ package body Sem_Attr is if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then - -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code - -- restriction set (since in general a trampoline is required). - - if not Is_Library_Level_Entity (Entity (P)) then - Check_Restriction (No_Implicit_Dynamic_Code, P); - end if; - - if Is_Always_Inlined (Entity (P)) then + if Has_Pragma_Inline_Always (Entity (P)) then Error_Attr_P ("prefix of % attribute cannot be Inline_Always subprogram"); end if; @@ -1399,7 +1392,6 @@ package body Sem_Attr is then Error_Attr ("only allowed prefix for % attribute is Standard", P); end if; - end Check_Standard_Prefix; ---------------------------- @@ -1921,10 +1913,6 @@ package body Sem_Attr is begin if Is_Subprogram (Ent) then - if not Is_Library_Level_Entity (Ent) then - Check_Restriction (No_Implicit_Dynamic_Code, P); - end if; - Set_Address_Taken (Ent); Kill_Current_Values (Ent); @@ -1934,7 +1922,7 @@ package body Sem_Attr is -- errors about implicit uses of Address in the dispatch -- table initialization). - if Is_Always_Inlined (Entity (P)) + if Has_Pragma_Inline_Always (Entity (P)) and then Comes_From_Source (P) then Error_Attr_P @@ -2809,6 +2797,20 @@ package body Sem_Attr is Error_Attr_P ("prefix of % attribute must be tagged"); end if; + --------------- + -- Fast_Math -- + --------------- + + when Attribute_Fast_Math => + Check_E0; + Check_Standard_Prefix; + + if Opt.Fast_Math then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + ----------- -- First -- ----------- @@ -3869,6 +3871,9 @@ package body Sem_Attr is if Comes_From_Source (N) then Check_Not_Incomplete_Type; end if; + + -- Set appropriate type + Set_Etype (N, RTE (RE_Tag)); ----------------- @@ -6914,6 +6919,7 @@ package body Sem_Attr is Attribute_Elab_Spec | Attribute_Enabled | Attribute_External_Tag | + Attribute_Fast_Math | Attribute_First_Bit | Attribute_Input | Attribute_Last_Bit | @@ -7439,6 +7445,26 @@ package body Sem_Attr is end if; end if; + Des_Btyp := Designated_Type (Btyp); + + if Ada_Version >= Ada_05 + and then Is_Incomplete_Type (Des_Btyp) + then + -- Ada 2005 (AI-412): If the (sub)type is a limited view of an + -- imported entity, and the non-limited view is visible, make + -- use of it. If it is an incomplete subtype, use the base type + -- in any case. + + if From_With_Type (Des_Btyp) + and then Present (Non_Limited_View (Des_Btyp)) + then + Des_Btyp := Non_Limited_View (Des_Btyp); + + elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then + Des_Btyp := Etype (Des_Btyp); + end if; + end if; + if (Attr_Id = Attribute_Access or else Attr_Id = Attribute_Unchecked_Access) @@ -7489,23 +7515,6 @@ package body Sem_Attr is Nom_Subt := Base_Type (Nom_Subt); end if; - Des_Btyp := Designated_Type (Btyp); - - if Ekind (Des_Btyp) = E_Incomplete_Subtype then - - -- Ada 2005 (AI-412): Subtypes of incomplete types visible - -- through a limited with clause or regular incomplete - -- subtypes. - - if From_With_Type (Des_Btyp) - and then Present (Non_Limited_View (Des_Btyp)) - then - Des_Btyp := Non_Limited_View (Des_Btyp); - else - Des_Btyp := Etype (Des_Btyp); - end if; - end if; - if Is_Tagged_Type (Designated_Type (Typ)) then -- If the attribute is in the context of an access @@ -7568,16 +7577,20 @@ package body Sem_Attr is -- (because access values must be assumed to designate mutable -- objects when designated type does not impose a constraint). - elsif not Subtypes_Statically_Match (Des_Btyp, Nom_Subt) + elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then + null; + + elsif Has_Discriminants (Designated_Type (Typ)) + and then not Is_Constrained (Des_Btyp) and then - not (Has_Discriminants (Designated_Type (Typ)) - and then not Is_Constrained (Des_Btyp) - and then - (Ada_Version < Ada_05 - or else - not Has_Constrained_Partial_View - (Designated_Type (Base_Type (Typ))))) + (Ada_Version < Ada_05 + or else + not Has_Constrained_Partial_View + (Designated_Type (Base_Type (Typ)))) then + null; + + else Error_Msg_F ("object subtype must statically match " & "designated subtype", P);