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

comparison gcc/ada/sem_ch8.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 _ C H 8                               --
 --                                                                          --
 --                                 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 Sem_Dim;  use Sem_Dim;
 with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Elab; use Sem_Elab;
 with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Type; use Sem_Type;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 --    If Ren is a renaming of a formal function and its return
 --    profile has a null exclusion, then Sub's return profile must
 --    have one. Otherwise the subtype of Sub's return profile must
 --    exclude null.
+procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id);
+--  Ensure that a SPARK renaming denoted by its entity Subp_Id does not
+--  declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)).
 procedure Freeze_Actual_Profile;
 --  In Ada 2012, enforce the freezing rule concerning formal incomplete
 --  types: a callable entity freezes its profile, unless it has an
 --  incomplete untagged formal (RM 13.14(10.2/3)).
 Error_Msg_N
 ("return must specify `NOT NULL`",
 Result_Definition (Parent (Sub)));
 end if;
 end Check_Null_Exclusion;
+-------------------------------------
+-- Check_SPARK_Primitive_Operation --
+-------------------------------------
+procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is
+Prag : constant Node_Id := SPARK_Pragma (Subp_Id);
+Typ  : Entity_Id;
+begin
+--  Nothing to do when the subprogram is not subject to SPARK_Mode On
+--  because this check applies to SPARK code only.
+if not (Present (Prag)
+and then Get_SPARK_Mode_From_Annotation (Prag) = On)
+then
+return;
+--  Nothing to do when the subprogram is not a primitive operation
+elsif not Is_Primitive (Subp_Id) then
+return;
+end if;
+Typ := Find_Dispatching_Type (Subp_Id);
+--  Nothing to do when the subprogram is a primitive operation of an
+--  untagged type.
+if No (Typ) then
+return;
+end if;
+--  At this point a renaming declaration introduces a new primitive
+--  operation for a tagged type.
+Error_Msg_Node_2 := Typ;
+Error_Msg_NE
+("subprogram renaming & cannot declare primitive for type & "
+& "(SPARK RM 6.1.1(3))", N, Subp_Id);
+end Check_SPARK_Primitive_Operation;
 ---------------------------
 -- Freeze_Actual_Profile --
 ---------------------------
 Set_Is_Pure (New_S, Is_Pure (Current_Scope));
 end if;
 --  Set SPARK mode from current context
-Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma);
+Set_SPARK_Pragma           (New_S, SPARK_Mode_Pragma);
 Set_SPARK_Pragma_Inherited (New_S);
 Rename_Spec := Find_Corresponding_Spec (N);
 --  Case of Renaming_As_Body
 else
 Generate_Definition (New_S);
 New_Overloaded_Entity (New_S);
-if Is_Entity_Name (Nam)
+if not (Is_Entity_Name (Nam)
-and then Is_Intrinsic_Subprogram (Entity (Nam))
+and then Is_Intrinsic_Subprogram (Entity (Nam)))
 then
-null;
-else
 Check_Delayed_Subprogram (New_S);
 end if;
