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

comparison gcc/ada/exp_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
 --                                                                          --
 --                             E X P _ 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- --
 -----------------------
 -- Local Subprograms --
 -----------------------
 function Build_Array_VS_Func
-(A_Type : Entity_Id;
+(Attr       : Node_Id;
-Nod    : Node_Id) return Entity_Id;
+Formal_Typ : Entity_Id;
---  Build function to test Valid_Scalars for array type A_Type. Nod is the
+Array_Typ  : Entity_Id;
---  Valid_Scalars attribute node, used to insert the function body, and the
+Comp_Typ   : Entity_Id) return Entity_Id;
---  value returned is the entity of the constructed function body. We do not
+--  Validate the components of an array type by means of a function. Return
---  bother to generate a separate spec for this subprogram.
+--  the entity of the validation function. The parameters are as follows:
+--
+--    * Attr - the 'Valid_Scalars attribute for which the function is
+--      generated.
+--
+--    * Formal_Typ - the type of the generated function's only formal
+--      parameter.
+--
+--    * Array_Typ - the array type whose components are to be validated
+--
+--    * Comp_Typ - the component type of the array
 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
 --  Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
 function Build_Record_VS_Func
-(R_Type : Entity_Id;
+(Attr       : Node_Id;
-Nod    : Node_Id) return Entity_Id;
+Formal_Typ : Entity_Id;
---  Build function to test Valid_Scalars for record type A_Type. Nod is the
+Rec_Typ    : Entity_Id) return Entity_Id;
---  Valid_Scalars attribute node, used to insert the function body, and the
+--  Validate the components, discriminants, and variants of a record type by
---  value returned is the entity of the constructed function body. We do not
+--  means of a function. Return the entity of the validation function. The
---  bother to generate a separate spec for this subprogram.
+--  parameters are as follows:
+--
+--    * Attr - the 'Valid_Scalars attribute for which the function is
+--      generated.
+--
+--    * Formal_Typ - the type of the generated function's only formal
+--      parameter.
+--
+--    * Rec_Typ - the record type whose internals are to be validated
 procedure Compile_Stream_Body_In_Scope
 (N     : Node_Id;
 Decl  : Node_Id;
 Arr   : Entity_Id;
 -------------------------
 -- Build_Array_VS_Func --
 -------------------------
 function Build_Array_VS_Func
-(A_Type : Entity_Id;
+(Attr       : Node_Id;
-Nod    : Node_Id) return Entity_Id
+Formal_Typ : Entity_Id;
+Array_Typ  : Entity_Id;
+Comp_Typ   : Entity_Id) return Entity_Id
 is
-Loc        : constant Source_Ptr := Sloc (Nod);
+Loc : constant Source_Ptr := Sloc (Attr);
-Func_Id    : constant Entity_Id  := Make_Temporary (Loc, 'V');
-Comp_Type  : constant Entity_Id  := Component_Type (A_Type);
+function Validate_Component
-Body_Stmts : List_Id;
+(Obj_Id  : Entity_Id;
-Index_List : List_Id;
+Indexes : List_Id) return Node_Id;
-Formals    : List_Id;
+--  Process a single component denoted by indexes Indexes. Obj_Id denotes
+--  the entity of the validation parameter. Return the check associated
-function Test_Component return List_Id;
+--  with the component.
---  Create one statement to test validity of one component designated by
---  a full set of indexes. Returns statement list containing test.
+function Validate_Dimension
+(Obj_Id  : Entity_Id;
-function Test_One_Dimension (N : Int) return List_Id;
+Dim     : Int;
---  Create loop to test one dimension of the array. The single statement
+Indexes : List_Id) return Node_Id;
---  in the loop body tests the inner dimensions if any, or else the
+--  Process dimension Dim of the array type. Obj_Id denotes the entity
---  single component. Note that this procedure is called recursively,
+--  of the validation parameter. Indexes is a list where each dimension
---  with N being the dimension to be initialized. A call with N greater
+--  deposits its loop variable, which will later identify a component.
---  than the number of dimensions simply generates the component test,
+--  Return the loop associated with the current dimension.
---  terminating the recursion. Returns statement list containing tests.
+------------------------
---------------------
+-- Validate_Component --
--- Test_Component --
+------------------------
---------------------
+function Validate_Component
-function Test_Component return List_Id is
+(Obj_Id  : Entity_Id;
-Comp : Node_Id;
+Indexes : List_Id) return Node_Id
-Anam : Name_Id;
+is
+Attr_Nam : Name_Id;
 begin
-Comp :=
+if Is_Scalar_Type (Comp_Typ) then
-Make_Indexed_Component (Loc,
+Attr_Nam := Name_Valid;
-Prefix      => Make_Identifier (Loc, Name_uA),
-Expressions => Index_List);
-if Is_Scalar_Type (Comp_Type) then
-Anam := Name_Valid;
 else
-Anam := Name_Valid_Scalars;
+Attr_Nam := Name_Valid_Scalars;
 end if;
-return New_List (
+--  Generate:
+--    if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
+--       return False;
+--    end if;
+return
 Make_If_Statement (Loc,
 Condition =>
 Make_Op_Not (Loc,
 Right_Opnd =>
 Make_Attribute_Reference (Loc,
-Attribute_Name => Anam,
+Prefix         =>
-Prefix         => Comp)),
+Make_Indexed_Component (Loc,
+Prefix      =>
+Unchecked_Convert_To (Array_Typ,
+New_Occurrence_Of (Obj_Id, Loc)),
+Expressions => Indexes),
+Attribute_Name => Attr_Nam)),
 Then_Statements => New_List (
 Make_Simple_Return_Statement (Loc,
-Expression => New_Occurrence_Of (Standard_False, Loc)))));
+Expression => New_Occurrence_Of (Standard_False, Loc))));
-end Test_Component;
+end Validate_Component;
 ------------------------
--- Test_One_Dimension --
+-- Validate_Dimension --
 ------------------------
-function Test_One_Dimension (N : Int) return List_Id is
+function Validate_Dimension
+(Obj_Id  : Entity_Id;
+Dim     : Int;
+Indexes : List_Id) return Node_Id
+is
 Index : Entity_Id;
 begin
---  If all dimensions dealt with, we simply test the component
+--  Validate the component once all dimensions have produced their
+--  individual loops.
-if N > Number_Dimensions (A_Type) then
-return Test_Component;
+if Dim > Number_Dimensions (Array_Typ) then
+return Validate_Component (Obj_Id, Indexes);
---  Here we generate the required loop
+--  Process the current dimension
 else
 Index :=
-Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
-Append (New_Occurrence_Of (Index, Loc), Index_List);
+Append_To (Indexes, New_Occurrence_Of (Index, Loc));
-return New_List (
+--  Generate:
-Make_Implicit_Loop_Statement (Nod,
+--    for J1 in Array_Typ (Obj_Id)'Range (1) loop
-Identifier => Empty,
+--       for JN in Array_Typ (Obj_Id)'Range (N) loop
+--          if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
+--          then
+--             return False;
+--          end if;
+--       end loop;
+--    end loop;
+return
+Make_Implicit_Loop_Statement (Attr,
+Identifier       => Empty,
 Iteration_Scheme =>
 Make_Iteration_Scheme (Loc,
 Loop_Parameter_Specification =>
 Make_Loop_Parameter_Specification (Loc,
-Defining_Identifier => Index,
+Defining_Identifier         => Index,
 Discrete_Subtype_Definition =>
 Make_Attribute_Reference (Loc,
-Prefix => Make_Identifier (Loc, Name_uA),
+Prefix          =>
+Unchecked_Convert_To (Array_Typ,
+New_Occurrence_Of (Obj_Id, Loc)),
 Attribute_Name  => Name_Range,
 Expressions     => New_List (
-Make_Integer_Literal (Loc, N))))),
+Make_Integer_Literal (Loc, Dim))))),
-Statements =>  Test_One_Dimension (N + 1)),
+Statements       => New_List (
-Make_Simple_Return_Statement (Loc,
+Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
-Expression => New_Occurrence_Of (Standard_True, Loc)));
+end if;
-end if;
+end Validate_Dimension;
-end Test_One_Dimension;
+--  Local variables
+Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
+Indexes : constant List_Id   := New_List;
+Obj_Id  : constant Entity_Id := Make_Temporary (Loc, 'A');
+Stmts   : List_Id;
 --  Start of processing for Build_Array_VS_Func
 begin
-Index_List := New_List;
+Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
-Body_Stmts := Test_One_Dimension (1);
+--  Generate:
---  Parameter is always (A : A_Typ)
+--    return True;
-Formals := New_List (
+Append_To (Stmts,
-Make_Parameter_Specification (Loc,
+Make_Simple_Return_Statement (Loc,
-Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
+Expression => New_Occurrence_Of (Standard_True, Loc)));
-In_Present          => True,
-Out_Present         => False,
+--  Generate:
-Parameter_Type      => New_Occurrence_Of (A_Type, Loc)));
+--    function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+--    begin
---  Build body
+--       Stmts
+--    end Func_Id;
 Set_Ekind       (Func_Id, E_Function);
 Set_Is_Internal (Func_Id);
+Set_Is_Pure     (Func_Id);
-Insert_Action (Nod,
+if not Debug_Generated_Code then
+Set_Debug_Info_Off (Func_Id);
+end if;
+Insert_Action (Attr,
 Make_Subprogram_Body (Loc,
 Specification              =>
 Make_Function_Specification (Loc,
 Defining_Unit_Name       => Func_Id,
-Parameter_Specifications => Formals,
+Parameter_Specifications => New_List (
-Result_Definition        =>
+Make_Parameter_Specification (Loc,
-New_Occurrence_Of (Standard_Boolean, Loc)),
+Defining_Identifier => Obj_Id,
+In_Present          => True,
+Out_Present         => False,
+Parameter_Type      => New_Occurrence_Of (Formal_Typ, Loc))),
+Result_Definition        =>
+New_Occurrence_Of (Standard_Boolean, Loc)),
 Declarations               => New_List,
 Handled_Statement_Sequence =>
 Make_Handled_Sequence_Of_Statements (Loc,
-Statements => Body_Stmts)));
+Statements => Stmts)));
-if not Debug_Generated_Code then
-Set_Debug_Info_Off (Func_Id);
-end if;
-Set_Is_Pure (Func_Id);
 return Func_Id;
 end Build_Array_VS_Func;
 ---------------------------------
 -- Build_Disp_Get_Task_Id_Call --
 --------------------------
 -- Build_Record_VS_Func --
 --------------------------
