+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
-- 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;
-- (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),
-- 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,
-- 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;
-- 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;
-- 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;
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
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
-- 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)
-- 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;
-- 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
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;
(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);
-- 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;
-- --
-- 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- --
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,
-- --
-- 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- --
-- 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)
Ada_Tags,
Ada_Task_Identification,
Ada_Task_Termination,
+ Ada_Text_IO,
+ Ada_Wide_Text_IO,
+ Ada_Wide_Wide_Text_IO,
-- Children of Ada.Calendar
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
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,
-- --
-- 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- --
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))
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;
---------
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;
-----------
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;
----------------
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;
---------------------
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;
----------------
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;
---------------------
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;
---------------------
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
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.
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.
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!
projects / thirdparty / gcc.git / commitdiff