+--  Verify that a SPARK renaming does not declare a primitive
+--  operation of a tagged type.
+Check_SPARK_Primitive_Operation (New_S);
 end if;
 --  There is no need for elaboration checks on the new entity, which may
 --  be called before the next freezing point where the body will appear.
 --  Elaboration checks refer to the real entity, not the one created by
 elsif not Ekind_In (Old_S, E_Function, E_Procedure) then
 null;
 elsif Requires_Overriding (Old_S)
 or else
 (Is_Abstract_Subprogram (Old_S)
 and then Present (Find_Dispatching_Type (Old_S))
-and then
+and then not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
-not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
 then
 Error_Msg_N
 ("renamed entity cannot be subprogram that requires overriding "
 & "(RM 8.5.4 (5.1))", N);
 end if;
 --  Check if we are looking at an Ada 2012 defaulted formal subprogram
 --  and mark any use_package_clauses that affect the visibility of the
 --  implicit generic actual.
+--  Also, we may be looking at an internal renaming of a user-defined
+--  subprogram created for a generic formal subprogram association,
+--  which will also have to be marked here. This can occur when the
+--  corresponding formal subprogram contains references to other generic
+--  formals.
 if Is_Generic_Actual_Subprogram (New_S)
-and then (Is_Intrinsic_Subprogram (New_S) or else From_Default (N))
+and then (Is_Intrinsic_Subprogram (New_S)
+or else From_Default (N)
+or else Nkind (N) = N_Subprogram_Renaming_Declaration)
 then
 Mark_Use_Clauses (New_S);
 --  Handle overloaded subprograms
 end loop;
 end Analyze_Package_Name_List;
 --  Local variables
-Ghost_Id  : Entity_Id := Empty;
+Pack : Entity_Id;
-Living_Id : Entity_Id := Empty;
-Pack      : Entity_Id;
 --  Start of processing for Analyze_Use_Package
 begin
 Check_SPARK_05_Restriction ("use clause is not allowed", N);
 if Nkind (Parent (N)) = N_Compilation_Unit then
 Check_In_Previous_With_Clause (N, Name (N));
 end if;
 Use_One_Package (N, Name (N));
+end if;
---  Capture the first Ghost package and the first living package
+Mark_Ghost_Clause (N);
-if Is_Entity_Name (Name (N)) then
-Pack := Entity (Name (N));
-if Is_Ghost_Entity (Pack) then
-if No (Ghost_Id) then
-Ghost_Id := Pack;
-end if;
-elsif No (Living_Id) then
-Living_Id := Pack;
-end if;
-end if;
-end if;
 end Analyze_Use_Package;
 ----------------------
 -- Analyze_Use_Type --
 ----------------------
 --  There are many cases where a use_type_clause may be reanalyzed due to
 --  manipulation of the scope stack so we much guard against those cases
 --  here, otherwise, we must add the new use_type_clause to the previous
 --  use_type_clause chain in order to mark redundant use_type_clauses as
---  used.
+--  used. When the redundant use-type clauses appear in a parent unit and
+--  a child unit we must prevent a circularity in the chain that would
+--  otherwise result from the separate steps of analysis and installation
+--  of the parent context.
 if Present (Current_Use_Clause (E))
 and then Current_Use_Clause (E) /= N
+and then Prev_Use_Clause (Current_Use_Clause (E)) /= N
 and then No (Prev_Use_Clause (N))
 then
 Set_Prev_Use_Clause (N, Current_Use_Clause (E));
 end if;
 if Is_Compilation_Unit (New_S) then
 Error_Msg_N
 ("a library unit can only rename another library unit", N);
 end if;
+--  We suppress elaboration warnings for the resulting entity, since
+--  clearly they are not needed, and more particularly, in the case
+--  of a generic formal subprogram, the resulting entity can appear
+--  after the instantiation itself, and thus look like a bogus case
+--  of access before elaboration.
+if Legacy_Elaboration_Checks then
+Set_Suppress_Elaboration_Warnings (New_S);
+end if;
 end Attribute_Renaming;
 ----------------------
 -- Chain_Use_Clause --
 ----------------------
 else
 Insert_After (N, B_Node);
 Analyze (B_Node);
 end if;
-if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then
+if Is_Intrinsic_Subprogram (Old_S)
+and then not In_Instance
+and then not Relaxed_RM_Semantics
+then
 Error_Msg_N
 ("subprogram used in renaming_as_body cannot be intrinsic",
 Name (N));
 end if;
 --  Come here with entity set
 <<Done>>
 Check_Restriction_No_Use_Of_Entity (N);
---  Save the scenario for later examination by the ABE Processing phase
+--  Annotate the tree by creating a variable reference marker in case the
+--  original variable reference is folded or optimized away. The variable
-Record_Elaboration_Scenario (N);
+--  reference marker is automatically saved for later examination by the
+--  ABE Processing phase. Variable references which act as actuals in a
+--  call require special processing and are left to Resolve_Actuals. The
+--  reference is a write when it appears on the left hand side of an
+--  assignment.
+if Needs_Variable_Reference_Marker
+(N        => N,
+Calls_OK => False)
+then
+declare
+Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes;
+begin
+Build_Variable_Reference_Marker
+(N     => N,
+Read  => not Is_Assignment_LHS,
+Write => Is_Assignment_LHS);
+end;
+end if;
 end Find_Direct_Name;
 ------------------------
 -- Find_Expanded_Name --
 ------------------------
 return False;
 end In_Abstract_View_Pragma;
 --  Local variables
-Selector  : constant Node_Id := Selector_Name (N);
+Selector : constant Node_Id := Selector_Name (N);
-Candidate : Entity_Id        := Empty;
+Candidate : Entity_Id := Empty;
 P_Name    : Entity_Id;
 Id        : Entity_Id;
 --  Start of processing for Find_Expanded_Name
 end if;
 --  If this is a selection from Ada, System or Interfaces, then
 --  we assume a missing with for the corresponding package.
-if Is_Known_Unit (N) then
+if Is_Known_Unit (N)
+and then not (Present (Entity (Prefix (N)))
+and then Scope (Entity (Prefix (N))) /=
+Standard_Standard)
+then
 if not Error_Posted (N) then
 Error_Msg_Node_2 := Selector;
 Error_Msg_N -- CODEFIX
 ("missing `WITH &.&;`", Prefix (N));
 end if;
 Mark_Use_Clauses (N);
 end if;
 Check_Restriction_No_Use_Of_Entity (N);
---  Save the scenario for later examination by the ABE Processing phase
+--  Annotate the tree by creating a variable reference marker in case the
+--  original variable reference is folded or optimized away. The variable
-Record_Elaboration_Scenario (N);
+--  reference marker is automatically saved for later examination by the
+--  ABE Processing phase. Variable references which act as actuals in a
+--  call require special processing and are left to Resolve_Actuals. The
+--  reference is a write when it appears on the left hand side of an
+--  assignment.
+if Needs_Variable_Reference_Marker
+(N        => N,
+Calls_OK => False)
+then
+declare
+Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes;
+begin
+Build_Variable_Reference_Marker
+(N     => N,
+Read  => not Is_Assignment_LHS,
+Write => Is_Assignment_LHS);
+end;
+end if;
 end Find_Expanded_Name;
 --------------------
 -- Find_Most_Prev --
 --------------------
 Set_Etype (P, Designated_Type (Etype (Prefix (P))));
 end;
 end if;
 --  If the selected component appears within a default expression
---  and it has an actual subtype, the pre-analysis has not yet
+--  and it has an actual subtype, the preanalysis has not yet
 --  completed its analysis, because Insert_Actions is disabled in
 --  that context. Within the init proc of the enclosing type we
 --  must complete this analysis, if an actual subtype was created.
 elsif Inside_Init_Proc then
 -- Mark_Use_Type --
 -------------------
 procedure Mark_Use_Type (E : Entity_Id) is
 Curr : Node_Id;
+Base : Entity_Id;
 begin
 --  Ignore void types and unresolved string literals and primitives
 if Nkind (E) = N_String_Literal
 or else not Is_Type (Etype (E))
 then
 return;
 end if;
+--  Primitives with class-wide operands might additionally render
+--  their base type's use_clauses effective - so do a recursive check
+--  here.
+Base := Base_Type (Etype (E));
+if Ekind (Base) = E_Class_Wide_Type then
+Mark_Use_Type (Base);
+end if;
 --  The package containing the type or operator function being used
 --  may be in use as well, so mark any use_package_clauses for it as
 --  effective. There are also additional sanity checks performed here
 --  for ignoring previous errors.
-Mark_Use_Package (Scope (Base_Type (Etype (E))));
+Mark_Use_Package (Scope (Base));
 if Nkind (E) in N_Op
 and then Present (Entity (E))
 and then Present (Scope (Entity (E)))
 then
 Mark_Use_Package (Scope (Entity (E)));
 end if;
-Curr := Current_Use_Clause (Base_Type (Etype (E)));
+Curr := Current_Use_Clause (Base);
 while Present (Curr)
 and then not Is_Effective_Use_Clause (Curr)
 loop
 --  Current use_type_clause may render other use_package_clauses
 --  effective.
 elsif (Ekind (Id) in Overloadable_Kind
 or else Ekind_In (Id, E_Generic_Function,
 E_Generic_Procedure))
 and then (Is_Potentially_Use_Visible (Id)
-or else Is_Intrinsic_Subprogram (Id))
+or else Is_Intrinsic_Subprogram (Id)
+or else (Ekind_In (Id, E_Function, E_Procedure)
+and then Is_Generic_Actual_Subprogram (Id)))
 then
 Mark_Parameters (Id);
 end if;
 --  Handle nodes
 function Most_Descendant_Use_Clause
 (Clause1 : Entity_Id;
 Clause2 : Entity_Id) return Entity_Id
 is