---  Generates:
---    function _Valid_Scalars (X : T) return Boolean is
---    begin
---       --  Check discriminants
---       if not X.D1'Valid_Scalars or else
---          not X.D2'Valid_Scalars or else
---         ...
---       then
---          return False;
---       end if;
---       --  Check components
---       if not X.C1'Valid_Scalars or else
---          not X.C2'Valid_Scalars or else
---          ...
---       then
---          return False;
---       end if;
---       --  Check variant part
---       case X.D1 is
---          when V1 =>
---             if not X.C2'Valid_Scalars or else
---                not X.C3'Valid_Scalars or else
---               ...
---             then
---                return False;
---             end if;
---          ...
---          when Vn =>
---             if not X.Cn'Valid_Scalars or else
---               ...
---             then
---                return False;
---             end if;
---       end case;
---       return True;
---    end _Valid_Scalars;
---  If the record type is an unchecked union, we can only check components
---  in the invariant part, given that there are no discriminant values to
---  select a variant.
 function Build_Record_VS_Func
-(R_Type : Entity_Id;
+(Attr       : Node_Id;
-Nod    : Node_Id) return Entity_Id
+Formal_Typ : Entity_Id;
+Rec_Typ    : Entity_Id) return Entity_Id
 is
-Loc     : constant Source_Ptr := Sloc (R_Type);
+--  NOTE: The logic of Build_Record_VS_Func is intentionally passive.
-Func_Id : constant Entity_Id  := Make_Temporary (Loc, 'V');
+--  It generates code only when there are components, discriminants,
-X       : constant Entity_Id  := Make_Defining_Identifier (Loc, Name_X);
+--  or variant parts to validate.
-function Make_VS_Case
+--  NOTE: The routines within Build_Record_VS_Func are intentionally
-(E      : Entity_Id;
+--  unnested to avoid deep indentation of code.
-CL     : Node_Id;
-Discrs : Elist_Id := New_Elmt_List) return List_Id;
+Loc : constant Source_Ptr := Sloc (Attr);
---  Building block for variant valid scalars. Given a Component_List node
---  CL, it generates an 'if' followed by a 'case' statement that compares
+procedure Validate_Component_List
---  all components of local temporaries named X and Y (that are declared
+(Obj_Id    : Entity_Id;
---  as formals at some upper level). E provides the Sloc to be used for
+Comp_List : Node_Id;
---  the generated code.
+Stmts     : in out List_Id);
+--  Process all components and variant parts of component list Comp_List.
-function Make_VS_If
+--  Obj_Id denotes the entity of the validation parameter. All new code
-(E : Entity_Id;
+--  is added to list Stmts.
-L : List_Id) return Node_Id;
---  Building block for variant validate scalars. Given the list, L, of
+procedure Validate_Field
---  components (or discriminants) L, it generates a return statement that
+(Obj_Id : Entity_Id;
---  compares all components of local temporaries named X and Y (that are
+Field  : Node_Id;
---  declared as formals at some upper level). E provides the Sloc to be
+Cond   : in out Node_Id);
---  used for the generated code.
+--  Process component declaration or discriminant specification Field.
+--  Obj_Id denotes the entity of the validation parameter. Cond denotes
-------------------
+--  an "or else" conditional expression which contains the new code (if
--- Make_VS_Case --
+--  any).
-------------------
+procedure Validate_Fields
---  <Make_VS_If on shared components>
+(Obj_Id : Entity_Id;
+Fields : List_Id;
---  case X.D1 is
+Stmts  : in out List_Id);
---     when V1 => <Make_VS_Case> on subcomponents
+--  Process component declarations or discriminant specifications in list
---     ...
+--  Fields. Obj_Id denotes the entity of the validation parameter. All
---     when Vn => <Make_VS_Case> on subcomponents
+--  new code is added to list Stmts.
---  end case;
+procedure Validate_Variant
-function Make_VS_Case
+(Obj_Id : Entity_Id;
-(E      : Entity_Id;
+Var    : Node_Id;
-CL     : Node_Id;
+Alts   : in out List_Id);
-Discrs : Elist_Id := New_Elmt_List) return List_Id
+--  Process variant Var. Obj_Id denotes the entity of the validation
+--  parameter. Alts denotes a list of case statement alternatives which
+--  contains the new code (if any).
+procedure Validate_Variant_Part
+(Obj_Id   : Entity_Id;
+Var_Part : Node_Id;
+Stmts    : in out List_Id);
+--  Process variant part Var_Part. Obj_Id denotes the entity of the
+--  validation parameter. All new code is added to list Stmts.
+-----------------------------
+-- Validate_Component_List --
+-----------------------------
+procedure Validate_Component_List
+(Obj_Id    : Entity_Id;
+Comp_List : Node_Id;
+Stmts     : in out List_Id)
 is
