OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-01-20  Robert Dewar  <dewar@adacore.com>

	* 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  <charlet@adacore.com>

	* s-osinte-linux.ads (struct_sigaction): Fix rep clause.

2014-01-20  Bob Duff  <duff@adacore.com>

	* par-ch8.adb (P_Use_Type_Clause): Detect syntax
	error when "use all" is not followed by "type".

From-SVN: r206829
This commit is contained in:
Arnaud Charlet 2014-01-20 16:39:55 +01:00
parent 3b4598a761
commit 6fd0a72a53
8 changed files with 144 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/ada/ChangeLog
View File

@ -1,3 +1,18 @@
2014-01-20 Robert Dewar <dewar@adacore.com>
* 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 <charlet@adacore.com>
* s-osinte-linux.ads (struct_sigaction): Fix rep clause.
2014-01-20 Bob Duff <duff@adacore.com>
* par-ch8.adb (P_Use_Type_Clause): Detect syntax
error when "use all" is not followed by "type".
2014-01-20 Bob Duff <duff@adacore.com> 2014-01-20 Bob Duff <duff@adacore.com>
* exp_intr.adb (Expand_Unc_Deallocation): Remove warning on abort * exp_intr.adb (Expand_Unc_Deallocation): Remove warning on abort

6
gcc/ada/checks.adb
View File

@ -767,9 +767,11 @@ package body Checks is
and then not Warnings_Off (E) and then not Warnings_Off (E)
and then Restriction_Active (No_Exception_Propagation) and then Restriction_Active (No_Exception_Propagation)
then then
Error_Msg_N ("address value may be incompatible with " & Error_Msg_N
"alignment of object?", N); ("address value may be incompatible with alignment of object?",
N);
end if; end if;
return; return;
end if; end if;

115
gcc/ada/exp_ch9.adb
View File

