[multiple changes]
2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> * sem_prag.adb (Analyze_Pragma, (Check_Mode_Restriction_In_Function): Correct error message format. 2013-04-12 Robert Dewar <dewar@adacore.com> * sem_attr.adb: Minor reformatting. 2013-04-12 Ed Schonberg <schonberg@adacore.com> * sem_elab.adb (Within_Elaborate_All): Do not examine a context item that has not been analyzed, because the unit may have errors, or the context item may come from a proper unit inserted at the point of a stub and not analyzed yet. 2013-04-12 Thomas Quinot <quinot@adacore.com> * gnat1drv.adb, repinfo.adb, repinfo.ads (Repinfo.List_Array_Info, List_Record_Info): Also include scalar storage order information in output. 2013-04-12 Yannick Moy <moy@adacore.com> * sem_ch6.adb (Process_Contract_Cases): Update code to apply to Contract_Cases instead of Contract_Case pragma. From-SVN: r197906
This commit is contained in:
parent
2eb8701742
commit
d9f8616ee4
@ -1,3 +1,30 @@
|
||||
2013-04-12 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* sem_prag.adb (Analyze_Pragma, (Check_Mode_Restriction_In_Function):
|
||||
Correct error message format.
|
||||
|
||||
2013-04-12 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_attr.adb: Minor reformatting.
|
||||
|
||||
2013-04-12 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_elab.adb (Within_Elaborate_All): Do not examine a context
|
||||
item that has not been analyzed, because the unit may have errors,
|
||||
or the context item may come from a proper unit inserted at the
|
||||
point of a stub and not analyzed yet.
|
||||
|
||||
2013-04-12 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* gnat1drv.adb, repinfo.adb, repinfo.ads (Repinfo.List_Array_Info,
|
||||
List_Record_Info): Also include scalar storage order information in
|
||||
output.
|
||||
|
||||
2013-04-12 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* sem_ch6.adb (Process_Contract_Cases): Update code to apply to
|
||||
Contract_Cases instead of Contract_Case pragma.
|
||||
|
||||
2013-04-12 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* a-cfdlli.ads, g-socket.adb, s-fileio.adb: Minor reformatting.
|
||||
|
@ -1259,7 +1259,7 @@ begin
|
||||
|
||||
Errout.Finalize (Last_Call => True);
|
||||
Errout.Output_Messages;
|
||||
List_Rep_Info;
|
||||
List_Rep_Info (Ttypes.Bytes_Big_Endian);
|
||||
List_Inlining_Info;
|
||||
|
||||
-- Only write the library if the backend did not generate any error
|
||||
|
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2011, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-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- --
|
||||
@ -29,22 +29,23 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Alloc; use Alloc;
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Debug; use Debug;
|
||||
with Einfo; use Einfo;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Opt; use Opt;
|
||||
with Output; use Output;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Table; use Table;
|
||||
with Uname; use Uname;
|
||||
with Urealp; use Urealp;
|
||||
with Alloc; use Alloc;
|
||||
with Atree; use Atree;
|
||||
with Casing; use Casing;
|
||||
with Debug; use Debug;
|
||||
with Einfo; use Einfo;
|
||||
with Lib; use Lib;
|
||||
with Namet; use Namet;
|
||||
with Opt; use Opt;
|
||||
with Output; use Output;
|
||||
with Sem_Aux; use Sem_Aux;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Table; use Table;
|
||||
with Uname; use Uname;
|
||||
with Urealp; use Urealp;
|
||||
|
||||
with Ada.Unchecked_Conversion;
|
||||
|
||||
@ -133,7 +134,7 @@ package body Repinfo is
|
||||
-- Called before outputting anything for an entity. Ensures that
|
||||
-- a blank line precedes the output for a particular entity.
|
||||
|
||||
procedure List_Entities (Ent : Entity_Id);
|
||||
procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
|
||||
-- This procedure lists the entities associated with the entity E, starting
|
||||
-- with the First_Entity and using the Next_Entity link. If a nested
|
||||
-- package is found, entities within the package are recursively processed.
|
||||
@ -142,7 +143,7 @@ package body Repinfo is
|
||||
-- List name of entity Ent in appropriate case. The name is listed with
|
||||
-- full qualification up to but not including the compilation unit name.
|
||||
|
||||
procedure List_Array_Info (Ent : Entity_Id);
|
||||
procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
|
||||
-- List representation info for array type Ent
|
||||
|
||||
procedure List_Mechanisms (Ent : Entity_Id);
|
||||
@ -152,9 +153,14 @@ package body Repinfo is
|
||||
procedure List_Object_Info (Ent : Entity_Id);
|
||||
-- List representation info for object Ent
|
||||
|
||||
procedure List_Record_Info (Ent : Entity_Id);
|
||||
procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
|
||||
-- List representation info for record type Ent
|
||||
|
||||
procedure List_Scalar_Storage_Order
|
||||
(Ent : Entity_Id;
|
||||
Bytes_Big_Endian : Boolean);
|
||||
-- List scalar storage order information for record or array type Ent
|
||||
|
||||
procedure List_Type_Info (Ent : Entity_Id);
|
||||
-- List type info for type Ent
|
||||
|
||||
@ -286,7 +292,7 @@ package body Repinfo is
|
||||
-- List_Array_Info --
|
||||
----------------------
|
||||
|
||||
procedure List_Array_Info (Ent : Entity_Id) is
|
||||
procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
|
||||
begin
|
||||
List_Type_Info (Ent);
|
||||
Write_Str ("for ");
|
||||
@ -294,13 +300,15 @@ package body Repinfo is
|
||||
Write_Str ("'Component_Size use ");
|
||||
Write_Val (Component_Size (Ent));
|
||||
Write_Line (";");
|
||||
|
||||
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
|
||||
end List_Array_Info;
|
||||
|
||||
-------------------
|
||||
-- List_Entities --
|
||||
-------------------
|
||||
|
||||
procedure List_Entities (Ent : Entity_Id) is
|
||||
procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
|
||||
Body_E : Entity_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
@ -379,12 +387,12 @@ package body Repinfo is
|
||||
|
||||
elsif Is_Record_Type (E) then
|
||||
if List_Representation_Info >= 1 then
|
||||
List_Record_Info (E);
|
||||
List_Record_Info (E, Bytes_Big_Endian);
|
||||
end if;
|
||||
|
||||
elsif Is_Array_Type (E) then
|
||||
if List_Representation_Info >= 1 then
|
||||
List_Array_Info (E);
|
||||
List_Array_Info (E, Bytes_Big_Endian);
|
||||
end if;
|
||||
|
||||
elsif Is_Type (E) then
|
||||
@ -411,7 +419,7 @@ package body Repinfo is
|
||||
|
||||
if Ekind (E) = E_Package then
|
||||
if No (Renamed_Object (E)) then
|
||||
List_Entities (E);
|
||||
List_Entities (E, Bytes_Big_Endian);
|
||||
end if;
|
||||
|
||||
-- Recurse into bodies
|
||||
@ -428,12 +436,12 @@ package body Repinfo is
|
||||
or else
|
||||
Ekind (E) = E_Protected_Body
|
||||
then
|
||||
List_Entities (E);
|
||||
List_Entities (E, Bytes_Big_Endian);
|
||||
|
||||
-- Recurse into blocks
|
||||
|
||||
elsif Ekind (E) = E_Block then
|
||||
List_Entities (E);
|
||||
List_Entities (E, Bytes_Big_Endian);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
@ -461,7 +469,7 @@ package body Repinfo is
|
||||
and then
|
||||
Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
|
||||
then
|
||||
List_Entities (Body_E);
|
||||
List_Entities (Body_E, Bytes_Big_Endian);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
@ -779,7 +787,7 @@ package body Repinfo is
|
||||
-- List_Record_Info --
|
||||
----------------------
|
||||
|
||||
procedure List_Record_Info (Ent : Entity_Id) is
|
||||
procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
|
||||
Comp : Entity_Id;
|
||||
Cfbit : Uint;
|
||||
Sunit : Uint;
|
||||
@ -963,13 +971,15 @@ package body Repinfo is
|
||||
end loop;
|
||||
|
||||
Write_Line ("end record;");
|
||||
|
||||
List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
|
||||
end List_Record_Info;
|
||||
|
||||
-------------------
|
||||
-- List_Rep_Info --
|
||||
-------------------
|
||||
|
||||
procedure List_Rep_Info is
|
||||
procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
|
||||
Col : Nat;
|
||||
|
||||
begin
|
||||
@ -994,7 +1004,7 @@ package body Repinfo is
|
||||
end loop;
|
||||
|
||||
Write_Eol;
|
||||
List_Entities (Cunit_Entity (U));
|
||||
List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
|
||||
|
||||
-- List representation information to file
|
||||
|
||||
@ -1002,7 +1012,7 @@ package body Repinfo is
|
||||
Create_Repinfo_File_Access.all
|
||||
(Get_Name_String (File_Name (Source_Index (U))));
|
||||
Set_Special_Output (Write_Info_Line'Access);
|
||||
List_Entities (Cunit_Entity (U));
|
||||
List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
|
||||
Set_Special_Output (null);
|
||||
Close_Repinfo_File_Access.all;
|
||||
end if;
|
||||
@ -1011,6 +1021,49 @@ package body Repinfo is
|
||||
end if;
|
||||
end List_Rep_Info;
|
||||
|
||||
-------------------------------
|
||||
-- List_Scalar_Storage_Order --
|
||||
-------------------------------
|
||||
|
||||
procedure List_Scalar_Storage_Order
|
||||
(Ent : Entity_Id;
|
||||
Bytes_Big_Endian : Boolean)
|
||||
is
|
||||
procedure List_Attr (Attr_Name : String);
|
||||
-- Show attribute definition clause for Attr_Name
|
||||
|
||||
---------------
|
||||
-- List_Attr --
|
||||
---------------
|
||||
|
||||
procedure List_Attr (Attr_Name : String) is
|
||||
begin
|
||||
Write_Str ("for ");
|
||||
List_Name (Ent);
|
||||
Write_Str ("'" & Attr_Name & " use System.");
|
||||
if Bytes_Big_Endian xor Reverse_Storage_Order (Ent) then
|
||||
Write_Str ("High");
|
||||
else
|
||||
Write_Str ("Low");
|
||||
end if;
|
||||
Write_Line ("_Order_First;");
|
||||
end List_Attr;
|
||||
|
||||
-- Start of processing for List_Scalar_Storage_Order
|
||||
|
||||
begin
|
||||
if Has_Rep_Item (Ent, Name_Scalar_Storage_Order) then
|
||||
|
||||
-- For a record type with explicitly specified scalar storage order,
|
||||
-- also display explicit Bit_Order.
|
||||
|
||||
if Is_Record_Type (Ent) then
|
||||
List_Attr ("Bit_Order");
|
||||
end if;
|
||||
List_Attr ("Scalar_Storage_Order");
|
||||
end if;
|
||||
end List_Scalar_Storage_Order;
|
||||
|
||||
--------------------
|
||||
-- List_Type_Info --
|
||||
--------------------
|
||||
|
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-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- --
|
||||
@ -283,8 +283,9 @@ package Repinfo is
|
||||
-- Compiler Interface --
|
||||
------------------------
|
||||
|
||||
procedure List_Rep_Info;
|
||||
-- Procedure to list representation information
|
||||
procedure List_Rep_Info (Bytes_Big_Endian : Boolean);
|
||||
-- Procedure to list representation information. Bytes_Big_Endian is the
|
||||
-- value from Ttypes (Repinfo cannot have a dependency on Ttypes).
|
||||
|
||||
procedure Tree_Write;
|
||||
-- Writes out internal tables to current tree file using the relevant
|
||||
|
@ -4314,8 +4314,8 @@ package body Sem_Attr is
|
||||
Arg := Parent (Arg);
|
||||
end loop;
|
||||
|
||||
-- At this point, Parent (Arg) should be a
|
||||
-- N_Component_Association. Attribute Old is only allowed in
|
||||
-- At this point, Parent (Arg) should be a component
|
||||
-- association. Attribute Result is only allowed in
|
||||
-- the expression part of this association.
|
||||
|
||||
if Nkind (Parent (Arg)) /= N_Component_Association
|
||||
@ -4731,9 +4731,9 @@ package body Sem_Attr is
|
||||
Arg := Parent (Arg);
|
||||
end loop;
|
||||
|
||||
-- At this point, Parent (Arg) should be a
|
||||
-- N_Component_Association. Attribute Result is only
|
||||
-- allowed in the expression part of this association.
|
||||
-- At this point, Parent (Arg) should be a component
|
||||
-- association. Attribute Result is only allowed in
|
||||
-- the expression part of this association.
|
||||
|
||||
if Nkind (Parent (Arg)) /= N_Component_Association
|
||||
or else Arg /= Expression (Parent (Arg))
|
||||
|
@ -7064,8 +7064,8 @@ package body Sem_Ch6 is
|
||||
-- Last non-trivial postcondition on the subprogram, or else Empty if
|
||||
-- either no non-trivial postcondition or only inherited postconditions.
|
||||
|
||||
Last_Contract_Case : Node_Id := Empty;
|
||||
-- Last non-trivial contract-case on the subprogram, or else Empty
|
||||
Last_Contract_Cases : Node_Id := Empty;
|
||||
-- Last non-trivial contract-cases on the subprogram, or else Empty
|
||||
|
||||
Attribute_Result_Mentioned : Boolean := False;
|
||||
-- Whether attribute 'Result is mentioned in a non-trivial postcondition
|
||||
@ -7204,8 +7204,10 @@ package body Sem_Ch6 is
|
||||
----------------------------
|
||||
|
||||
procedure Process_Contract_Cases (Spec : Node_Id) is
|
||||
Prag : Node_Id;
|
||||
Arg : Node_Id;
|
||||
Prag : Node_Id;
|
||||
Aggr : Node_Id;
|
||||
Conseq : Node_Id;
|
||||
Post_Case : Node_Id;
|
||||
|
||||
Ignored : Traverse_Final_Result;
|
||||
pragma Unreferenced (Ignored);
|
||||
@ -7213,42 +7215,47 @@ package body Sem_Ch6 is
|
||||
begin
|
||||
Prag := Spec_CTC_List (Contract (Spec));
|
||||
loop
|
||||
-- Retrieve the Ensures component of the contract-case, if any
|
||||
if Pragma_Name (Prag) = Name_Contract_Cases then
|
||||
|
||||
Arg := Get_Ensures_From_CTC_Pragma (Prag);
|
||||
Aggr := Expression (First
|
||||
(Pragma_Argument_Associations (Prag)));
|
||||
|
||||
-- Ignore trivial contract-case when Ensures component is "True"
|
||||
-- or "False".
|
||||
Post_Case := First (Component_Associations (Aggr));
|
||||
while Present (Post_Case) loop
|
||||
Conseq := Expression (Post_Case);
|
||||
|
||||
if Pragma_Name (Prag) = Name_Contract_Case
|
||||
and then not Is_Trivial_Post_Or_Ensures (Expression (Arg))
|
||||
then
|
||||
-- Since contract-cases are listed in reverse order, the first
|
||||
-- contract-case in the list is the last in the source.
|
||||
-- Ignore trivial contract-case when consequence is "True"
|
||||
-- or "False".
|
||||
|
||||
if No (Last_Contract_Case) then
|
||||
Last_Contract_Case := Prag;
|
||||
end if;
|
||||
if not Is_Trivial_Post_Or_Ensures (Conseq) then
|
||||
|
||||
-- For functions, look for presence of 'Result in Ensures
|
||||
Last_Contract_Cases := Prag;
|
||||
|
||||
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
|
||||
Ignored := Find_Attribute_Result (Arg);
|
||||
end if;
|
||||
-- For functions, look for presence of 'Result in
|
||||
-- consequence expression.
|
||||
|
||||
-- For each individual contract-case, look for presence
|
||||
-- of an expression that could be evaluated differently
|
||||
-- in post-state.
|
||||
if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
|
||||
Ignored := Find_Attribute_Result (Conseq);
|
||||
end if;
|
||||
|
||||
Post_State_Mentioned := False;
|
||||
Ignored := Find_Post_State (Arg);
|
||||
-- For each individual case, look for presence of an
|
||||
-- expression that could be evaluated differently in
|
||||
-- post-state.
|
||||
|
||||
if Post_State_Mentioned then
|
||||
No_Warning_On_Some_Postcondition := True;
|
||||
else
|
||||
Error_Msg_N
|
||||
("`Ensures` component refers only to pre-state??", Prag);
|
||||
end if;
|
||||
Post_State_Mentioned := False;
|
||||
Ignored := Find_Post_State (Conseq);
|
||||
|
||||
if Post_State_Mentioned then
|
||||
No_Warning_On_Some_Postcondition := True;
|
||||
else
|
||||
Error_Msg_N
|
||||
("contract case refers only to pre-state?T?",
|
||||
Conseq);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Next (Post_Case);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Prag := Next_Pragma (Prag);
|
||||
@ -7304,7 +7311,7 @@ package body Sem_Ch6 is
|
||||
No_Warning_On_Some_Postcondition := True;
|
||||
else
|
||||
Error_Msg_N
|
||||
("postcondition refers only to pre-state??", Prag);
|
||||
("postcondition refers only to pre-state?T?", Prag);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
@ -7352,12 +7359,12 @@ package body Sem_Ch6 is
|
||||
|
||||
if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
|
||||
and then (Present (Last_Postcondition)
|
||||
or else Present (Last_Contract_Case))
|
||||
or else Present (Last_Contract_Cases))
|
||||
and then not Attribute_Result_Mentioned
|
||||
and then No_Warning_On_Some_Postcondition
|
||||
then
|
||||
if Present (Last_Postcondition) then
|
||||
if Present (Last_Contract_Case) then
|
||||
if Present (Last_Contract_Cases) then
|
||||
Error_Msg_N
|
||||
("neither function postcondition nor "
|
||||
& "contract cases mention result?T?", Last_Postcondition);
|
||||
@ -7369,7 +7376,7 @@ package body Sem_Ch6 is
|
||||
end if;
|
||||
else
|
||||
Error_Msg_N
|
||||
("contract cases do not mention result?T?", Last_Contract_Case);
|
||||
("contract cases do not mention result?T?", Last_Contract_Cases);
|
||||
end if;
|
||||
end if;
|
||||
end Check_Subprogram_Contract;
|
||||
|
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1997-2012, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1997-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- --
|
||||
@ -3340,8 +3340,13 @@ package body Sem_Elab is
|
||||
and then Pragma_Name (Item) = Name_Elaborate_All
|
||||
then
|
||||
-- Return if some previous error on the pragma itself
|
||||
-- The pragma may be unanalyzed, because of a previous error,
|
||||
-- or if it is the context of a subunit, inherited by its
|
||||
-- parent.
|
||||
|
||||
if Error_Posted (Item) then
|
||||
if Error_Posted (Item)
|
||||
or else not Analyzed (Item)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
@ -6871,8 +6871,8 @@ package body Sem_Prag is
|
||||
-- declare additional states.
|
||||
|
||||
if Null_Seen then
|
||||
Error_Msg_Name_1 := Chars (Pack_Id);
|
||||
Error_Msg_N ("package % has null abstract state", State);
|
||||
Error_Msg_NE
|
||||
("package & has null abstract state", State, Pack_Id);
|
||||
|
||||
-- Null states appear as internally generated entities
|
||||
|
||||
@ -6885,9 +6885,9 @@ package body Sem_Prag is
|
||||
-- non-null states.
|
||||
|
||||
if Non_Null_Seen then
|
||||
Error_Msg_Name_1 := Chars (Pack_Id);
|
||||
Error_Msg_N
|
||||
("package % has non-null abstract state", State);
|
||||
Error_Msg_NE
|
||||
("package & has non-null abstract state",
|
||||
State, Pack_Id);
|
||||
end if;
|
||||
|
||||
-- Simple state declaration
|
||||
@ -11364,9 +11364,8 @@ package body Sem_Prag is
|
||||
procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
|
||||
begin
|
||||
if Ekind (Subp_Id) = E_Function then
|
||||
Error_Msg_NE
|
||||
("global mode & not applicable to functions",
|
||||
Mode, Mode);
|
||||
Error_Msg_N
|
||||
("global mode & not applicable to functions", Mode);
|
||||
end if;
|
||||
end Check_Mode_Restriction_In_Function;
|
||||
|
||||
|
Loading…
x
Reference in New Issue
Block a user