-Loc      : constant Source_Ptr := Sloc (E);
+Var_Part : constant Node_Id := Variant_Part (Comp_List);
-Result   : constant List_Id    := New_List;
-Variant  : Node_Id;
-Alt_List : List_Id;
 begin
-Append_To (Result, Make_VS_If (E, Component_Items (CL)));
+--  Validate all components
-if No (Variant_Part (CL))
+Validate_Fields
-or else Is_Unchecked_Union (R_Type)
+(Obj_Id => Obj_Id,
+Fields => Component_Items (Comp_List),
+Stmts  => Stmts);
+--  Validate the variant part
+if Present (Var_Part) then
+Validate_Variant_Part
+(Obj_Id   => Obj_Id,
+Var_Part => Var_Part,
+Stmts    => Stmts);
+end if;
+end Validate_Component_List;
+--------------------
+-- Validate_Field --
+--------------------
+procedure Validate_Field
+(Obj_Id : Entity_Id;
+Field  : Node_Id;
+Cond   : in out Node_Id)
+is
+Field_Id  : constant Entity_Id := Defining_Entity (Field);
+Field_Nam : constant Name_Id   := Chars (Field_Id);
+Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
+Attr_Nam  : Name_Id;
+begin
+--  Do not process internally-generated fields. Note that checking for
+--  Comes_From_Source is not correct because this will eliminate the
+--  components within the corresponding record of a protected type.
+if Nam_In (Field_Nam, Name_uObject,
+Name_uParent,
+Name_uTag)
 then
