CbC/CbC_gcc: gcc/ada/sem_attr.adb comparison

comparison gcc/ada/sem_attr.adb @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                             S E M _ A T T R                              --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
 with Atree;    use Atree;
 with Casing;   use Casing;
 with Checks;   use Checks;
+with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Eval_Fat;
 with Exp_Dist; use Exp_Dist;
 Exprs   : constant List_Id      := Expressions (N);
 Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
 E1      : Node_Id;
 E2      : Node_Id;
-P_Type : Entity_Id;
+P_Type : Entity_Id := Empty;
 --  Type of prefix after analysis
-P_Base_Type : Entity_Id;
+P_Base_Type : Entity_Id := Empty;
 --  Base type of prefix after analysis
 -----------------------
 -- Local Subprograms --
 -----------------------
 --  character which is replaced by the attribute name. The call with
 --  no arguments is used when the caller has already generated the
 --  required error messages.
 procedure Error_Attr_P (Msg : String);
-pragma No_Return (Error_Attr);
+pragma No_Return (Error_Attr_P);
 --  Like Error_Attr, but error is posted at the start of the prefix
 procedure Legal_Formal_Attribute;
 --  Common processing for attributes Definite and Has_Discriminants.
 --  Checks that prefix is generic indefinite formal type.
 --  expression. Generates appropriate message or warning depending on
 --  the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification
 --  node in the aspect case).
 procedure Unexpected_Argument (En : Node_Id);
---  Signal unexpected attribute argument (En is the argument)
+pragma No_Return (Unexpected_Argument);
+--  Signal unexpected attribute argument (En is the argument), and then
+--  raises Bad_Attribute to avoid any further semantic processing.
 procedure Validate_Non_Static_Attribute_Function_Call;
 --  Called when processing an attribute that is a function call to a
 --  non-static function, i.e. an attribute function that either takes
 --  non-scalar arguments or returns a non-scalar result. Verifies that
 --  Preserve relevant elaboration-related attributes of the context
 --  which are no longer available or very expensive to recompute once
 --  analysis, resolution, and expansion are over.
 Mark_Elaboration_Attributes
-(N_Id   => N,
+(N_Id     => N,
-Checks => True,
+Checks   => True,
-Modes  => True);
+Modes    => True,
+Warnings => True);
 --  Save the scenario for later examination by the ABE Processing
 --  phase.
 Record_Elaboration_Scenario (N);
 then
 null;
 else
 Kill_Current_Values;
+end if;
+--  In the static elaboration model, treat the attribute reference
+--  as a subprogram call for elaboration purposes. Suppress this
+--  treatment under debug flag. In any case, we are all done.
+if Legacy_Elaboration_Checks
+and not Dynamic_Elaboration_Checks
+and not Debug_Flag_Dot_UU
+then
+Check_Elab_Call (N);
 end if;
 return;
 --  Component is an operation of a protected type
 Encl_Nod : Node_Id) return Boolean;
 --  Subsidiary to Check_Placemenet_In_XXX. Determine whether arbitrary
 --  node Nod is within enclosing node Encl_Nod.
 procedure Placement_Error;
+pragma No_Return (Placement_Error);
 --  Emit a general error when the attributes does not appear in a
---  postcondition-like aspect or pragma.
+--  postcondition-like aspect or pragma, and then raises Bad_Attribute
+--  to avoid any further semantic processing.
 ------------------------------
 -- Check_Placement_In_Check --
 ------------------------------
 --  If there is an implicit dereference, then we must freeze the
 --  designated type of the access type, since the type of the
 --  referenced array is this type (see AI95-00106).
---  As done elsewhere, freezing must not happen when pre-analyzing
+--  As done elsewhere, freezing must not happen when preanalyzing
 --  a pre- or postcondition or a default value for an object or for
 --  a formal parameter.
 if not In_Spec_Expression then
 Freeze_Before (N, Designated_Type (P_Type));
 procedure Check_Object_Reference (P : Node_Id) is
 Rtyp : Entity_Id;
 begin
---  If we need an object, and we have a prefix that is the name of
+--  If we need an object, and we have a prefix that is the name of a
---  a function entity, convert it into a function call.
+--  function entity, convert it into a function call.
 if Is_Entity_Name (P)
 and then Ekind (Entity (P)) = E_Function
 then
 Rtyp := Etype (Entity (P));
 -- Error_Attr --
 ----------------
 procedure Error_Attr is
 begin
-Set_Etype (N, Any_Type);
+Set_Etype  (N, Any_Type);
 Set_Entity (N, Any_Type);
 raise Bad_Attribute;
 end Error_Attr;
 procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
 Check_E0;
 Check_Type;
 if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then
---  In GNAT mode, the attribute applies to generic types as well
+--  The attribute applies to generic private types (in which case
---  as composite types, and for non-composite types always returns
+--  the legality rule is applied in the instance) as well as to
---  the default bit order for the target.
+--  composite types. For noncomposite types it always returns the
+--  default bit order for the target.
-if not (GNAT_Mode and then Is_Generic_Type (P_Type))
+--  Allowing formal private types was originally introduced in
+--  GNAT_Mode only, to compile instances of Sequential_IO, but
+--  users find it more generally useful in generic units.
+if not (Is_Generic_Type (P_Type) and then Is_Private_Type (P_Type))
 and then not In_Instance
 then
 Error_Attr_P
 ("prefix of % attribute must be record or array type");
 -----------
 -- Valid --
 -----------
