diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c309e5785d4a..97defc95cdea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2014-01-20 Robert Dewar + + * exp_ch9.adb, checks.adb, exp_intr.adb: Minor reformatting. + * sem_res.adb (Resolve): Fix error causing infinite loop for + integer used as address. Allow addresses as integers. + +2014-01-20 Arnaud Charlet + + * s-osinte-linux.ads (struct_sigaction): Fix rep clause. + +2014-01-20 Bob Duff + + * par-ch8.adb (P_Use_Type_Clause): Detect syntax + error when "use all" is not followed by "type". + 2014-01-20 Bob Duff * exp_intr.adb (Expand_Unc_Deallocation): Remove warning on abort diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 58b8422ccdd2..1e4cff810c56 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -767,9 +767,11 @@ package body Checks is and then not Warnings_Off (E) and then Restriction_Active (No_Exception_Propagation) then - Error_Msg_N ("address value may be incompatible with " & - "alignment of object?", N); + Error_Msg_N + ("address value may be incompatible with alignment of object?", + N); end if; + return; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index c505e16d09f3..752354298913 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -70,9 +70,9 @@ package body Exp_Ch9 is -- The following constant establishes the upper bound for the index of -- an entry family. It is used to limit the allocated size of protected -- types with defaulted discriminant of an integer type, when the bound - -- of some entry family depends on a discriminant. The limitation to - -- entry families of 128K should be reasonable in all cases, and is a - -- documented implementation restriction. + -- of some entry family depends on a discriminant. The limitation to entry + -- families of 128K should be reasonable in all cases, and is a documented + -- implementation restriction. Entry_Family_Bound : constant Int := 2**16; @@ -202,8 +202,8 @@ package body Exp_Ch9 is -- pre/postconditions. The body gathers the PPC's and expands them in the -- usual way, and performs the entry call itself. This way preconditions -- are evaluated before the call is queued. E is the entry in question, - -- and Decl is the enclosing synchronized type declaration at whose - -- freeze point the generated body is analyzed. + -- and Decl is the enclosing synchronized type declaration at whose freeze + -- point the generated body is analyzed. function Build_Protected_Entry (N : Node_Id; @@ -238,12 +238,12 @@ package body Exp_Ch9 is Pid : Node_Id; N_Op_Spec : Node_Id) return Node_Id; -- This function is used to construct the protected version of a protected - -- subprogram. Its statement sequence first defers abort, then locks - -- the associated protected object, and then enters a block that contains - -- a call to the unprotected version of the subprogram (for details, see - -- Build_Unprotected_Subprogram_Body). This block statement requires - -- a cleanup handler that unlocks the object in all cases. - -- (see Exp_Ch7.Expand_Cleanup_Actions). + -- subprogram. Its statement sequence first defers abort, then locks the + -- associated protected object, and then enters a block that contains a + -- call to the unprotected version of the subprogram (for details, see + -- Build_Unprotected_Subprogram_Body). This block statement requires a + -- cleanup handler that unlocks the object in all cases. For details, + -- see Exp_Ch7.Expand_Cleanup_Actions. function Build_Renamed_Formal_Declaration (New_F : Entity_Id; @@ -262,14 +262,13 @@ package body Exp_Ch9 is (Prefix : Entity_Id; Selector : Entity_Id; Append_Char : Character := ' ') return Name_Id; - -- Build a name in the form of Prefix__Selector, with an optional - -- character appended. This is used for internal subprograms generated - -- for operations of protected types, including barrier functions. - -- For the subprograms generated for entry bodies and entry barriers, - -- the generated name includes a sequence number that makes names - -- unique in the presence of entry overloading. This is necessary - -- because entry body procedures and barrier functions all have the - -- same signature. + -- Build a name in the form of Prefix__Selector, with an optional character + -- appended. This is used for internal subprograms generated for operations + -- of protected types, including barrier functions. For the subprograms + -- generated for entry bodies and entry barriers, the generated name + -- includes a sequence number that makes names unique in the presence of + -- entry overloading. This is necessary because entry body procedures and + -- barrier functions all have the same signature. procedure Build_Simple_Entry_Call (N : Node_Id; @@ -350,14 +349,14 @@ package body Exp_Ch9 is procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); -- If control flow optimizations are suppressed, and Alt is an accept, - -- delay, or entry call alternative with no trailing statements, insert a - -- null trailing statement with the given Loc (which is the sloc of the - -- accept, delay, or entry call statement). There might not be any - -- generated code for the accept, delay, or entry call itself (the - -- effect of these statements is part of the general processsing done - -- for the enclosing selective accept, timed entry call, or asynchronous - -- select), and the null statement is there to carry the sloc of that - -- statement to the back-end for trace-based coverage analysis purposes. + -- delay, or entry call alternative with no trailing statements, insert + -- a null trailing statement with the given Loc (which is the sloc of + -- the accept, delay, or entry call statement). There might not be any + -- generated code for the accept, delay, or entry call itself (the effect + -- of these statements is part of the general processsing done for the + -- enclosing selective accept, timed entry call, or asynchronous select), + -- and the null statement is there to carry the sloc of that statement to + -- the back-end for trace-based coverage analysis purposes. procedure Extract_Dispatching_Call (N : Node_Id; @@ -376,8 +375,8 @@ package body Exp_Ch9 is Concval : out Node_Id; Ename : out Node_Id; Index : out Node_Id); - -- Given an entry call, returns the associated concurrent object, - -- the entry name, and the entry family index. + -- Given an entry call, returns the associated concurrent object, the entry + -- name, and the entry family index. function Family_Offset (Loc : Source_Ptr; @@ -385,11 +384,11 @@ package body Exp_Ch9 is Lo : Node_Id; Ttyp : Entity_Id; Cap : Boolean) return Node_Id; - -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in - -- an accept statement, or the upper bound in the discrete subtype of - -- an entry declaration. Lo is the corresponding lower bound. Ttyp is - -- the concurrent type of the entry. If Cap is true, the result is - -- capped according to Entry_Family_Bound. + -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an + -- accept statement, or the upper bound in the discrete subtype of an entry + -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent + -- type of the entry. If Cap is true, the result is capped according to + -- Entry_Family_Bound. function Family_Size (Loc : Source_Ptr; @@ -397,11 +396,11 @@ package body Exp_Ch9 is Lo : Node_Id; Ttyp : Entity_Id; Cap : Boolean) return Node_Id; - -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in - -- a family, and handle properly the superflat case. This is equivalent - -- to the use of 'Length on the index type, but must use Family_Offset - -- to handle properly the case of bounds that depend on discriminants. - -- If Cap is true, the result is capped according to Entry_Family_Bound. + -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a + -- family, and handle properly the superflat case. This is equivalent to + -- the use of 'Length on the index type, but must use Family_Offset to + -- handle properly the case of bounds that depend on discriminants. If + -- Cap is true, the result is capped according to Entry_Family_Bound. procedure Find_Enclosing_Context (N : Node_Id; @@ -417,8 +416,8 @@ package body Exp_Ch9 is function Index_Object (Spec_Id : Entity_Id) return Entity_Id; -- Given a subprogram identifier, return the entity which is associated - -- with the protection entry index in the Protected_Body_Subprogram or the - -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal + -- with the protection entry index in the Protected_Body_Subprogram or + -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- parameter _E. function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; @@ -436,9 +435,9 @@ package body Exp_Ch9 is function Null_Statements (Stats : List_Id) return Boolean; -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. - -- Allows labels, and pragma Warnings/Unreferenced in the sequence as - -- well to still count as null. Returns True for a null sequence. The - -- argument is the list of statements from the DO-END sequence. + -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well + -- to still count as null. Returns True for a null sequence. The argument + -- is the list of statements from the DO-END sequence. function Parameter_Block_Pack (Loc : Source_Ptr; @@ -447,8 +446,8 @@ package body Exp_Ch9 is Formals : List_Id; Decls : List_Id; Stmts : List_Id) return Entity_Id; - -- Set the components of the generated parameter block with the values of - -- the actual parameters. Generate aliased temporaries to capture the + -- Set the components of the generated parameter block with the values + -- of the actual parameters. Generate aliased temporaries to capture the -- values for types that are passed by copy. Otherwise generate a reference -- to the actual's value. Return the address of the aggregate block. -- Generate: @@ -605,8 +604,8 @@ package body Exp_Ch9 is S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); - -- The need for the following full view retrieval stems from - -- this complex case of nested generics and tasking: + -- The need for the following full view retrieval stems from this + -- complex case of nested generics and tasking: -- generic -- type Formal_Index is range <>; @@ -638,6 +637,7 @@ package body Exp_Ch9 is -- We are currently building the index expression for the entry -- call "T.E" (1). Part of the expansion must mention the range -- of the discrete type "Index" (2) of entry family "Fam". + -- However only the private view of type "Index" is available to -- the inner generic (3) because there was no prior mention of -- the type inside "Inner". This visibility requirement is @@ -708,9 +708,9 @@ package body Exp_Ch9 is Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); - -- Now we set debug info needed on New_F even though it does not - -- come from source, so that the debugger will get the right - -- information for these generated names. + -- Now we set debug info needed on New_F even though it does not come + -- from source, so that the debugger will get the right information + -- for these generated names. Set_Debug_Info_Needed (New_F); @@ -843,8 +843,8 @@ package body Exp_Ch9 is New_S := Stats; end if; - -- At this stage we know that the new statement sequence does not - -- have an exception handler part, so we supply one to call + -- At this stage we know that the new statement sequence does + -- not have an exception handler part, so we supply one to call -- Exceptional_Complete_Rendezvous. This handler is -- when all others => @@ -974,8 +974,7 @@ package body Exp_Ch9 is Prepend_To (Decls, Decl); - -- Ensure that the _chain appears in the proper scope of the - -- context. + -- Ensure that _chain appears in the proper scope of the context if Context_Id /= Current_Scope then Push_Scope (Context_Id); @@ -1189,9 +1188,9 @@ package body Exp_Ch9 is while Nkind (Par) /= N_Compilation_Unit loop Par := Parent (Par); - -- If we fall off the top, we are at the outer level, and - -- the environment task is our effective master, so - -- nothing to mark. + -- If we fall off the top, we are at the outer level, + -- and the environment task is our effective master, + -- so nothing to mark. if Nkind_In (Par, N_Block_Statement, N_Subprogram_Body, diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 058b8274e043..6289b1ee224c 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1018,11 +1018,12 @@ package body Exp_Intr is -- For a task type, call Free_Task before freeing the ATCB if Is_Task_Type (Desig_T) then + -- We used to detect the case of Abort followed by a Free here, - -- because the Free wouldn't actually free if it happens before the - -- aborted task actually terminates. The warning is removed, because - -- Free now works properly (the task will be freed once it - -- terminates). + -- because the Free wouldn't actually free if it happens before + -- the aborted task actually terminates. The warning was removed, + -- because Free now works properly (the task will be freed once + -- it terminates). Append_To (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 5e32e74c99ce..8b349b417d6a 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1239,8 +1239,9 @@ If the configuration pragma @code{Allow_Integer_Address} is given, then integer expressions may be used anywhere a value of type @code{System.Address} is required. The effect is to introduce an implicit unchecked conversion from the -integer value to type @code{System.Address}. The following example -compiles without errors: +integer value to type @code{System.Address}. The reverse case of using +an address where an integer type is required is handled analogously. +The following example compiles without errors: @smallexample @c ada pragma Allow_Integer_Address; @@ -1253,6 +1254,8 @@ package AddrAsInt is m : Address := 16#4000#; n : constant Address := 4000; p : constant Address := Address (X + Y); + v : Integer := y'Address; + w : constant Integer := Integer (Y'Address); type R is new integer; RR : R := 1000; Z : Integer; diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index 89a2bb4a22bd..b4eaf8c72284 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -113,7 +113,12 @@ package body Ch8 is Error_Msg_Ada_2012_Feature ("|`USE ALL TYPE`", Token_Ptr); All_Present := True; Scan; -- past ALL - else + + if Token /= Tok_Type then + Error_Msg_SC ("TYPE expected"); + end if; + + else pragma Assert (Token = Tok_Type); All_Present := False; end if; diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 6eb0b88f561d..3f8df80c0721 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2013, 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- -- @@ -589,7 +589,8 @@ private for struct_sigaction use record sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; sa_mask at Linux.sa_mask_pos range 0 .. 1023; - sa_flags at Linux.sa_flags_pos range 0 .. Standard'Address_Size - 1; + sa_flags at Linux.sa_flags_pos + range 0 .. Interfaces.C.unsigned_long'Size - 1; end record; -- We intentionally leave sa_restorer unspecified and let the compiler -- append it after the last field, so disable corresponding warning. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c79c788e32d1..2dc9291a4114 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2612,30 +2612,36 @@ package body Sem_Res is end; end if; - -- If an error message was issued already, Found got reset to - -- True, so if it is still False, issue standard Wrong_Type msg. + -- Looks like we have a type error, but check for special case + -- of Address wanted, integer found, with the configuration pragma + -- Allow_Integer_Address active. If we have this case, introduce + -- an unchecked conversion to allow the integer expression to be + -- treated as an Address. The reverse case of integer wanted, + -- Address found, is treated in an analogous manner. - -- First check for special case of Address wanted, integer found - -- with the configuration pragma Allow_Integer_Address active. - - if Allow_Integer_Address - and then Is_RTE (Typ, RE_Address) - and then Is_Integer_Type (Etype (N)) - then - Rewrite - (N, Unchecked_Convert_To (RTE (RE_Address), - Relocate_Node (N))); - Analyze_And_Resolve (N, RTE (RE_Address)); - return; - - -- OK, not the special case go ahead and issue message - - elsif not Found then - if Is_Overloaded (N) - and then Nkind (N) = N_Function_Call + if Allow_Integer_Address then + if (Is_RTE (Typ, RE_Address) + and then Is_Integer_Type (Etype (N))) + or else + (Is_Integer_Type (Typ) + and then Is_RTE (Etype (N), RE_Address)) then + Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N))); + Analyze_And_Resolve (N, Typ); + return; + end if; + end if; + + -- That special Allow_Integer_Address check did not appply, so we + -- have a real type error. If an error message was issued already, + -- Found got reset to True, so if it's still False, issue standard + -- Wrong_Type message. + + if not Found then + if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then declare Subp_Name : Node_Id; + begin if Is_Entity_Name (Name (N)) then Subp_Name := Name (N); @@ -11085,6 +11091,23 @@ package body Sem_Res is end; end if; + -- Deal with conversion of integer type to address if the pragma + -- Allow_Integer_Address is in effect. We convert the conversion to + -- an unchecked conversion in this case and we are all done! + + if Allow_Integer_Address + and then + ((Is_RTE (Target_Type, RE_Address) + and then Is_Integer_Type (Opnd_Type)) + or else + (Is_RTE (Opnd_Type, RE_Address) + and then Is_Integer_Type (Target_Type))) + then + Rewrite (N, Unchecked_Convert_To (Target_Type, Expression (N))); + Analyze_And_Resolve (N, Target_Type); + return True; + end if; + -- If we are within a child unit, check whether the type of the -- expression has an ancestor in a parent unit, in which case it -- belongs to its derivation class even if the ancestor is private. @@ -11094,7 +11117,7 @@ package body Sem_Res is -- Numeric types - if Is_Numeric_Type (Target_Type) then + if Is_Numeric_Type (Target_Type) then -- A universal fixed expression can be converted to any numeric type @@ -11120,11 +11143,11 @@ package body Sem_Res is else return Conversion_Check - (Is_Numeric_Type (Opnd_Type) - or else - (Present (Inc_Ancestor) - and then Is_Numeric_Type (Inc_Ancestor)), - "illegal operand for numeric conversion"); + (Is_Numeric_Type (Opnd_Type) + or else + (Present (Inc_Ancestor) + and then Is_Numeric_Type (Inc_Ancestor)), + "illegal operand for numeric conversion"); end if; -- Array types @@ -11637,18 +11660,6 @@ package body Sem_Res is ("add ALL to }!", N, Target_Type); return False; - -- Deal with conversion of integer type to address if the pragma - -- Allow_Integer_Address is in effect. - - elsif Allow_Integer_Address - and then Is_RTE (Etype (N), RE_Address) - and then Is_Integer_Type (Etype (Operand)) - then - Rewrite (N, - Unchecked_Convert_To (RTE (RE_Address), Relocate_Node (N))); - Analyze_And_Resolve (N, RTE (RE_Address)); - return True; - -- Here we have a real conversion error else