-return Result;
+null;
-end if;
+--  Do not process fields without any scalar components
-Variant := First_Non_Pragma (Variants (Variant_Part (CL)));
+elsif not Scalar_Part_Present (Field_Typ) then
-if No (Variant) then
+null;
-return Result;
-end if;
+--  Otherwise the field needs to be validated. Use Make_Identifier
+--  rather than New_Occurrence_Of to identify the field because the
-Alt_List := New_List;
+--  wrong entity may be picked up when private types are involved.
-while Present (Variant) loop
-Append_To (Alt_List,
+--  Generate:
-Make_Case_Statement_Alternative (Loc,
+--    [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
-Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
-Statements       =>
+else
-Make_VS_Case (E, Component_List (Variant), Discrs)));
+if Is_Scalar_Type (Field_Typ) then
-Next_Non_Pragma (Variant);
+Attr_Nam := Name_Valid;
+else
+Attr_Nam := Name_Valid_Scalars;
+end if;
+Evolve_Or_Else (Cond,
+Make_Op_Not (Loc,
+Right_Opnd =>
+Make_Attribute_Reference (Loc,
+Prefix         =>
+Make_Selected_Component (Loc,
+Prefix        =>
+Unchecked_Convert_To (Rec_Typ,
+New_Occurrence_Of (Obj_Id, Loc)),
+Selector_Name => Make_Identifier (Loc, Field_Nam)),
+Attribute_Name => Attr_Nam)));
+end if;
+end Validate_Field;
+---------------------
+-- Validate_Fields --
+---------------------
+procedure Validate_Fields
+(Obj_Id : Entity_Id;
+Fields : List_Id;
+Stmts  : in out List_Id)
+is
+Cond  : Node_Id;
+Field : Node_Id;
+begin
+--  Assume that none of the fields are eligible for verification
+Cond := Empty;
+--  Validate all fields
+Field := First_Non_Pragma (Fields);
+while Present (Field) loop
+Validate_Field
+(Obj_Id => Obj_Id,
+Field  => Field,
+Cond   => Cond);
+Next_Non_Pragma (Field);
 end loop;
-Append_To (Result,
+--  Generate:
+--    if        not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
+--      or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
+--    then
+--       return False;
+--    end if;
+if Present (Cond) then
+Append_New_To (Stmts,
+Make_Implicit_If_Statement (Attr,
+Condition       => Cond,
+Then_Statements => New_List (
+Make_Simple_Return_Statement (Loc,
+Expression => New_Occurrence_Of (Standard_False, Loc)))));
+end if;
+end Validate_Fields;
+----------------------
+-- Validate_Variant --
+----------------------
+procedure Validate_Variant
+(Obj_Id : Entity_Id;
+Var    : Node_Id;
+Alts   : in out List_Id)
+is
+Stmts : List_Id;
+begin
+--  Assume that none of the components and variants are eligible for
+--  verification.
+Stmts := No_List;
+--  Validate componants
+Validate_Component_List
+(Obj_Id    => Obj_Id,
+Comp_List => Component_List (Var),
+Stmts     => Stmts);
+--  Generate a null statement in case none of the components were
+--  verified because this will otherwise eliminate an alternative
+--  from the variant case statement and render the generated code
+--  illegal.
+if No (Stmts) then
+Append_New_To (Stmts, Make_Null_Statement (Loc));
+end if;
+--  Generate:
+--    when Discrete_Choices =>
+--       Stmts
+Append_New_To (Alts,
+Make_Case_Statement_Alternative (Loc,
+Discrete_Choices =>
+New_Copy_List_Tree (Discrete_Choices (Var)),
+Statements       => Stmts));
+end Validate_Variant;
+---------------------------
+-- Validate_Variant_Part --
+---------------------------
+procedure Validate_Variant_Part
+(Obj_Id   : Entity_Id;
+Var_Part : Node_Id;
+Stmts    : in out List_Id)
+is
+Vars : constant List_Id := Variants (Var_Part);
+Alts : List_Id;
+Var  : Node_Id;
+begin
+--  Assume that none of the variants are eligible for verification
+Alts := No_List;
+--  Validate variants
+Var := First_Non_Pragma (Vars);
+while Present (Var) loop
+Validate_Variant
+(Obj_Id => Obj_Id,
+Var    => Var,
+Alts   => Alts);
+Next_Non_Pragma (Var);
+end loop;
+--  Even though individual variants may lack eligible components, the
+--  alternatives must still be generated.
+pragma Assert (Present (Alts));
+--  Generate:
+--    case Rec_Typ (Obj_Id).Discriminant is
+--       when Discrete_Choices_1 =>
+--          Stmts_1
+--       when Discrete_Choices_N =>
+--          Stmts_N
+--    end case;
+Append_New_To (Stmts,
 Make_Case_Statement (Loc,
 Expression   =>
 Make_Selected_Component (Loc,
-Prefix        => Make_Identifier (Loc, Name_X),
+Prefix        =>
-Selector_Name => New_Copy (Name (Variant_Part (CL)))),
+Unchecked_Convert_To (Rec_Typ,
-Alternatives => Alt_List));
+New_Occurrence_Of (Obj_Id, Loc)),
+Selector_Name => New_Copy_Tree (Name (Var_Part))),
-return Result;
+Alternatives => Alts));
-end Make_VS_Case;
+end Validate_Variant_Part;
-----------------
+--  Local variables
--- Make_VS_If --
-----------------
+Func_Id  : constant Entity_Id := Make_Temporary (Loc, 'V');
+Obj_Id   : constant Entity_Id := Make_Temporary (Loc, 'R');
---  Generates:
+Comps    : Node_Id;
+Stmts    : List_Id;
---    if
+Typ      : Entity_Id;
---      not X.C1'Valid_Scalars
+Typ_Decl : Node_Id;
---        or else
+Typ_Def  : Node_Id;
---      not X.C2'Valid_Scalars
+Typ_Ext  : Node_Id;
---        ...
---    then
+--  Start of processing for Build_Record_VS_Func
---       return False;
---    end if;
+begin
+Typ := Rec_Typ;
---  or a null statement if the list L is empty
+--  Use the root type when dealing with a class-wide type
-function Make_VS_If
-(E : Entity_Id;
+if Is_Class_Wide_Type (Typ) then
-L : List_Id) return Node_Id
+Typ := Root_Type (Typ);
-is
+end if;
-Loc        : constant Source_Ptr := Sloc (E);
-C          : Node_Id;
+Typ_Decl := Declaration_Node (Typ);
-Def_Id     : Entity_Id;
+Typ_Def  := Type_Definition (Typ_Decl);
-Field_Name : Name_Id;
-Cond       : Node_Id;
+--  The components of a derived type are located in the extension part
-begin
+if Nkind (Typ_Def) = N_Derived_Type_Definition then
-if No (L) then
+Typ_Ext := Record_Extension_Part (Typ_Def);
-return Make_Null_Statement (Loc);
+if Present (Typ_Ext) then
+Comps := Component_List (Typ_Ext);
 else
-Cond := Empty;
+Comps := Empty;
+end if;
-C := First_Non_Pragma (L);
-while Present (C) loop
+--  Otherwise the components are available in the definition
-Def_Id := Defining_Identifier (C);
-Field_Name := Chars (Def_Id);
+else
+Comps := Component_List (Typ_Def);
---  The tags need not be checked since they will always be valid
+end if;
---  Note also that in the following, we use Make_Identifier for
+--  The code generated by this routine is as follows:
---  the component names. Use of New_Occurrence_Of to identify
+--
---  the components would be incorrect because wrong entities for
+--    function Func_Id (Obj_Id : Formal_Typ) return Boolean is
---  discriminants could be picked up in the private type case.
+--    begin
+--       if not        Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
---  Don't bother with abstract parent in interface case
+--         or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
+--       then
-if Field_Name = Name_uParent
+--          return False;
-and then Is_Interface (Etype (Def_Id))
+--       end if;
-then
+--
-null;
+--       if not        Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
+--         or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
---  Don't bother with tag, always valid, and not scalar anyway
+--       then
+--          return False;
-elsif Field_Name = Name_uTag then
+--       end if;
-null;
+--
+--       case Discriminant_1 is
-elsif Ekind (Def_Id) = E_Discriminant
+--          when Choice_1 =>
-and then Is_Unchecked_Union (R_Type)
+--             if not        Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
-then
+--               or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
-null;
+--             then
+--                return False;
---  Don't bother with component with no scalar components
+--             end if;
+--
-elsif not Scalar_Part_Present (Etype (Def_Id)) then
+--             case Discriminant_N is
-null;
+--                ...
+--          when Choice_N =>
---  Normal case, generate Valid_Scalars attribute reference
+--             ...
+--       end case;
-else
+--
-Evolve_Or_Else (Cond,
+--       return True;
-Make_Op_Not (Loc,
+--    end Func_Id;
-Right_Opnd =>
-Make_Attribute_Reference (Loc,
+--  Assume that the record type lacks eligible components, discriminants,
-Prefix =>
+--  and variant parts.
-Make_Selected_Component (Loc,
-Prefix        =>
+Stmts := No_List;
-Make_Identifier (Loc, Name_X),
-Selector_Name =>
+--  Validate the discriminants
-Make_Identifier (Loc, Field_Name)),
-Attribute_Name => Name_Valid_Scalars)));
+if not Is_Unchecked_Union (Rec_Typ) then
-end if;
+Validate_Fields
+(Obj_Id => Obj_Id,
-Next_Non_Pragma (C);
+Fields => Discriminant_Specifications (Typ_Decl),
-end loop;
+Stmts  => Stmts);
+end if;
-if No (Cond) then
-return Make_Null_Statement (Loc);
+--  Validate the components and variant parts
-else
+Validate_Component_List
-return
+(Obj_Id    => Obj_Id,
-Make_Implicit_If_Statement (E,
+Comp_List => Comps,
-Condition       => Cond,
+Stmts     => Stmts);
-Then_Statements => New_List (
-Make_Simple_Return_Statement (Loc,
+--  Generate:
-Expression =>
+--    return True;
-New_Occurrence_Of (Standard_False, Loc))));
-end if;
+Append_New_To (Stmts,
-end if;
-end Make_VS_If;
---  Local variables
-Def    : constant Node_Id := Parent (R_Type);
-Comps  : constant Node_Id := Component_List (Type_Definition (Def));
-Stmts  : constant List_Id := New_List;
-Pspecs : constant List_Id := New_List;
---  Start of processing for Build_Record_VS_Func
-begin
-Append_To (Pspecs,
-Make_Parameter_Specification (Loc,
-Defining_Identifier => X,
-Parameter_Type      => New_Occurrence_Of (R_Type, Loc)));
-Append_To (Stmts,
-Make_VS_If (R_Type, Discriminant_Specifications (Def)));
-Append_List_To (Stmts, Make_VS_Case (R_Type, Comps));
-Append_To (Stmts,
 Make_Simple_Return_Statement (Loc,
 Expression => New_Occurrence_Of (Standard_True, Loc)));
-Insert_Action (Nod,
+--  Generate:
+--    function Func_Id (Obj_Id : Formal_Typ) return Boolean is
+--    begin
+--       Stmts
+--    end Func_Id;
+Set_Ekind       (Func_Id, E_Function);
+Set_Is_Internal (Func_Id);
+Set_Is_Pure     (Func_Id);
+if not Debug_Generated_Code then
+Set_Debug_Info_Off (Func_Id);
+end if;
+Insert_Action (Attr,
 Make_Subprogram_Body (Loc,
 Specification =>
 Make_Function_Specification (Loc,
 Defining_Unit_Name       => Func_Id,
-Parameter_Specifications => Pspecs,
+Parameter_Specifications => New_List (
-Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
+Make_Parameter_Specification (Loc,
+Defining_Identifier => Obj_Id,
+Parameter_Type      => New_Occurrence_Of (Formal_Typ, Loc))),
+Result_Definition        =>
+New_Occurrence_Of (Standard_Boolean, Loc)),
 Declarations               => New_List,
 Handled_Statement_Sequence =>
-Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)),
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => Stmts)),
 Suppress => Discriminant_Check);
-if not Debug_Generated_Code then
-Set_Debug_Info_Off (Func_Id);
-end if;
-Set_Is_Pure (Func_Id);
 return Func_Id;
 end Build_Record_VS_Func;
 ----------------------------------
 -- Compile_Stream_Body_In_Scope --
 Pref      : constant Node_Id   := Prefix (N);
 Base_Typ  : constant Entity_Id := Base_Type (Etype (Pref));
 Exprs     : constant List_Id   := Expressions (N);
 Aux_Decl  : Node_Id;
-Blk       : Node_Id;
+Blk       : Node_Id := Empty;
 Decls     : List_Id;
 Installed : Boolean;
 Loc       : Source_Ptr;
 Loop_Id   : Entity_Id;
 Loop_Stmt : Node_Id;
 Extra := New_Formal;
 Next_Formal (Old_Formal);
 exit when No (Old_Formal);