-when Attribute_Valid =>
+when Attribute_Valid => Valid : declare
+Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
+begin
 Check_E0;
 --  Ignore check for object if we have a 'Valid reference generated
 --  by the expanded code, since in some cases valid checks can occur
 --  on items that are names, but are not objects (e.g. attributes).
 if Comes_From_Source (N) then
 Check_Object_Reference (P);
-end if;
+if not Is_Scalar_Type (P_Type) then
-if not Is_Scalar_Type (P_Type) then
+Error_Attr_P ("object for % attribute must be of scalar type");
-Error_Attr_P ("object for % attribute must be of scalar type");
+end if;
-end if;
+--  If the attribute appears within the subtype's own predicate
---  If the attribute appears within the subtype's own predicate
+--  function, then issue a warning that this will cause infinite
---  function, then issue a warning that this will cause infinite
+--  recursion.
---  recursion.
-declare
-Pred_Func : constant Entity_Id := Predicate_Function (P_Type);
-begin
 if Present (Pred_Func) and then Current_Scope = Pred_Func then
-Error_Msg_N
+Error_Msg_N ("attribute Valid requires a predicate check??", N);
-("attribute Valid requires a predicate check??", N);
 Error_Msg_N ("\and will result in infinite recursion??", N);
 end if;
-end;
+end if;
 Set_Etype (N, Standard_Boolean);
+end Valid;
 -------------------
 -- Valid_Scalars --
 -------------------
-when Attribute_Valid_Scalars =>
+when Attribute_Valid_Scalars => Valid_Scalars : declare
+begin
 Check_E0;
-Check_Object_Reference (P);
+if Comes_From_Source (N) then
+Check_Object_Reference (P);
+--  Do not emit any diagnostics related to private types to avoid
+--  disclosing the structure of the type.
+if Is_Private_Type (P_Type) then
+--  Attribute 'Valid_Scalars is not supported on private tagged
+--  types due to a code generation issue. Is_Visible_Component
+--  does not allow for a component of a private tagged type to
+--  be successfully retrieved.
+--  Do not use Error_Attr_P because this bypasses any subsequent
+--  processing and leaves the attribute with type Any_Type. This
+--  in turn prevents the proper expansion of the attribute into
+--  True.
+if Is_Tagged_Type (P_Type) then
+Error_Msg_Name_1 := Aname;
+Error_Msg_N ("??effects of attribute % are ignored", N);
+end if;
+--  Otherwise the type is not private
+else
+if not Scalar_Part_Present (P_Type) then
+Error_Msg_Name_1 := Aname;
+Error_Msg_F
+("??attribute % always True, no scalars to check", P);
+Set_Boolean_Result (N, True);
+end if;
+--  Attribute 'Valid_Scalars is illegal on unchecked union types
+--  because it is not always guaranteed that the components are
+--  retrievable based on whether the discriminants are inferable
+if Has_Unchecked_Union (P_Type) then
+Error_Attr_P
+("attribute % not allowed for Unchecked_Union type");
+end if;
+end if;
+end if;
 Set_Etype (N, Standard_Boolean);
+end Valid_Scalars;
---  Following checks are only for source types
-if Comes_From_Source (N) then
-if not Scalar_Part_Present (P_Type) then
-Error_Attr_P
-("??attribute % always True, no scalars to check");
-end if;
---  Not allowed for unchecked union type
-if Has_Unchecked_Union (P_Type) then
-Error_Attr_P
-("attribute % not allowed for Unchecked_Union type");
-end if;
-end if;
 -----------
 -- Value --
 -----------
 Wrong_Type (N, Typ);
 end if;
 --  The context may be a constrained access type (however ill-
 --  advised such subtypes might be) so in order to generate a
---  constraint check when needed set the type of the attribute
+--  constraint check we need to set the type of the attribute
 --  reference to the base type of the context.
 Set_Etype (N, Btyp);
 --  Check for incorrect atomic/volatile reference (RM C.6(12))
 if not (Is_Entity_Name (P)
 and then Is_Overloadable (Entity (P)))
 and then not (Nkind (P) = N_Selected_Component
 and then
 Is_Overloadable (Entity (Selector_Name (P))))
-and then not Is_Aliased_View (P)
+and then not Is_Aliased_View (Original_Node (P))
 and then not In_Instance
 and then not In_Inlined_Body
 and then Comes_From_Source (N)
 then
 --  Here we have a non-aliased view. This is illegal unless we
 Defining_Identifier => Flag_Id,
 Object_Definition   =>
 New_Occurrence_Of (Standard_Short_Integer, Loc),
 Expression          =>
 Make_Integer_Literal (Loc, Uint_0)));
+--  The above sets the Scope of the flag entity to the
+--  current scope, in which the attribute appears, but
+--  the flag declaration has been inserted after that
+--  of Subp_Id, so the scope of the flag is the same as
+--  that of Subp_Id. This is relevant when unnesting,
+--  where processing depends on correct scope setting.
+Set_Scope (Flag_Id, Scop);
 end if;
 --  Taking the 'Access of an expression function freezes its
 --  expression (RM 13.14 10.3/3). This does not apply to an
 --  expression function that acts as a completion because the
 --  of a generic function whose type may remain unelaborated.
 if Attr_Id = Attribute_Elaborated then
 null;
+--  Should this be restricted to Expander_Active???
 else
 Freeze_Expression (P);
 end if;
 --  Finally perform static evaluation on the attribute reference

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_attr.adb @ 131:84e7813d76e9