layout.adb: Minor reformatting.
2014-05-21 Robert Dewar <dewar@adacore.com> * layout.adb: Minor reformatting. * sem_prag.adb (Analyze_Pragma, case Inspection_Point): Call dummy procedure ip. 2014-05-21 Robert Dewar <dewar@adacore.com> * restrict.ads (Implementation_Restriction): Add entry for No_Fixed_IO. * rtsfind.ads: Add entries for Fixed_IO and Decimal_IO in Ada.[Wide_[Wide_]Text_IO. * s-rident.ads (Restriction_Id): Add entry for No_Fixed_IO. * sem_attr.adb (Analyze_Attribute): Disallow fixed point types for Img, Image, Value, Wide_Image, Wide_Value, Wide_Wide_Image, Wide_Wide_Value if restriction No_Fixed_IO is set. * sem_util.adb (Set_Entity_Checks): Check restriction No_Fixed_IO. From-SVN: r210710
This commit is contained in:
Robert Dewar
Arnaud Charlet
parent
ee6208f2d5
commit
0688dac826
|
|
@ -1,3 +1,21 @@
|
|||
2014-05-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* layout.adb: Minor reformatting.
|
||||
* sem_prag.adb (Analyze_Pragma, case Inspection_Point): Call
|
||||
dummy procedure ip.
|
||||
|
||||
2014-05-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* restrict.ads (Implementation_Restriction): Add entry for
|
||||
No_Fixed_IO.
|
||||
* rtsfind.ads: Add entries for Fixed_IO and Decimal_IO in
|
||||
Ada.[Wide_[Wide_]Text_IO.
|
||||
* s-rident.ads (Restriction_Id): Add entry for No_Fixed_IO.
|
||||
* sem_attr.adb (Analyze_Attribute): Disallow fixed point types
|
||||
for Img, Image, Value, Wide_Image, Wide_Value, Wide_Wide_Image,
|
||||
Wide_Wide_Value if restriction No_Fixed_IO is set.
|
||||
* sem_util.adb (Set_Entity_Checks): Check restriction No_Fixed_IO.
|
||||
|
||||
2014-05-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* gnatcmd.adb: Minor error msg changes (no upper case letter
|
||||
|
|
|
|||
|
|
@ -270,8 +270,7 @@ package body Layout is
|
|||
-- the Integer base type, but it is safe to reduce it to 1 at this
|
||||
-- stage, since we will only be loading a single storage unit.
|
||||
|
||||
if Is_Discrete_Type (Etype (E))
|
||||
and then not Has_Alignment_Clause (E)
|
||||
if Is_Discrete_Type (Etype (E)) and then not Has_Alignment_Clause (E)
|
||||
then
|
||||
loop
|
||||
Abits := Abits / 2;
|
||||
|
|
@ -363,13 +362,13 @@ package body Layout is
|
|||
|
||||
-- (E - C1) + C2 = E - (C1 - C2)
|
||||
|
||||
-- If the type is unsigned, then only do the optimization if
|
||||
-- C1 >= C2, to avoid creating a negative literal that can't be
|
||||
-- used with the unsigned type.
|
||||
-- If the type is unsigned then only do the optimization if C1 >= C2,
|
||||
-- to avoid creating a negative literal that can't be used with the
|
||||
-- unsigned type.
|
||||
|
||||
elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L))
|
||||
and then (not Is_Unsigned_Type (Etype (Sinfo.Right_Opnd (L)))
|
||||
or else Expr_Value (Sinfo.Right_Opnd (L)) >= R)
|
||||
or else Expr_Value (Sinfo.Right_Opnd (L)) >= R)
|
||||
then
|
||||
Rewrite_Integer
|
||||
(Sinfo.Right_Opnd (L),
|
||||
|
|
@ -626,8 +625,8 @@ package body Layout is
|
|||
-- parameter rather than passing "V" directly.
|
||||
|
||||
if Present (Comp)
|
||||
and then Base_Type (Etype (Comp))
|
||||
= Base_Type (Etype (First_Formal (Ent)))
|
||||
and then Base_Type (Etype (Comp)) =
|
||||
Base_Type (Etype (First_Formal (Ent)))
|
||||
then
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
|
|
@ -755,7 +754,8 @@ package body Layout is
|
|||
-- Value of the current subscript range is statically known
|
||||
|
||||
if Compile_Time_Known_Value (Lo)
|
||||
and then Compile_Time_Known_Value (Hi)
|
||||
and then
|
||||
Compile_Time_Known_Value (Hi)
|
||||
then
|
||||
S := Expr_Value (Hi) - Expr_Value (Lo) + 1;
|
||||
|
||||
|
|
@ -1092,7 +1092,8 @@ package body Layout is
|
|||
-- Value of the current subscript range is statically known
|
||||
|
||||
if Compile_Time_Known_Value (Lo)
|
||||
and then Compile_Time_Known_Value (Hi)
|
||||
and then
|
||||
Compile_Time_Known_Value (Hi)
|
||||
then
|
||||
S := Expr_Value (Hi) - Expr_Value (Lo) + 1;
|
||||
|
||||
|
|
@ -1388,9 +1389,7 @@ package body Layout is
|
|||
-- not set by an explicit Object_Size attribute clause, then we reset
|
||||
-- the Esize to unknown, since we really don't know it.
|
||||
|
||||
if Unknown_Alignment (E)
|
||||
and then not Has_Size_Clause (E)
|
||||
then
|
||||
if Unknown_Alignment (E) and then not Has_Size_Clause (E) then
|
||||
Set_Esize (E, Uint_0);
|
||||
end if;
|
||||
end Layout_Object;
|
||||
|
|
@ -2512,12 +2511,12 @@ package body Layout is
|
|||
elsif AAMP_On_Target
|
||||
and then
|
||||
((Ekind (E) = E_Access_Subprogram_Type
|
||||
and then Present (Enclosing_Subprogram (E)))
|
||||
or else
|
||||
(Ekind (E) = E_Anonymous_Access_Subprogram_Type
|
||||
and then
|
||||
(not Is_Local_Anonymous_Access (E)
|
||||
or else Present (Enclosing_Subprogram (E)))))
|
||||
and then Present (Enclosing_Subprogram (E)))
|
||||
or else
|
||||
(Ekind (E) = E_Anonymous_Access_Subprogram_Type
|
||||
and then
|
||||
(not Is_Local_Anonymous_Access (E)
|
||||
or else Present (Enclosing_Subprogram (E)))))
|
||||
then
|
||||
Init_Size (E, 2 * System_Address_Size);
|
||||
else
|
||||
|
|
@ -2541,7 +2540,7 @@ package body Layout is
|
|||
|
||||
if Opt.True_VMS_Target
|
||||
and then (Convention (E) = Convention_C
|
||||
or else
|
||||
or else
|
||||
Convention (E) = Convention_CPP)
|
||||
and then No (Get_Attribute_Definition_Clause (E, Attribute_Size))
|
||||
and then Esize (E) = 64
|
||||
|
|
@ -2653,14 +2652,12 @@ package body Layout is
|
|||
-- component type is known and is a small power of 2 (8, 16, 32, 64),
|
||||
-- since this is what will always be used.
|
||||
|
||||
if Ekind (E) = E_Array_Type
|
||||
and then Unknown_Component_Size (E)
|
||||
then
|
||||
if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then
|
||||
declare
|
||||
CT : constant Entity_Id := Component_Type (E);
|
||||
|
||||
begin
|
||||
-- For some reasons, access types can cause trouble, So let's
|
||||
-- For some reason, access types can cause trouble, So let's
|
||||
-- just do this for scalar types ???
|
||||
|
||||
if Present (CT)
|
||||
|
|
@ -2700,9 +2697,7 @@ package body Layout is
|
|||
-- For these types, we set a corresponding alignment matching
|
||||
-- the size if possible, or as large as possible if not.
|
||||
|
||||
if Convention (E) = Convention_Ada
|
||||
and then not Debug_Flag_Q
|
||||
then
|
||||
if Convention (E) = Convention_Ada and then not Debug_Flag_Q then
|
||||
Set_Composite_Alignment (E);
|
||||
end if;
|
||||
|
||||
|
|
@ -2724,9 +2719,7 @@ package body Layout is
|
|||
-- arrays when passed to subprogram parameters (see special test
|
||||
-- in Exp_Ch6.Expand_Actuals).
|
||||
|
||||
if not Is_Packed (E)
|
||||
and then Unknown_Alignment (E)
|
||||
then
|
||||
if not Is_Packed (E) and then Unknown_Alignment (E) then
|
||||
if Known_Static_Component_Size (E)
|
||||
and then Component_Size (E) = 1
|
||||
then
|
||||
|
|
@ -2989,12 +2982,8 @@ package body Layout is
|
|||
|
||||
if Known_Static_Esize (E) then
|
||||
Siz := Esize (E);
|
||||
|
||||
elsif Unknown_Esize (E)
|
||||
and then Known_Static_RM_Size (E)
|
||||
then
|
||||
elsif Unknown_Esize (E) and then Known_Static_RM_Size (E) then
|
||||
Siz := RM_Size (E);
|
||||
|
||||
else
|
||||
return;
|
||||
end if;
|
||||
|
|
@ -3102,7 +3091,7 @@ package body Layout is
|
|||
(Unknown_Esize (Comp)
|
||||
or else (Known_Static_Esize (Comp)
|
||||
and then
|
||||
Esize (Comp) =
|
||||
Esize (Comp) =
|
||||
Calign * System_Storage_Unit))
|
||||
then
|
||||
Align := UI_To_Int (Calign);
|
||||
|
|
@ -3194,9 +3183,7 @@ package body Layout is
|
|||
-- For access types, do not set the alignment if the size is less than
|
||||
-- the allowed minimum size. This avoids cascaded error messages.
|
||||
|
||||
elsif Is_Access_Type (E)
|
||||
and then Esize (E) < System_Address_Size
|
||||
then
|
||||
elsif Is_Access_Type (E) and then Esize (E) < System_Address_Size then
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
|
|
@ -120,6 +120,7 @@ package Restrict is
|
|||
No_Exception_Propagation => True,
|
||||
No_Exception_Registration => True,
|
||||
No_Finalization => True,
|
||||
No_Fixed_IO => True,
|
||||
No_Implementation_Attributes => True,
|
||||
No_Implementation_Pragmas => True,
|
||||
No_Implicit_Conditionals => True,
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
|
|
@ -108,8 +108,9 @@ package Rtsfind is
|
|||
-- ambiguities).
|
||||
|
||||
type RTU_Id is (
|
||||
-- Runtime packages, for list of accessible entities in each
|
||||
-- package see declarations in the runtime entity table below.
|
||||
|
||||
-- Runtime packages, for list of accessible entities in each package,
|
||||
-- see declarations in the runtime entity table below.
|
||||
|
||||
RTU_Null,
|
||||
-- Used as a null entry (will cause an error if referenced)
|
||||
|
|
@ -132,6 +133,9 @@ package Rtsfind is
|
|||
Ada_Tags,
|
||||
Ada_Task_Identification,
|
||||
Ada_Task_Termination,
|
||||
Ada_Text_IO,
|
||||
Ada_Wide_Text_IO,
|
||||
Ada_Wide_Wide_Text_IO,
|
||||
|
||||
-- Children of Ada.Calendar
|
||||
|
||||
|
|
@ -701,6 +705,15 @@ package Rtsfind is
|
|||
RE_Current_Task, -- Ada.Task_Identification
|
||||
RO_AT_Task_Id, -- Ada.Task_Identification
|
||||
|
||||
RE_Decimal_IO, -- Ada.Text_IO
|
||||
RE_Fixed_IO, -- Ada.Text_IO
|
||||
|
||||
RO_WT_Decimal_IO, -- Ada.Wide_Text_IO
|
||||
RO_WT_Fixed_IO, -- Ada.Wide_Text_IO
|
||||
|
||||
RO_WW_Decimal_IO, -- Ada.Wide_Wide_Text_IO
|
||||
RO_WW_Fixed_IO, -- Ada.Wide_Wide_Text_IO
|
||||
|
||||
RE_Integer_8, -- Interfaces
|
||||
RE_Integer_16, -- Interfaces
|
||||
RE_Integer_32, -- Interfaces
|
||||
|
|
@ -1973,6 +1986,15 @@ package Rtsfind is
|
|||
RE_Current_Task => Ada_Task_Identification,
|
||||
RO_AT_Task_Id => Ada_Task_Identification,
|
||||
|
||||
RE_Decimal_IO => Ada_Text_IO,
|
||||
RE_Fixed_IO => Ada_Text_IO,
|
||||
|
||||
RO_WT_Decimal_IO => Ada_Wide_Text_IO,
|
||||
RO_WT_Fixed_IO => Ada_Wide_Text_IO,
|
||||
|
||||
RO_WW_Decimal_IO => Ada_Wide_Wide_Text_IO,
|
||||
RO_WW_Fixed_IO => Ada_Wide_Wide_Text_IO,
|
||||
|
||||
RE_Integer_8 => Interfaces,
|
||||
RE_Integer_16 => Interfaces,
|
||||
RE_Integer_32 => Interfaces,
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2013, 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- --
|
||||
|
|
@ -112,6 +112,7 @@ package System.Rident is
|
|||
No_Exception_Registration, -- GNAT
|
||||
No_Exceptions, -- (RM H.4(12))
|
||||
No_Finalization, -- GNAT
|
||||
No_Fixed_IO, -- GNAT
|
||||
No_Fixed_Point, -- (RM H.4(15))
|
||||
No_Floating_Point, -- (RM H.4(14))
|
||||
No_IO, -- (RM H.4(20))
|
||||
|
|
|
|||
|
|
@ -3627,6 +3627,16 @@ package body Sem_Attr is
|
|||
Resolve (E1, P_Base_Type);
|
||||
Check_Enum_Image;
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
|
||||
-- to avoid giving a duplicate message for Img expanded into Image.
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Comes_From_Source (N)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Image;
|
||||
|
||||
---------
|
||||
|
|
@ -3646,6 +3656,14 @@ package body Sem_Attr is
|
|||
end if;
|
||||
|
||||
Check_Enum_Image;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Img;
|
||||
|
||||
-----------
|
||||
|
|
@ -6458,6 +6476,14 @@ package body Sem_Attr is
|
|||
|
||||
Set_Etype (N, P_Base_Type);
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Value;
|
||||
|
||||
----------------
|
||||
|
|
@ -6498,6 +6524,14 @@ package body Sem_Attr is
|
|||
Check_E1;
|
||||
Resolve (E1, P_Base_Type);
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Wide_Image;
|
||||
|
||||
---------------------
|
||||
|
|
@ -6511,6 +6545,14 @@ package body Sem_Attr is
|
|||
Check_E1;
|
||||
Resolve (E1, P_Base_Type);
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Wide_Wide_Image;
|
||||
|
||||
----------------
|
||||
|
|
@ -6528,6 +6570,14 @@ package body Sem_Attr is
|
|||
|
||||
Set_Etype (N, P_Type);
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Wide_Value;
|
||||
|
||||
---------------------
|
||||
|
|
@ -6544,6 +6594,14 @@ package body Sem_Attr is
|
|||
|
||||
Set_Etype (N, P_Type);
|
||||
Validate_Non_Static_Attribute_Function_Call;
|
||||
|
||||
-- Check restriction No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then Is_Fixed_Point_Type (P_Type)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, P);
|
||||
end if;
|
||||
end Wide_Wide_Value;
|
||||
|
||||
---------------------
|
||||
|
|
|
|||
|
|
@ -15327,7 +15327,26 @@ package body Sem_Prag is
|
|||
Arg : Node_Id;
|
||||
Exp : Node_Id;
|
||||
|
||||
procedure ip;
|
||||
-- A dummy procedure called when pragma Inspection_Point is
|
||||
-- analyzed. This is just to help debugging the front end. If
|
||||
-- a pragma Inspection_Point is added to a source program, then
|
||||
-- breaking on ip will get you to that point in the program.
|
||||
|
||||
--------
|
||||
-- ip --
|
||||
--------
|
||||
|
||||
procedure ip is
|
||||
begin
|
||||
null;
|
||||
end ip;
|
||||
|
||||
-- Start of processing for Inspection_Point
|
||||
|
||||
begin
|
||||
ip;
|
||||
|
||||
if Arg_Count > 0 then
|
||||
Arg := Arg1;
|
||||
loop
|
||||
|
|
|
|||
|
|
@ -15867,12 +15867,6 @@ package body Sem_Util is
|
|||
|
||||
Set_Entity (N, Val);
|
||||
|
||||
-- Remaining checks are only done on source nodes
|
||||
|
||||
if not Comes_From_Source (N) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- The node to post on is the selector in the case of an expanded name,
|
||||
-- and otherwise the node itself.
|
||||
|
||||
|
|
@ -15882,6 +15876,44 @@ package body Sem_Util is
|
|||
Post_Node := N;
|
||||
end if;
|
||||
|
||||
-- Check for violation of No_Fixed_IO
|
||||
|
||||
if Restriction_Check_Required (No_Fixed_IO)
|
||||
and then
|
||||
((RTU_Loaded (Ada_Text_IO)
|
||||
and then (Is_RTE (Val, RE_Decimal_IO)
|
||||
or else
|
||||
Is_RTE (Val, RE_Fixed_IO)))
|
||||
|
||||
or else
|
||||
(RTU_Loaded (Ada_Wide_Text_IO)
|
||||
and then (Is_RTE (Val, RO_WT_Decimal_IO)
|
||||
or else
|
||||
Is_RTE (Val, RO_WT_Fixed_IO)))
|
||||
|
||||
or else
|
||||
(RTU_Loaded (Ada_Wide_Wide_Text_IO)
|
||||
and then (Is_RTE (Val, RO_WW_Decimal_IO)
|
||||
or else
|
||||
Is_RTE (Val, RO_WW_Fixed_IO))))
|
||||
|
||||
-- A special extra check, don't complain about a reference from within
|
||||
-- the Ada.Interrupts package itself!
|
||||
|
||||
and then not In_Same_Extended_Unit (N, Val)
|
||||
then
|
||||
Check_Restriction (No_Fixed_IO, Post_Node);
|
||||
end if;
|
||||
|
||||
-- Remaining checks are only done on source nodes. Note that we test
|
||||
-- for violation of No_Fixed_IO even on non-source nodes, because the
|
||||
-- cases for checking violations of this restriction are instantiations
|
||||
-- where the refernece in the instance has Comes_From_Source False.
|
||||
|
||||
if not Comes_From_Source (N) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Check for violation of No_Abort_Statements, which is triggered by
|
||||
-- call to Ada.Task_Identification.Abort_Task.
|
||||
|
||||
|
|
@ -15907,6 +15939,7 @@ package body Sem_Util is
|
|||
Is_RTE (Val, RE_Exchange_Handler) or else
|
||||
Is_RTE (Val, RE_Detach_Handler) or else
|
||||
Is_RTE (Val, RE_Reference))
|
||||
|
||||
-- A special extra check, don't complain about a reference from within
|
||||
-- the Ada.Interrupts package itself!
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue