+2017-09-06 Yannick Moy <moy@adacore.com>
+
+ * inline.adb: Add comments to Can_Be_Inlined_In_GNATprove_Mode.
+
+2017-09-06 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): The C backend
+ cannot handle a type conversion of an array as an aggregate
+ component.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * g-comlin.adb (Try_Help): Remove ".exe" so we
+ get the same results on windows and unix.
+
+2017-09-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_imgv.adb (Expand_Image_Attribute),
+ (Expand_Wide_Image_Attribute), (Expand_Wide_Wide_Image_Attribute):
+ Added case to handle new-style 'Image expansion
+ (Rewrite_Object_Image): Moved from exp_attr.adb
+ * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image
+ attribute cases so that the relevant subprograms in exp_imgv.adb
+ handle all expansion.
+ (Rewrite_Object_Reference_Image): Moved to exp_imgv.adb
+ * sem_attr.adb (Analyze_Attribute): Modified Image attribute
+ cases to call common function Analyze_Image_Attribute.
+ (Analyze_Image_Attribute): Created as a common path for all
+ image attributes (Check_Object_Reference_Image): Removed
+ * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object):
+ Removed and refactored into Is_Object_Image (Is_Object_Image):
+ Created as a replacement for Is_Image_Applied_To_Object
+
2017-09-06 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Analyze_Depends_In_Decl_Part): Add continuation
then
Static_Components := False;
return True;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (Expr_Q) = N_Type_Conversion
+ and then Is_Array_Type (Etype (Expr_Q))
+ then
+ Static_Components := False;
+ return True;
end if;
if Is_Elementary_Type (Etype (Expr_Q)) then
Exprs : constant List_Id := Expressions (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
- procedure Rewrite_Object_Reference_Image
- (Name : Name_Id;
- Str_Typ : Entity_Id);
- -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
- -- reference as an attribute applied to a type.
-
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
-- Rewrites a stream attribute for Read, Write or Output with the
-- procedure call. Pname is the entity for the procedure to call.
- ------------------------------------
- -- Rewrite_Object_Reference_Image --
- ------------------------------------
-
- procedure Rewrite_Object_Reference_Image
- (Name : Name_Id;
- Str_Typ : Entity_Id)
- is
- begin
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name,
- Expressions => New_List (Relocate_Node (Pref))));
-
- Analyze_And_Resolve (N, Str_Typ);
- end Rewrite_Object_Reference_Image;
-
------------------------------
-- Rewrite_Stream_Proc_Call --
------------------------------
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
- if Is_Image_Applied_To_Object (Pref, Ptyp) then
- Rewrite_Object_Reference_Image (Name_Image, Standard_String);
- return;
- end if;
-
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
- Rewrite_Object_Reference_Image (Name_Image, Standard_String);
+ Exp_Imgv.Expand_Image_Attribute (N);
-----------
-- Input --
-- Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Image =>
- if Is_Image_Applied_To_Object (Pref, Ptyp) then
- Rewrite_Object_Reference_Image
- (Name_Wide_Image, Standard_Wide_String);
- return;
- end if;
-
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Image =>
- if Is_Image_Applied_To_Object (Pref, Ptyp) then
- Rewrite_Object_Reference_Image
- (Name_Wide_Wide_Image, Standard_Wide_Wide_String);
- return;
- end if;
-
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
-- Shouldn't this be in einfo.adb or sem_aux.adb???
+ procedure Rewrite_Object_Image
+ (N : Node_Id;
+ Pref : Entity_Id;
+ Attr_Name : Name_Id;
+ Str_Typ : Entity_Id);
+ -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
+ -- reference as an attribute applied to a type. N denotes the node to be
+ -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
+ -- and Str_Typ specify which specific string type and 'Image attribute to
+ -- apply (e.g. Name_Wide_Image and Standard_Wide_String).
+
------------------------------------
-- Build_Enumeration_Image_Tables --
------------------------------------
Loc : constant Source_Ptr := Sloc (N);
Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
- Ptyp : constant Entity_Id := Entity (Pref);
- Rtyp : constant Entity_Id := Root_Type (Ptyp);
Expr : constant Node_Id := Relocate_Node (First (Exprs));
Imid : RE_Id;
+ Ptyp : Entity_Id;
+ Rtyp : Entity_Id;
Tent : Entity_Id;
Ttyp : Entity_Id;
Proc_Ent : Entity_Id;
Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
+ return;
+ end if;
+
+ Ptyp := Entity (Pref);
+ Rtyp := Root_Type (Ptyp);
+
-- Build declarations of Snn and Pnn to be inserted
Ins_List := New_List (
procedure Expand_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
- Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
- Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Pref : constant Entity_Id := Prefix (N);
+ Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Rtyp : Entity_Id;
begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
+ return;
+ end if;
+
+ Rtyp := Root_Type (Entity (Pref));
+
Insert_Actions (N, New_List (
-- Rnn : Wide_String (1 .. base_typ'Width);
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
-
- Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
- Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Pref : constant Entity_Id := Prefix (N);
+ Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Rtyp : Entity_Id;
begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image
+ (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
+ return;
+ end if;
+
+ Rtyp := Root_Type (Entity (Pref));
+
Insert_Actions (N, New_List (
-- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
end Has_Decimal_Small;
+ --------------------------
+ -- Rewrite_Object_Image --
+ --------------------------
+
+ procedure Rewrite_Object_Image
+ (N : Node_Id;
+ Pref : Entity_Id;
+ Attr_Name : Name_Id;
+ Str_Typ : Entity_Id)
+ is
+ begin
+ Rewrite (N,
+ Make_Attribute_Reference (Sloc (N),
+ Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)),
+ Attribute_Name => Attr_Name,
+ Expressions => New_List (Relocate_Node (Pref))));
+
+ Analyze_And_Resolve (N, Str_Typ);
+ end Rewrite_Object_Image;
end Exp_Imgv;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2017, 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- --
-- declarations are not constructed, and the fields remain Empty.
procedure Expand_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Image.
procedure Expand_Wide_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Wide_Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Wide_Image.
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Wide_Wide_Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Wide_Wide_Image.
procedure Expand_Value_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Value.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Value.
type Atype is (Normal, Wide, Wide_Wide);
-- Type of attribute in call to Expand_Width_Attribute
begin
Put_Line
(Standard_Error,
- "try """ & Base_Name (Ada.Command_Line.Command_Name)
+ "try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe")
& " --help"" for more information.");
end Try_Help;
-- types.
function Has_Some_Contract (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id has any contract (Pre, Post, Global,
- -- Depends, etc.)
+ -- Returns True if subprogram Id has any contract (Pre, Post,
+ -- Global, Depends, etc.) The presence of Extensions_Visible
+ -- or Volatile_Function is also considered as a contract here.
function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
-- Returns True if subprogram Id defines a compilation unit
if Is_Subprogram_Or_Generic_Subprogram (Id) then
Items := Contract (Id);
+ -- Note that Classifications is not Empty when Extensions_Visible
+ -- or Volatile_Function is present, which causes such subprograms
+ -- to be considered to have a contract here. This is fine as we
+ -- want to avoid inlining these too.
+
return Present (Items)
and then (Present (Pre_Post_Conditions (Items)) or else
Present (Contract_Test_Cases (Items)) or else
return False;
-- Do not inline subprograms that have a contract on the spec or the
- -- body. Use the contract(s) instead in GNATprove.
+ -- body. Use the contract(s) instead in GNATprove. This also prevents
+ -- inlining of subprograms with Extensions_Visible or Volatile_Function.
elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
or else
-- when the above criteria are met. Spec_Id denotes the entity of the
-- subprogram [body] or Empty if the attribute is illegal.
+ procedure Analyze_Image_Attribute (Str_Typ : Entity_Id);
+ -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and
+ -- 'Wide_Wide_Image. The routine checks that the prefix is valid and
+ -- sets the entity type to the one specified by Str_Typ (e.g.
+ -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
+
procedure Bad_Attribute_For_Predicate;
-- Output error message for use of a predicate (First, Last, Range) not
-- allowed with a type that has predicates. If the type is a generic
procedure Check_Object_Reference (P : Node_Id);
-- Check that P is an object reference
- procedure Check_Object_Reference_Image (Str_Typ : Entity_Id);
- -- Verify that the prefix of attribute 'Image is an object reference and
- -- set the type of the prefix to Str_Typ.
-
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
end if;
end Analyze_Attribute_Old_Result;
+ -----------------------------
+ -- Analyze_Image_Attribute --
+ -----------------------------
+
+ procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
+ begin
+ Check_SPARK_05_Restriction_On_Attribute;
+
+ -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for
+ -- scalar types, so that the prefix can be an object, a named value,
+ -- or a type, and there is no need for an argument in this case.
+
+ if Attr_Id = Attribute_Img
+ or else (Ada_Version > Ada_2005 and then Is_Object_Image (P))
+ then
+ Check_E0;
+ Set_Etype (N, Str_Typ);
+
+ if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then
+ Error_Attr_P
+ ("prefix of % attribute must be a scalar object name");
+ end if;
+ else
+ Check_E1;
+ Set_Etype (N, Str_Typ);
+
+ -- Check that the prefix type is scalar - much in the same way as
+ -- Check_Scalar_Type but with custom error messages to denote the
+ -- variants of 'Image attributes.
+
+ if Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ and then Ekind (Entity (P)) = E_Incomplete_Type
+ and then Present (Full_View (Entity (P)))
+ then
+ P_Type := Full_View (Entity (P));
+ Set_Entity (P, P_Type);
+ end if;
+
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ or else not Is_Scalar_Type (P_Type)
+ then
+ if Ada_Version > Ada_2005 then
+ Error_Attr_P
+ ("prefix of % attribute must be a scalar type or a scalar "
+ & "object name");
+ else
+ Error_Attr_P ("prefix of % attribute must be a scalar type");
+ end if;
+
+ elsif Is_Protected_Self_Reference (P) then
+ Error_Attr_P
+ ("prefix of % attribute denotes current instance "
+ & "(RM 9.4(21/2))");
+ end if;
+
+ Resolve (E1, P_Base_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end if;
+
+ Check_Enum_Image;
+
+ -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
+ -- to avoid giving a duplicate message for when Image attributes
+ -- applied to object references get expanded into type-based Image
+ -- attributes.
+
+ 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 Analyze_Image_Attribute;
+
---------------------------------
-- Bad_Attribute_For_Predicate --
---------------------------------
end if;
end Check_Object_Reference;
- ----------------------------------
- -- Check_Object_Reference_Image --
- ----------------------------------
-
- procedure Check_Object_Reference_Image (Str_Typ : Entity_Id) is
- begin
- Check_E0;
- Set_Etype (N, Str_Typ);
-
- if not Is_Scalar_Type (P_Type)
- or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
- then
- Error_Attr_P
- ("prefix of % attribute must be scalar object name");
- 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 Check_Object_Reference_Image;
-
----------------------------
-- Check_PolyORB_Attribute --
----------------------------
-----------
when Attribute_Image =>
- Check_SPARK_05_Restriction_On_Attribute;
-
- if Is_Image_Applied_To_Object (P, P_Type) then
- Check_Object_Reference_Image (Standard_String);
- return;
- end if;
-
- Check_Scalar_Type;
- Set_Etype (N, Standard_String);
-
if Is_Real_Type (P_Type) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
end if;
end if;
- if Is_Enumeration_Type (P_Type) then
- Check_Restriction (No_Enumeration_Maps, N);
- end if;
-
- Check_E1;
- 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;
+ Analyze_Image_Attribute (Standard_String);
---------
-- Img --
---------
when Attribute_Img =>
- Check_Object_Reference_Image (Standard_String);
+ Analyze_Image_Attribute (Standard_String);
-----------
-- Input --
----------------
when Attribute_Wide_Image =>
- Check_SPARK_05_Restriction_On_Attribute;
-
- if Is_Image_Applied_To_Object (P, P_Type) then
- Check_Object_Reference_Image (Standard_Wide_String);
- return;
- end if;
-
- Check_Scalar_Type;
- Set_Etype (N, Standard_Wide_String);
- 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;
+ Analyze_Image_Attribute (Standard_Wide_String);
---------------------
-- Wide_Wide_Image --
---------------------
when Attribute_Wide_Wide_Image =>
- if Is_Image_Applied_To_Object (P, P_Type) then
- Check_Object_Reference_Image (Standard_Wide_Wide_String);
- return;
- end if;
-
- Check_Scalar_Type;
- Set_Etype (N, Standard_Wide_Wide_String);
- 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;
+ Analyze_Image_Attribute (Standard_Wide_Wide_String);
----------------
-- Wide_Value --
N_Generic_Subprogram_Declaration);
end Is_Generic_Declaration_Or_Body;
- --------------------------------
- -- Is_Image_Applied_To_Object --
- --------------------------------
-
- function Is_Image_Applied_To_Object
- (Prefix : Node_Id;
- P_Typ : Entity_Id) return Boolean
- is
- begin
- return
- Ada_Version > Ada_2005
- and then Is_Object_Reference (Prefix)
- and then Is_Scalar_Type (P_Typ);
- end Is_Image_Applied_To_Object;
-
----------------------------
-- Is_Inherited_Operation --
----------------------------
or else Null_Present (Component_List (Type_Definition (Decl))));
end Is_Null_Record_Type;
+ ---------------------
+ -- Is_Object_Image --
+ ---------------------
+
+ function Is_Object_Image (Prefix : Node_Id) return Boolean is
+ begin
+ -- When the type of the prefix is not scalar then the prefix is not
+ -- valid in any senario.
+
+ if not Is_Scalar_Type (Etype (Prefix)) then
+ return False;
+ end if;
+
+ -- Here we test for the case that the prefix is not a type and assume
+ -- if it is not then it must be a named value or an object reference.
+ -- This is because the parser always checks that prefix's of attributes
+ -- are named.
+
+ return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
+ end Is_Object_Image;
+
-------------------------
-- Is_Object_Reference --
-------------------------
return not Nkind_In (Original_Node (N), N_Case_Expression,
N_If_Expression);
- -- A view conversion of a tagged object is an object reference
-
when N_Type_Conversion =>
+ -- A view conversion of a tagged object is an object reference
+
return Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Object_Reference (Expression (N));
-- Determine whether arbitrary declaration Decl denotes a generic package,
-- a generic subprogram or a generic body.
- function Is_Image_Applied_To_Object
- (Prefix : Node_Id;
- P_Typ : Entity_Id) return Boolean;
- -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
- -- can be applied to a given object-reference prefix (see AI12-00124).
-
- -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar
- -- types, so that the prefix can be an object and not a type, and there is
- -- no need for an argument. Given the vote of confidence from the ARG,
- -- simplest is to transform this new usage of 'Image into a reference to
- -- 'Img.
-
function Is_Inherited_Operation (E : Entity_Id) return Boolean;
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by a derived type declaration.
-- Determine whether T is declared with a null record definition or a
-- null component list.
+ function Is_Object_Image (Prefix : Node_Id) return Boolean;
+ -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
+ -- is applied to a given object or named value prefix (see below).
+
+ -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar
+ -- types, so that the prefix of any 'Image attribute can be an object, a
+ -- named value, or a type, and there is no need for an argument in the
+ -- case it is an object reference.
+
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both
-- variable and constant objects return True (compare Is_Variable).
projects / gcc.git / commitdiff