-Set_Next_Entity (New_Formal,
+Link_Entities (New_Formal, New_Copy (Old_Formal));
-New_Copy (Old_Formal));
+Next_Entity   (New_Formal);
-Next_Entity (New_Formal);
 end loop;
-Set_Next_Entity (New_Formal, Empty);
+Unlink_Next_Entity (New_Formal);
 Set_Last_Entity (Subp_Typ, Extra);
 end if;
 --  Now that the explicit formals have been duplicated,
 --  any extra formals needed by the subprogram must be
 end loop;
 --  Protected case
 if Is_Protected_Type (Conctyp) then
+--  No need to transform 'Count into a function call if the current
+--  scope has been eliminated. In this case such transformation is
+--  also not viable because the enclosing protected object is not
+--  available.
+if Is_Eliminated (Current_Scope) then
+return;
+end if;
 case Corresponding_Runtime_Package (Conctyp) is
 when System_Tasking_Protected_Objects_Entries =>
 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
 Call :=
 --  We do all the required analysis of the conversion here, because we do
 --  not want this to go through the fixed-point conversion circuits. Note
 --  that the back end always treats fixed-point as equivalent to the
 --  corresponding integer type anyway.
+--  However, in order to remove the handling of Do_Range_Check from the
+--  backend, we force the generation of a check on the result by
+--  setting the result type appropriately. Apply_Conversion_Checks
+--  will generate the required expansion.
 when Attribute_Fixed_Value
 | Attribute_Integer_Value
 =>
 Rewrite (N,
 Make_Type_Conversion (Loc,
 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
 Expression   => Relocate_Node (First (Exprs))));
-Set_Etype (N, Entity (Pref));
+--  Indicate that the result of the conversion may require a
+--  range check (see below);
+Set_Etype (N, Base_Type (Entity (Pref)));
 Set_Analyzed (N);
 --  Note: it might appear that a properly analyzed unchecked
 --  conversion would be just fine here, but that's not the case,
---  since the full range checks performed by the following call
+--  since the full range checks performed by the following code
 --  are critical.
+--  Given that Fixed-point conversions are not further expanded
-Apply_Type_Conversion_Checks (N);
+--  to prevent the involvement of real type operations we have to
+--  construct two checks explicitly: one on the operand, and one
+--  on the result. This used to be done in part in the back-end,
+--  but for other targets (E.g. LLVM) it is preferable to create
+--  the tests in full in the front-end.
+if Is_Fixed_Point_Type (Etype (N)) then
+declare
+Loc     : constant Source_Ptr := Sloc (N);
+Equiv_T : constant Entity_Id  := Make_Temporary (Loc, 'T', N);
+Expr    : constant Node_Id    := Expression (N);
+Fst     : constant Entity_Id  := Root_Type (Etype (N));
+Decl    : Node_Id;
+begin
+Decl :=
+Make_Full_Type_Declaration (Sloc (N),
+Defining_Identifier => Equiv_T,
+Type_Definition     =>
+Make_Signed_Integer_Type_Definition (Loc,
+Low_Bound  =>
+Make_Integer_Literal (Loc,
+Intval =>
+Corresponding_Integer_Value
+(Type_Low_Bound (Fst))),
+High_Bound =>
+Make_Integer_Literal (Loc,
+Intval =>
+Corresponding_Integer_Value
+(Type_High_Bound (Fst)))));
+Insert_Action (N, Decl);
+--  Verify that the conversion is possible
+Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed);
+--  and verify that the result is in range
+Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed);
+end;
+end if;
 -----------
 -- Floor --
 -----------
 --  The code for valid is dependent on the particular types involved.
 --  See separate sections below for the generated code in each case.
 when Attribute_Valid => Valid : declare
 Btyp : Entity_Id := Base_Type (Ptyp);
-Tst  : Node_Id;
 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
 --  Save the validity checking mode. We always turn off validity
 --  checking during process of 'Valid since this is one place
---  where we do not want the implicit validity checks to intefere
+--  where we do not want the implicit validity checks to interfere
 --  with the explicit validity check that the programmer is doing.
 function Make_Range_Test return Node_Id;
 --  Build the code for a range test of the form
 --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
 Make_Attribute_Reference (Loc,
 Prefix         => New_Occurrence_Of (Ptyp, Loc),
 Attribute_Name => Name_Last))));
 end Make_Range_Test;
+--  Local variables
+Tst : Node_Id;
 --  Start of processing for Attribute_Valid
 begin
 --  Do not expand sourced code 'Valid reference in CodePeer mode,
 --  will be handled by the back-end directly.
 -------------------
 -- Valid_Scalars --
 -------------------
 when Attribute_Valid_Scalars => Valid_Scalars : declare
-Ftyp : Entity_Id;
+Val_Typ  : constant Entity_Id := Validated_View (Ptyp);
+Comp_Typ : Entity_Id;
+Expr     : Node_Id;
 begin