@ -70,9 +70,9 @@ package body Exp_Ch9 is
-- The following constant establishes the upper bound for the index of -- The following constant establishes the upper bound for the index of
-- an entry family. It is used to limit the allocated size of protected -- an entry family. It is used to limit the allocated size of protected
-- types with defaulted discriminant of an integer type, when the bound -- types with defaulted discriminant of an integer type, when the bound
-- of some entry family depends on a discriminant. The limitation to -- of some entry family depends on a discriminant. The limitation to entry
-- entry families of 128K should be reasonable in all cases, and is a -- families of 128K should be reasonable in all cases, and is a documented
-- documented implementation restriction. -- implementation restriction.
Entry_Family_Bound : constant Int := 2**16; 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 -- pre/postconditions. The body gathers the PPC's and expands them in the
-- usual way, and performs the entry call itself. This way preconditions -- usual way, and performs the entry call itself. This way preconditions
-- are evaluated before the call is queued. E is the entry in question, -- are evaluated before the call is queued. E is the entry in question,
-- and Decl is the enclosing synchronized type declaration at whose -- and Decl is the enclosing synchronized type declaration at whose freeze
-- freeze point the generated body is analyzed. -- point the generated body is analyzed.
function Build_Protected_Entry function Build_Protected_Entry
(N : Node_Id; (N : Node_Id;
@ -238,12 +238,12 @@ package body Exp_Ch9 is
Pid : Node_Id; Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id; N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected -- This function is used to construct the protected version of a protected
-- subprogram. Its statement sequence first defers abort, then locks -- subprogram. Its statement sequence first defers abort, then locks the
-- the associated protected object, and then enters a block that contains -- associated protected object, and then enters a block that contains a
-- a call to the unprotected version of the subprogram (for details, see -- call to the unprotected version of the subprogram (for details, see
-- Build_Unprotected_Subprogram_Body). This block statement requires -- Build_Unprotected_Subprogram_Body). This block statement requires a
-- a cleanup handler that unlocks the object in all cases. -- cleanup handler that unlocks the object in all cases. For details,
-- (see Exp_Ch7.Expand_Cleanup_Actions). -- see Exp_Ch7.Expand_Cleanup_Actions.
function Build_Renamed_Formal_Declaration function Build_Renamed_Formal_Declaration
(New_F : Entity_Id; (New_F : Entity_Id;
@ -262,14 +262,13 @@ package body Exp_Ch9 is
(Prefix : Entity_Id; (Prefix : Entity_Id;
Selector : Entity_Id; Selector : Entity_Id;
Append_Char : Character := ' ') return Name_Id; Append_Char : Character := ' ') return Name_Id;
-- Build a name in the form of Prefix__Selector, with an optional -- Build a name in the form of Prefix__Selector, with an optional character
-- character appended. This is used for internal subprograms generated -- appended. This is used for internal subprograms generated for operations
-- for operations of protected types, including barrier functions. -- of protected types, including barrier functions. For the subprograms
-- For the subprograms generated for entry bodies and entry barriers, -- generated for entry bodies and entry barriers, the generated name
-- the generated name includes a sequence number that makes names -- includes a sequence number that makes names unique in the presence of
-- unique in the presence of entry overloading. This is necessary -- entry overloading. This is necessary because entry body procedures and
-- because entry body procedures and barrier functions all have the -- barrier functions all have the same signature.
-- same signature.
procedure Build_Simple_Entry_Call procedure Build_Simple_Entry_Call
(N : Node_Id; (N : Node_Id;
@ -350,14 +349,14 @@ package body Exp_Ch9 is
procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
-- If control flow optimizations are suppressed, and Alt is an accept, -- If control flow optimizations are suppressed, and Alt is an accept,
-- delay, or entry call alternative with no trailing statements, insert a -- delay, or entry call alternative with no trailing statements, insert
-- null trailing statement with the given Loc (which is the sloc of the -- a null trailing statement with the given Loc (which is the sloc of
-- accept, delay, or entry call statement). There might not be any -- the accept, delay, or entry call statement). There might not be any
-- generated code for the accept, delay, or entry call itself (the -- generated code for the accept, delay, or entry call itself (the effect
-- effect of these statements is part of the general processsing done -- of these statements is part of the general processsing done for the
-- for the enclosing selective accept, timed entry call, or asynchronous -- enclosing selective accept, timed entry call, or asynchronous select),
-- select), and the null statement is there to carry the sloc of that -- and the null statement is there to carry the sloc of that statement to
-- statement to the back-end for trace-based coverage analysis purposes. -- the back-end for trace-based coverage analysis purposes.
procedure Extract_Dispatching_Call procedure Extract_Dispatching_Call
(N : Node_Id; (N : Node_Id;
@ -376,8 +375,8 @@ package body Exp_Ch9 is
Concval : out Node_Id; Concval : out Node_Id;
Ename : out Node_Id; Ename : out Node_Id;
Index : out Node_Id); Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object, -- Given an entry call, returns the associated concurrent object, the entry
-- the entry name, and the entry family index. -- name, and the entry family index.
function Family_Offset function Family_Offset
(Loc : Source_Ptr; (Loc : Source_Ptr;
@ -385,11 +384,11 @@ package body Exp_Ch9 is
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id; Ttyp : Entity_Id;
Cap : Boolean) return Node_Id; Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) for two entry family indexes. Hi is the index in -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
-- an accept statement, or the upper bound in the discrete subtype of -- accept statement, or the upper bound in the discrete subtype of an entry
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
-- the concurrent type of the entry. If Cap is true, the result is -- type of the entry. If Cap is true, the result is capped according to
-- capped according to Entry_Family_Bound. -- Entry_Family_Bound.
function Family_Size function Family_Size
(Loc : Source_Ptr; (Loc : Source_Ptr;
@ -397,11 +396,11 @@ package body Exp_Ch9 is
Lo : Node_Id; Lo : Node_Id;
Ttyp : Entity_Id; Ttyp : Entity_Id;
Cap : Boolean) return Node_Id; Cap : Boolean) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
-- a family, and handle properly the superflat case. This is equivalent -- family, and handle properly the superflat case. This is equivalent to
-- to the use of 'Length on the index type, but must use Family_Offset -- the use of 'Length on the index type, but must use Family_Offset to
-- to handle properly the case of bounds that depend on discriminants. -- handle properly the case of bounds that depend on discriminants. If
-- If Cap is true, the result is capped according to Entry_Family_Bound. -- Cap is true, the result is capped according to Entry_Family_Bound.
procedure Find_Enclosing_Context procedure Find_Enclosing_Context
(N : Node_Id; (N : Node_Id;
@ -417,8 +416,8 @@ package body Exp_Ch9 is
function Index_Object (Spec_Id : Entity_Id) return Entity_Id; function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
-- Given a subprogram identifier, return the entity which is associated -- Given a subprogram identifier, return the entity which is associated
-- with the protection entry index in the Protected_Body_Subprogram or the -- with the protection entry index in the Protected_Body_Subprogram or
-- Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
-- parameter _E. -- parameter _E.
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; 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; function Null_Statements (Stats : List_Id) return Boolean;
-- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
-- Allows labels, and pragma Warnings/Unreferenced in the sequence as -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
-- well to still count as null. Returns True for a null sequence. The -- to still count as null. Returns True for a null sequence. The argument
-- argument is the list of statements from the DO-END sequence. -- is the list of statements from the DO-END sequence.
function Parameter_Block_Pack function Parameter_Block_Pack
(Loc : Source_Ptr; (Loc : Source_Ptr;
@ -447,8 +446,8 @@ package body Exp_Ch9 is
Formals : List_Id; Formals : List_Id;
Decls : List_Id; Decls : List_Id;
Stmts : List_Id) return Entity_Id; Stmts : List_Id) return Entity_Id;
-- Set the components of the generated parameter block with the values of -- Set the components of the generated parameter block with the values
-- the actual parameters. Generate aliased temporaries to capture the -- of the actual parameters. Generate aliased temporaries to capture the
-- values for types that are passed by copy. Otherwise generate a reference -- values for types that are passed by copy. Otherwise generate a reference
-- to the actual's value. Return the address of the aggregate block. -- to the actual's value. Return the address of the aggregate block.
-- Generate: -- Generate:
@ -605,8 +604,8 @@ package body Exp_Ch9 is
S := S :=
Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
-- The need for the following full view retrieval stems from -- The need for the following full view retrieval stems from this
-- this complex case of nested generics and tasking: -- complex case of nested generics and tasking:
-- generic -- generic
-- type Formal_Index is range <>; -- type Formal_Index is range <>;
@ -638,6 +637,7 @@ package body Exp_Ch9 is
-- We are currently building the index expression for the entry -- We are currently building the index expression for the entry
-- call "T.E" (1). Part of the expansion must mention the range -- call "T.E" (1). Part of the expansion must mention the range
-- of the discrete type "Index" (2) of entry family "Fam". -- of the discrete type "Index" (2) of entry family "Fam".
-- However only the private view of type "Index" is available to -- However only the private view of type "Index" is available to
-- the inner generic (3) because there was no prior mention of -- the inner generic (3) because there was no prior mention of
-- the type inside "Inner". This visibility requirement is -- the type inside "Inner". This visibility requirement is
@ -708,9 +708,9 @@ package body Exp_Ch9 is
Set_Etype (New_F, Etype (Formal)); Set_Etype (New_F, Etype (Formal));
Set_Scope (New_F, Ent); Set_Scope (New_F, Ent);
-- Now we set debug info needed on New_F even though it does not -- Now we set debug info needed on New_F even though it does not come
-- come from source, so that the debugger will get the right -- from source, so that the debugger will get the right information
-- information for these generated names. -- for these generated names.
Set_Debug_Info_Needed (New_F); Set_Debug_Info_Needed (New_F);
@ -843,8 +843,8 @@ package body Exp_Ch9 is
New_S := Stats; New_S := Stats;
end if; end if;
-- At this stage we know that the new statement sequence does not -- At this stage we know that the new statement sequence does
-- have an exception handler part, so we supply one to call -- not have an exception handler part, so we supply one to call
-- Exceptional_Complete_Rendezvous. This handler is -- Exceptional_Complete_Rendezvous. This handler is
-- when all others => -- when all others =>
@ -974,8 +974,7 @@ package body Exp_Ch9 is
Prepend_To (Decls, Decl); Prepend_To (Decls, Decl);
-- Ensure that the _chain appears in the proper scope of the -- Ensure that _chain appears in the proper scope of the context
-- context.
if Context_Id /= Current_Scope then if Context_Id /= Current_Scope then
Push_Scope (Context_Id); Push_Scope (Context_Id);
@ -1189,9 +1188,9 @@ package body Exp_Ch9 is
while Nkind (Par) /= N_Compilation_Unit loop while Nkind (Par) /= N_Compilation_Unit loop
Par := Parent (Par); Par := Parent (Par);
-- If we fall off the top, we are at the outer level, and -- If we fall off the top, we are at the outer level,
-- the environment task is our effective master, so -- and the environment task is our effective master,
-- nothing to mark. -- so nothing to mark.
if Nkind_In (Par, N_Block_Statement, if Nkind_In (Par, N_Block_Statement,
N_Subprogram_Body, N_Subprogram_Body,

9
gcc/ada/exp_intr.adb
View File

@ -1018,11 +1018,12 @@ package body Exp_Intr is
-- For a task type, call Free_Task before freeing the ATCB -- For a task type, call Free_Task before freeing the ATCB
if Is_Task_Type (Desig_T) then if Is_Task_Type (Desig_T) then
-- We used to detect the case of Abort followed by a Free here, -- 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 -- because the Free wouldn't actually free if it happens before
-- aborted task actually terminates. The warning is removed, because -- the aborted task actually terminates. The warning was removed,
-- Free now works properly (the task will be freed once it -- because Free now works properly (the task will be freed once
-- terminates). -- it terminates).
Append_To Append_To
(Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));

7
gcc/ada/gnat_rm.texi
View File

@ -1239,8 +1239,9 @@ If the configuration pragma
@code{Allow_Integer_Address} is given, then integer expressions may @code{Allow_Integer_Address} is given, then integer expressions may
be used anywhere a value of type @code{System.Address} is required. be used anywhere a value of type @code{System.Address} is required.
The effect is to introduce an implicit unchecked conversion from the The effect is to introduce an implicit unchecked conversion from the
integer value to type @code{System.Address}. The following example integer value to type @code{System.Address}. The reverse case of using
compiles without errors: an address where an integer type is required is handled analogously.
The following example compiles without errors:
@smallexample @c ada @smallexample @c ada
pragma Allow_Integer_Address; pragma Allow_Integer_Address;
@ -1253,6 +1254,8 @@ package AddrAsInt is
m : Address := 16#4000#; m : Address := 16#4000#;
n : constant Address := 4000; n : constant Address := 4000;
p : constant Address := Address (X + Y); p : constant Address := Address (X + Y);
v : Integer := y'Address;
w : constant Integer := Integer (Y'Address);
type R is new integer; type R is new integer;
RR : R := 1000; RR : R := 1000;
Z : Integer; Z : Integer;

7
gcc/ada/par-ch8.adb
View File

@ -113,7 +113,12 @@ package body Ch8 is
Error_Msg_Ada_2012_Feature ("|`USE ALL TYPE`", Token_Ptr); Error_Msg_Ada_2012_Feature ("|`USE ALL TYPE`", Token_Ptr);
All_Present := True; All_Present := True;
Scan; -- past ALL 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; All_Present := False;
end if; end if;

5
gcc/ada/s-osinte-linux.ads
View File

@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -589,7 +589,8 @@ private
for struct_sigaction use record for struct_sigaction use record
sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1; sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
sa_mask at Linux.sa_mask_pos range 0 .. 1023; 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; end record;
-- We intentionally leave sa_restorer unspecified and let the compiler -- We intentionally leave sa_restorer unspecified and let the compiler
-- append it after the last field, so disable corresponding warning. -- append it after the last field, so disable corresponding warning.

87
gcc/ada/sem_res.adb
View File

@ -2612,30 +2612,36 @@ package body Sem_Res is
end; end;
end if; end if;
-- If an error message was issued already, Found got reset to -- Looks like we have a type error, but check for special case
-- True, so if it is still False, issue standard Wrong_Type msg. -- 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 if Allow_Integer_Address then
-- with the configuration pragma Allow_Integer_Address active. if (Is_RTE (Typ, RE_Address)
and then Is_Integer_Type (Etype (N)))
if Allow_Integer_Address or else
and then Is_RTE (Typ, RE_Address) (Is_Integer_Type (Typ)
and then Is_Integer_Type (Etype (N)) and then Is_RTE (Etype (N), RE_Address))
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
then 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 declare
Subp_Name : Node_Id; Subp_Name : Node_Id;
begin begin
if Is_Entity_Name (Name (N)) then if Is_Entity_Name (Name (N)) then
Subp_Name := Name (N); Subp_Name := Name (N);
@ -11085,6 +11091,23 @@ package body Sem_Res is
end; end;
end if; 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 -- 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 -- expression has an ancestor in a parent unit, in which case it
-- belongs to its derivation class even if the ancestor is private. -- belongs to its derivation class even if the ancestor is private.
@ -11094,7 +11117,7 @@ package body Sem_Res is
-- Numeric types -- 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 -- A universal fixed expression can be converted to any numeric type
@ -11120,11 +11143,11 @@ package body Sem_Res is
else else
return Conversion_Check return Conversion_Check
(Is_Numeric_Type (Opnd_Type) (Is_Numeric_Type (Opnd_Type)
or else or else
(Present (Inc_Ancestor) (Present (Inc_Ancestor)
and then Is_Numeric_Type (Inc_Ancestor)), and then Is_Numeric_Type (Inc_Ancestor)),
"illegal operand for numeric conversion"); "illegal operand for numeric conversion");
end if; end if;
-- Array types -- Array types
@ -11637,18 +11660,6 @@ package body Sem_Res is
("add ALL to }!", N, Target_Type); ("add ALL to }!", N, Target_Type);
return False; 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 -- Here we have a real conversion error
else else