+2017-09-06 Steve Baird <baird@adacore.com>
+
+ * exp_util.adb (Side_Effect_Free): For CodePeer (only) treat
+ uses of 'Image and related attributes as having side effects in
+ order to avoid replicating such uses.
+ * pprint.ads (Expression_Image) Add new generic formal flag
+ Hide_Temp_Derefs. The flag defaults to False; CodePeer will
+ (eventually) override the default.
+ * pprint.adb (Expression_Image) If the new flag is set, then
+ suppress the ".all" suffix when displaying a dereference whose
+ prefix is a use of a value-capturing compiler temp of the sort
+ generated by Expr_Util.Remove_Side_Effects .
+ * exp_attr.adb, g-catiio.adb, inline.adb, sem_attr.adb, sem_ch13.adb,
+ sem_ch7.adb, sem_dim.adb, sem_util.adb, sem_util.ads, sem_warn.adb:
+ Minor reformatting.
+ * inline.adb: Minor wording change.
+
2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch7.adb: Update comment.
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
+
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
return;
end if;
- Exp_Imgv.Expand_Image_Attribute (N);
+ Expand_Image_Attribute (N);
---------
-- Img --
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
- Exp_Imgv.Expand_Image_Attribute (N);
+ Expand_Image_Attribute (N);
-----------
-- Input --
elsif Is_Record_Type (Ftyp)
and then Present (Declaration_Node (Ftyp))
and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
- N_Record_Definition
+ N_Record_Definition
then
Rewrite (N,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
- Parameter_Associations => New_List (Pref)));
+ Parameter_Associations => New_List (Pref)));
-- Other record types or types with discriminants
-- Is this right? what about x'first where x is a variable???
when N_Attribute_Reference =>
- return
- Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
- and then Attribute_Name (N) /= Name_Input
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free
- (Prefix (N), Name_Req, Variable_Ref));
+ Attribute_Reference : declare
+
+ function Side_Effect_Free_Attribute
+ (Attribute_Name : Name_Id) return Boolean;
+ -- Returns True if evaluation of the given attribute is
+ -- considered side-effect free (independent of prefix and
+ -- arguments).
+
+ --------------------------------
+ -- Side_Effect_Free_Attribute --
+ --------------------------------
+
+ function Side_Effect_Free_Attribute
+ (Attribute_Name : Name_Id) return Boolean
+ is
+ begin
+ case Attribute_Name is
+ when Name_Input =>
+ return False;
+
+ when Name_Image
+ | Name_Img
+ | Name_Wide_Image
+ | Name_Wide_Wide_Image
+ =>
+ -- CodePeer doesn't want to see replicated copies of
+ -- 'Image calls.
+
+ return not CodePeer_Mode;
+
+ when others =>
+ return True;
+ end case;
+ end Side_Effect_Free_Attribute;
+
+ -- Start of processing for Attribute_Reference
+
+ begin
+ return
+ Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
+ and then Side_Effect_Free_Attribute (Attribute_Name (N))
+ and then (Is_Entity_Name (Prefix (N))
+ or else Side_Effect_Free
+ (Prefix (N), Name_Req, Variable_Ref));
+ end Attribute_Reference;
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
Time : out Ada.Calendar.Time;
Success : out Boolean)
is
- Index : Positive := Date'First;
+ Index : Positive := Date'First;
-- The current character scan index. After a call to Advance, Index
-- points to the next character.
-- An exception used to signal that the scan pointer has reached the
-- end of the source string.
- Wrong_Syntax : exception;
+ Wrong_Syntax : exception;
-- An exception used to signal that the scan pointer has reached an
-- unexpected character in the source string.
Date_Separator : constant Character := '-';
Hour_Separator : constant Character := ':';
- Day : Day_Number;
- Month : Month_Number;
- Year : Year_Number;
- Hour : Hour_Number := 0;
- Minute : Minute_Number := 0;
- Second : Second_Number := 0;
- Subsec : Second_Duration := 0.0;
-
- Local_Hour : Hour_Number := 0;
- Local_Minute : Minute_Number := 0;
- Local_Sign : Character := ' ';
- Local_Disp : Duration;
-
- Sep_Required : Boolean := False;
+
+ Day : Day_Number;
+ Month : Month_Number;
+ Year : Year_Number;
+ Hour : Hour_Number := 0;
+ Minute : Minute_Number := 0;
+ Second : Second_Number := 0;
+ Subsec : Second_Duration := 0.0;
+
+ Local_Hour : Hour_Number := 0;
+ Local_Minute : Minute_Number := 0;
+ Local_Sign : Character := ' ';
+ Local_Disp : Duration;
+
+ Sep_Required : Boolean := False;
-- True if a separator is seen (and therefore required after it!)
begin
-- Compute time with positive local displacement
elsif Local_Sign = '+' then
- Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec)
- - Local_Disp;
+ Time :=
+ Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) -
+ Local_Disp;
-- Compute time with negative local displacement
elsif Local_Sign = '-' then
- Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec)
- + Local_Disp;
+ Time :=
+ Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) +
+ Local_Disp;
end if;
-- Notify that the input string was successfully parsed
Success := True;
exception
- when End_Of_Source_Reached |
- Wrong_Syntax =>
+ when End_Of_Source_Reached
+ | Wrong_Syntax
+ =>
Success := False;
end Parse_ISO_8861_UTC;
--------------------------
procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
-
procedure Generate_Subprogram_Body
(N : Node_Id;
Body_To_Inline : out Node_Id);
Save_Env (Scope (Current_Scope), Scope (Current_Scope));
end if;
- -- We need to capture references to the formals in order
- -- to substitute the actuals at the point of inlining, i.e.
- -- instantiation. To treat the formals as globals to the body to
- -- inline, we nest it within a dummy parameterless subprogram,
- -- declared within the real one.
+ -- Capture references to formals in order to substitute the actuals
+ -- at the point of inlining or instantiation. To treat the formals
+ -- as globals to the body to inline, nest the body within a dummy
+ -- parameterless subprogram, declared within the real one.
Generate_Subprogram_Body (N, Original_Body);
Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
-- Can_Split_Unconstrained_Function --
--------------------------------------
- function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
- is
+ function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
Ret_Node : constant Node_Id :=
First (Statements (Handled_Statement_Sequence (N)));
D : Node_Id;
-- The semantic analyzer checked that frontend-inlined functions
-- returning unconstrained types have no declarations and have
-- a single extended return statement. As part of its processing
- -- the function was split in two subprograms: a procedure P' and
+ -- the function was split into two subprograms: a procedure P' and
-- a function F' that has a block with a call to procedure P' (see
-- Split_Unconstrained_Function).
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-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- --
end if;
when N_Explicit_Dereference =>
+ Explicit_Dereference : declare
+ function Deref_Suffix return String;
+ -- Usually returns ".all", but will return "" if
+ -- Hide_Temp_Derefs is true and the prefix is a use of a
+ -- not-from-source object declared as
+ -- X : constant Some_Access_Type := Some_Expr'Reference;
+ -- (as is sometimes done in Exp_Util.Remove_Side_Effects).
- -- Return "Foo" instead of "Parameter_Block.Foo.all"
+ ------------------
+ -- Deref_Suffix --
+ ------------------
- if Hide_Parameter_Blocks
- and then Nkind (Prefix (Expr)) = N_Selected_Component
- and then Present (Etype (Prefix (Expr)))
- and then Is_Access_Type (Etype (Prefix (Expr)))
- and then Is_Param_Block_Component_Type (Etype (Prefix (Expr)))
- then
- return Expr_Name (Selector_Name (Prefix (Expr)));
+ function Deref_Suffix return String is
+ Decl : Node_Id;
- elsif Take_Prefix then
- return Expr_Name (Prefix (Expr)) & ".all";
- else
- return ".all";
- end if;
+ begin
+ if Hide_Temp_Derefs
+ and then Nkind (Prefix (Expr)) = N_Identifier
+ and then Nkind (Entity (Prefix (Expr))) =
+ N_Defining_Identifier
+ then
+ Decl := Parent (Entity (Prefix (Expr)));
+
+ if Present (Decl)
+ and then Nkind (Decl) = N_Object_Declaration
+ and then not Comes_From_Source (Decl)
+ and then Constant_Present (Decl)
+ and then Present (Sinfo.Expression (Decl))
+ and then Nkind (Sinfo.Expression (Decl)) =
+ N_Reference
+ then
+ return "";
+ end if;
+ end if;
+
+ -- The default case
+
+ return ".all";
+ end Deref_Suffix;
+
+ -- Start of processing for Explicit_Dereference
+
+ begin
+ if Hide_Parameter_Blocks
+ and then Nkind (Prefix (Expr)) = N_Selected_Component
+ and then Present (Etype (Prefix (Expr)))
+ and then Is_Access_Type (Etype (Prefix (Expr)))
+ and then Is_Param_Block_Component_Type
+ (Etype (Prefix (Expr)))
+ then
+ -- Return "Foo" instead of "Parameter_Block.Foo.all"
+
+ return Expr_Name (Selector_Name (Prefix (Expr)));
+
+ elsif Take_Prefix then
+ return Expr_Name (Prefix (Expr)) & Deref_Suffix;
+ else
+ return Deref_Suffix;
+ end if;
+ end Explicit_Dereference;
when N_Expanded_Name
| N_Selected_Component
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-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- --
-- If true, then "Parameter_Block.Field_Name.all" is
-- instead displayed as "Field_Name".
+ Hide_Temp_Derefs : Boolean := False;
+ -- If true, then "Foo.all" is instead displayed as "Foo"
+ -- in the case where Foo is a compiler-generated constant
+ -- initialized to Some_Captured_Value'Reference.
+
function Expression_Image
(Expr : Node_Id;
Default : String) return String;
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.
+ -- sets the type of the attribute 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;
if Ada_Version > Ada_2005 then
Error_Attr_P
("prefix of % attribute must be a scalar type or a scalar "
- & "object name");
+ & "object name");
else
Error_Attr_P ("prefix of % attribute must be a scalar type");
end if;
declare
A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
Expr : constant Node_Id := Expression (ASN);
+
begin
case A_Id is
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
--------------------------
procedure Hide_Public_Entities (Decls : List_Id) is
-
function Has_Referencer
(Decls : List_Id;
Top_Level : Boolean := False) return Boolean;
end if;
when N_Unary_Op =>
-
Analyze_Dimension_Unary_Op (N);
when others =>
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
+ -- When the type of the prefix is not scalar, then the prefix is not
-- valid in any scenario.
if not Is_Scalar_Type (Etype (Prefix)) then
return not Nkind_In (Original_Node (N), N_Case_Expression,
N_If_Expression);
- when N_Type_Conversion =>
- -- A view conversion of a tagged object is an object reference
+ -- A view conversion of a tagged object is an object reference
+ when N_Type_Conversion =>
return Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Object_Reference (Expression (N));
if Ekind (Scop) = E_Protected_Type then
return True;
end if;
+
Scop := Scope (Scop);
end loop;
-- null component list.
function Is_Object_Image (Prefix : Node_Id) return Boolean;
- -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
+ -- 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
-- an expression with actions.
UR := Original_Node (UR);
- while Nkind (UR) = N_Type_Conversion
- or else Nkind (UR) = N_Qualified_Expression
- or else Nkind (UR) = N_Expression_With_Actions
- or else Nkind (UR) = N_Attribute_Reference
+ while Nkind_In (UR, N_Attribute_Reference,
+ N_Expression_With_Actions,
+ N_Qualified_Expression,
+ N_Type_Conversion)
loop
if Nkind (UR) = N_Attribute_Reference then
UR := Prefix (UR);
projects / gcc.git / commitdiff