-if Present (Underlying_Type (Ptyp)) then
+--  Assume that the prefix does not need validation
-Ftyp := Underlying_Type (Ptyp);
-else
+Expr := Empty;
-Ftyp := Ptyp;
-end if;
+--  Attribute 'Valid_Scalars is not supported on private tagged types
---  Replace by True if no scalar parts
+if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
+null;
-if not Scalar_Part_Present (Ftyp) then
-Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+--  Attribute 'Valid_Scalars evaluates to True when the type lacks
+--  scalars.
---  For scalar types, Valid_Scalars is the same as Valid
+elsif not Scalar_Part_Present (Val_Typ) then
-elsif Is_Scalar_Type (Ftyp) then
+null;
-Rewrite (N,
+--  Attribute 'Valid_Scalars is the same as attribute 'Valid when the
+--  validated type is a scalar type. Generate:
+--    Val_Typ (Pref)'Valid
+elsif Is_Scalar_Type (Val_Typ) then
+Expr :=
 Make_Attribute_Reference (Loc,
-Attribute_Name => Name_Valid,
+Prefix         =>
-Prefix         => Pref));
+Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
+Attribute_Name => Name_Valid);
---  For array types, we construct a function that determines if there
---  are any non-valid scalar subcomponents, and call the function.
+--  Validate the scalar components of an array by iterating over all
---  We only do this for arrays whose component type needs checking
+--  dimensions of the array while checking individual components.
-elsif Is_Array_Type (Ftyp)
+elsif Is_Array_Type (Val_Typ) then
-and then Scalar_Part_Present (Component_Type (Ftyp))
+Comp_Typ := Validated_View (Component_Type (Val_Typ));
-then
-Rewrite (N,
+if Scalar_Part_Present (Comp_Typ) then
+Expr :=
+Make_Function_Call (Loc,
+Name                   =>
+New_Occurrence_Of
+(Build_Array_VS_Func
+(Attr       => N,
+Formal_Typ => Ptyp,
+Array_Typ  => Val_Typ,
+Comp_Typ   => Comp_Typ),
+Loc),
+Parameter_Associations => New_List (Pref));
+end if;
+--  Validate the scalar components, discriminants of a record type by
+--  examining the structure of a record type.
+elsif Is_Record_Type (Val_Typ) then
+Expr :=
 Make_Function_Call (Loc,
 Name                   =>
-New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
+New_Occurrence_Of
-Parameter_Associations => New_List (Pref)));
+(Build_Record_VS_Func
+(Attr       => N,
---  For record types, we construct a function that determines if there
+Formal_Typ => Ptyp,
---  are any non-valid scalar subcomponents, and call the function.
+Rec_Typ    => Val_Typ),
+Loc),
-elsif Is_Record_Type (Ftyp)
+Parameter_Associations => New_List (Pref));
-and then Present (Declaration_Node (Ftyp))
+end if;
-and then Nkind (Type_Definition (Declaration_Node (Ftyp))) =
-N_Record_Definition
+--  Default the attribute to True when the type of the prefix does not
-then
+--  need validation.
-Rewrite (N,
-Make_Function_Call (Loc,
+if No (Expr) then
-Name                   =>
+Expr := New_Occurrence_Of (Standard_True, Loc);
-New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc),
+end if;
-Parameter_Associations => New_List (Pref)));
+Rewrite (N, Expr);
---  Other record types or types with discriminants
-elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then
---  Build expression with list of equality tests
-declare
-C : Entity_Id;
-X : Node_Id;
-A : Name_Id;
-begin
-X := New_Occurrence_Of (Standard_True, Loc);
-C := First_Component_Or_Discriminant (Ptyp);
-while Present (C) loop
-if not Scalar_Part_Present (Etype (C)) then
-goto Continue;
-elsif Is_Scalar_Type (Etype (C)) then
-A := Name_Valid;
-else
-A := Name_Valid_Scalars;
-end if;
-X :=
-Make_And_Then (Loc,
-Left_Opnd   => X,
-Right_Opnd  =>
-Make_Attribute_Reference (Loc,
-Attribute_Name => A,
-Prefix         =>
-Make_Selected_Component (Loc,
-Prefix        =>
-Duplicate_Subexpr (Pref, Name_Req => True),
-Selector_Name =>
-New_Occurrence_Of (C, Loc))));
-<<Continue>>
-Next_Component_Or_Discriminant (C);
-end loop;
-Rewrite (N, X);
-end;
---  For all other types, result is True
-else
-Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
-end if;
---  Result is always boolean, but never static
 Analyze_And_Resolve (N, Standard_Boolean);
 Set_Is_Static_Expression (N, False);
 end Valid_Scalars;
 -----------
 end Is_GCC_Target;
 --  Start of processing for Is_Inline_Floating_Point_Attribute
 begin
---  Machine and Model can be expanded by the GCC and AAMP back ends only
+--  Machine and Model can be expanded by the GCC back end only
 if Id = Attribute_Machine or else Id = Attribute_Model then
 return Is_GCC_Target;
 --  Remaining cases handled by all back ends are Rounding and Truncation

Mercurial > hg > CbC > CbC_gcc

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