-Scope1, Scope2 : Entity_Id;
+Scope1 : Entity_Id;
+Scope2 : Entity_Id;
 begin
 if Clause1 = Clause2 then
 return Clause1;
 end if;
 Withn :=
 Make_With_Clause (Loc,
 Name =>
 Make_Expanded_Name (Loc,
-Chars  => Chars (System_Aux_Id),
+Chars         => Chars (System_Aux_Id),
-Prefix => New_Occurrence_Of (Scope (System_Aux_Id), Loc),
+Prefix        =>
+New_Occurrence_Of (Scope (System_Aux_Id), Loc),
 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc)));
 Set_Entity (Name (Withn), System_Aux_Id);
+Set_Corresponding_Spec (Withn, System_Aux_Id);
+Set_First_Name         (Withn);
+Set_Implicit_With      (Withn);
 Set_Library_Unit       (Withn, Cunit (Unum));
-Set_Corresponding_Spec (Withn, System_Aux_Id);
-Set_First_Name         (Withn, True);
-Set_Implicit_With      (Withn, True);
 Insert_After (With_Sys, Withn);
 Mark_Rewrite_Insertion (Withn);
 Set_Context_Installed (Withn);
 -----------------------------
 -- Update_Use_Clause_Chain --
 -----------------------------
 procedure Update_Use_Clause_Chain is
 procedure Update_Chain_In_Scope (Level : Int);
 --  Iterate through one level in the scope stack verifying each use-type
 --  clause within said level is used then reset the Current_Use_Clause
 --  to a redundant use clause outside of the current ending scope if such
 --  a clause exists.
 if Check_Unreferenced
 and then Comes_From_Source (Curr)
 and then not Is_Effective_Use_Clause (Curr)
 and then not In_Instance
+and then not In_Inlined_Body
 then
 --  We are dealing with a potentially unused use_package_clause
 if Nkind (Curr) = N_Use_Package_Clause then
 --  Renamings and formal subprograms may cause the associated
---  to be marked as effective instead of the original.
+--  node to be marked as effective instead of the original.
 if not (Present (Associated_Node (N))
 and then Present
 (Current_Use_Clause
 (Associated_Node (N)))
 return;
 --  Warn about detected redundant clauses
-elsif In_Open_Scopes (P) and not Force then
+elsif not Force
+and then In_Open_Scopes (P)
+and then not Is_Hidden_Open_Scope (P)
+then
 if Warn_On_Redundant_Constructs and then P = Current_Scope then
 Error_Msg_NE -- CODEFIX
 ("& is already use-visible within itself?r?",
 Pack_Name, P);
 end if;
 --  no redundancy between an outer use_clause and one that appears
 --  within the generic.
 and then not Spec_Reloaded_For_Body
 and then not In_Instance
+and then not In_Inlined_Body
 then
 --  The type already has a use clause
 if In_Use (T) then

Mercurial > hg > CbC > CbC_gcc

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