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

comparison gcc/ada/sem_ch7.adb @ 145:1830386684a0

gcc-9.2.0

author	anatofuz
date	Thu, 13 Feb 2020 11:34:05 +0900
parents	84e7813d76e9
children

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 --                                                                          --
 --                              S E M _ C H 7                               --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2019, 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- --
 if Is_Generic_Unit (Decl_Id) then
 return True;
 end if;
 --  An inlined subprogram body acts as a referencer
+--  unless we generate C code since inlining is then
+--  handled by the C compiler.
 --  Note that we test Has_Pragma_Inline here in addition
 --  to Is_Inlined. We are doing this for a client, since
 --  we are computing which entities should be public, and
 --  it is the client who will decide if actual inlining
 --  should occur, so we need to catch all cases where the
 --  subprogram may be inlined by the client.
-if Is_Inlined (Decl_Id)
+if not Generate_C_Code
-or else Has_Pragma_Inline (Decl_Id)
+and then (Is_Inlined (Decl_Id)
+or else Has_Pragma_Inline (Decl_Id))
 then
 Has_Referencer_Of_Non_Subprograms := True;
 --  Inspect the statements of the subprogram body
 --  to determine whether the body references other
 else
 Decl_Id := Defining_Entity (Decl);
 --  An inlined subprogram body acts as a referencer
+--  unless we generate C code since inlining is then
-if Is_Inlined (Decl_Id)
+--  handled by the C compiler.
-or else Has_Pragma_Inline (Decl_Id)
+if not Generate_C_Code
+and then (Is_Inlined (Decl_Id)
+or else Has_Pragma_Inline (Decl_Id))
 then
 Has_Referencer_Of_Non_Subprograms := True;
 --  Inspect the statements of the subprogram body
 --  to determine whether the body references other
 --  Local variables
 Saved_GM   : constant Ghost_Mode_Type := Ghost_Mode;
 Saved_IGR  : constant Node_Id         := Ignored_Ghost_Region;
+Saved_EA   : constant Boolean         := Expander_Active;
 Saved_ISMP : constant Boolean         :=
 Ignore_SPARK_Mode_Pragmas_In_Instance;
 --  Save the Ghost and SPARK mode-related data to restore on exit
 Body_Id          : Entity_Id;
 --  the mode now to ensure that any nodes generated during analysis and
 --  expansion are properly flagged as ignored Ghost.
 Mark_And_Set_Ghost_Body (N, Spec_Id);
+--  Deactivate expansion inside the body of ignored Ghost entities,
+--  as this code will ultimately be ignored. This avoids requiring the
+--  presence of run-time units which are not needed. Only do this for
+--  user entities, as internally generated entities might still need
+--  to be expanded (e.g. those generated for types).
+if Present (Ignored_Ghost_Region)
+and then Comes_From_Source (Body_Id)
+then
+Expander_Active := False;
+end if;
 --  If the body completes the initial declaration of a compilation unit
 --  which is subject to pragma Elaboration_Checks, set the model of the
 --  pragma because it applies to all parts of the unit.
 Install_Elaboration_Model (Spec_Id);
 Set_Use (Private_Declarations (Specification (Pack_Decl)));
 --  This is a nested package, so it may be necessary to declare certain
 --  inherited subprograms that are not yet visible because the parent
 --  type's subprograms are now visible.
+--  Note that for child units these operations were generated when
+--  analyzing the package specification.
 if Ekind (Scope (Spec_Id)) = E_Package
 and then Scope (Spec_Id) /= Standard_Standard
+and then not Is_Child_Unit (Spec_Id)
 then
 Declare_Inherited_Private_Subprograms (Spec_Id);
 end if;
 if Present (Declarations (N)) then
 --  At this point all entities of the package body are externally visible
 --  to the linker as their Is_Public flag is set to True. This proactive
 --  approach is necessary because an inlined or a generic body for which
 --  code is generated in other units may need to see these entities. Cut
---  down the number of global symbols that do not neet public visibility
+--  down the number of global symbols that do not need public visibility
 --  as this has two beneficial effects:
 --    (1) It makes the compilation process more efficient.
 --    (2) It gives the code generator more leeway to optimize within each
 --        unit, especially subprograms.
 if Is_Generic_Instance (Spec_Id)
 and then Operating_Mode = Generate_Code
 then
 Qualify_Entity_Names (N);
 end if;
+end if;
+if Present (Ignored_Ghost_Region) then
+Expander_Active := Saved_EA;
 end if;
 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP;
 Restore_Ghost_Region (Saved_GM, Saved_IGR);
 end Analyze_Package_Body_Helper;
 --  the chain whose first element is FE. A recursive call is made for all
 --  packages and generic packages.
 procedure Generate_Parent_References;
 --  For a child unit, generate references to parent units, for
---  GPS navigation purposes.
+--  GNAT Studio navigation purposes.
 function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
 --  Child and Unit are entities of compilation units. True if Child
 --  is a public child of Parent as defined in 10.1.1
 if Present (Renamed_Entity (Inst_Par)) then
 Inst_Par := Renamed_Entity (Inst_Par);
 end if;
-Gen_Par :=
+--  The instance may appear in a sibling generic unit, in
-Generic_Parent
+--  which case the prefix must include the common (generic)
-(Specification (Unit_Declaration_Node (Inst_Par)));
+--  ancestor, which is treated as a current instance.
+if Inside_A_Generic
+and then Ekind (Inst_Par) = E_Generic_Package
+then
+Gen_Par := Inst_Par;
+pragma Assert (In_Open_Scopes (Gen_Par));
+else
+Gen_Par :=
+Generic_Parent
+(Specification (Unit_Declaration_Node (Inst_Par)));
+end if;
 --  Install the private declarations and private use clauses
 --  of a parent instance of the child instance, unless the
 --  parent instance private declarations have already been
 --  installed earlier in Analyze_Package_Specification, which
 else
 Set_First_Private_Entity (Id, First_Entity (Id));
 end if;
 --  There may be inherited private subprograms that need to be declared,
---  even in the absence of an explicit private part.  If there are any
+--  even in the absence of an explicit private part. If there are any
 --  public declarations in the package and the package is a public child
 --  unit, then an implicit private part is assumed.
 elsif Present (L) and then Public_Child then
 Set_In_Private_Part (Id);
 then
 Unit_Requires_Body_Info (Id);
 end if;
 --  Nested package specs that do not require bodies are not checked for
---  ineffective use clauses due to the possbility of subunits. This is
+--  ineffective use clauses due to the possibility of subunits. This is
 --  because at this stage it is impossible to tell whether there will be
 --  a separate body.
 if not Unit_Requires_Body (Id)
 and then Is_Compilation_Unit (Id)
 Priv_Deps : Elist_Id;
 procedure Swap_Private_Dependents (Priv_Deps : Elist_Id);
 --  When the full view of a private type is made available, we do the
 --  same for its private dependents under proper visibility conditions.
---  When compiling a grand-chid unit this needs to be done recursively.
+--  When compiling a child unit this needs to be done recursively.
 -----------------------------
 -- Swap_Private_Dependents --
 -----------------------------
 procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is
+Cunit     : Entity_Id;
 Deps      : Elist_Id;
 Priv      : Entity_Id;
 Priv_Elmt : Elmt_Id;
 Is_Priv   : Boolean;
 --  installed due to a previous call.
 if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv)
 then
 if Is_Private_Type (Priv) then
+Cunit := Cunit_Entity (Current_Sem_Unit);
 Deps := Private_Dependents (Priv);
 Is_Priv := True;
 else
 Is_Priv := False;
 end if;
 (Priv, In_Open_Scopes (Scope (Priv)));
 Set_Is_Potentially_Use_Visible
 (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
---  Within a child unit, recurse, except in generic child unit,
+--  Recurse for child units, except in generic child units,
---  which (unfortunately) handle private_dependents separately.
+--  which unfortunately handle private_dependents separately.
+--  Note that the current unit may not have been analyzed,
+--  for example a package body, so we cannot rely solely on
+--  the Is_Child_Unit flag, but that's only an optimization.
 if Is_Priv
-and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
+and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit))
 and then not Is_Empty_Elmt_List (Deps)
 and then not Inside_A_Generic
 then
 Swap_Private_Dependents (Deps);
 end if;
 procedure Uninstall_Declarations (P : Entity_Id) is
 Decl      : constant Node_Id := Unit_Declaration_Node (P);
 Id        : Entity_Id;
 Full      : Entity_Id;
-Priv_Elmt : Elmt_Id;
-Priv_Sub  : Entity_Id;
 procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id);
 --  Copy to the private declaration the attributes of the full view that
 --  need to be available for the partial view also.
+procedure Swap_Private_Dependents (Priv_Deps : Elist_Id);
+--  When the full view of a private type is made unavailable, we do the
+--  same for its private dependents under proper visibility conditions.
+--  When compiling a child unit this needs to be done recursively.
 function Type_In_Use (T : Entity_Id) return Boolean;
 --  Check whether type or base type appear in an active use_type clause
 ------------------------------
 (Priv, Has_Controlled_Component (Full_Base));
 Propagate_Concurrent_Flags (Priv, Base_Type (Full));
 end if;
+--  As explained in Freeze_Entity, private types are required to point
+--  to the same freeze node as their corresponding full view, if any.
+--  But we ought not to overwrite a node already inserted in the tree.
+pragma Assert
+(Serious_Errors_Detected /= 0
+or else No (Freeze_Node (Priv))
+or else No (Parent (Freeze_Node (Priv)))
+or else Freeze_Node (Priv) = Freeze_Node (Full));
 Set_Freeze_Node (Priv, Freeze_Node (Full));
 --  Propagate Default_Initial_Condition-related attributes from the
 --  base type of the full view to the full view and vice versa. This
 --  may seem strange, but is necessary depending on which type
 Set_Discriminant_Constraint (Priv,
 Discriminant_Constraint (Full));
 end if;
 end if;
 end Preserve_Full_Attributes;
+-----------------------------
+-- Swap_Private_Dependents --
+-----------------------------
+procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is
+Cunit     : Entity_Id;
+Deps      : Elist_Id;
+Priv      : Entity_Id;
+Priv_Elmt : Elmt_Id;
+Is_Priv   : Boolean;
+begin
+Priv_Elmt := First_Elmt (Priv_Deps);
+while Present (Priv_Elmt) loop
+Priv := Node (Priv_Elmt);
+--  Before we do the swap, we verify the presence of the Full_View
+--  field, which may be empty due to a swap by a previous call to
+--  End_Package_Scope (e.g. from the freezing mechanism).
+if Present (Full_View (Priv)) then
+if Is_Private_Type (Priv) then
+Cunit := Cunit_Entity (Current_Sem_Unit);
+Deps := Private_Dependents (Priv);
+Is_Priv := True;
+else
+Is_Priv := False;
+end if;
+if Scope (Priv) = P
+or else not In_Open_Scopes (Scope (Priv))
+then
+Set_Is_Immediately_Visible (Priv, False);
+end if;
+if Is_Visible_Dependent (Priv) then
+Preserve_Full_Attributes (Priv, Full_View (Priv));
+Replace_Elmt (Priv_Elmt, Full_View (Priv));
+Exchange_Declarations (Priv);
+--  Recurse for child units, except in generic child units,
+--  which unfortunately handle private_dependents separately.
+--  Note that the current unit may not have been analyzed,
+--  for example a package body, so we cannot rely solely on
+--  the Is_Child_Unit flag, but that's only an optimization.
+if Is_Priv
+and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit))
+and then not Is_Empty_Elmt_List (Deps)
+and then not Inside_A_Generic
+then
+Swap_Private_Dependents (Deps);
+end if;
+end if;
+end if;
+Next_Elmt (Priv_Elmt);
+end loop;
+end Swap_Private_Dependents;
 -----------------
 -- Type_In_Use --
 -----------------
 --  established by use clauses in the current scope. Two cases:
 --  a) If the entity is an operator, it may be a primitive operator of
 --  a type for which there is a visible use-type clause.
---  b) for other entities, their use-visibility is determined by a
+--  b) For other entities, their use-visibility is determined by a
---  visible use clause for the package itself. For a generic instance,
+--  visible use clause for the package itself or a use-all-type clause
+--  applied directly to the entity's type. For a generic instance,
 --  the instantiation of the formals appears in the visible part,
 --  but the formals are private and remain so.
 if Ekind (Id) = E_Function
 and then Is_Operator_Symbol_Name (Chars (Id))
 (Id, Is_Visible_Lib_Unit (Id));
 else
 Set_Is_Potentially_Use_Visible (Id);
 end if;
+--  We need to avoid incorrectly marking enumeration literals as
+--  non-visible when a visible use-all-type clause is in effect.
+elsif Type_In_Use (Etype (Id))
+and then Nkind (Current_Use_Clause (Etype (Id))) =
+N_Use_Type_Clause
+and then All_Present (Current_Use_Clause (Etype (Id)))
+then
+null;
 else
 Set_Is_Potentially_Use_Visible (Id, False);
 end if;
 end if;
 --  Swap out the subtypes and derived types of Id that
 --  were compiled in this scope, or installed previously
 --  by Install_Private_Declarations.
---  Before we do the swap, we verify the presence of the Full_View
+Swap_Private_Dependents (Private_Dependents (Id));
---  field which may be empty due to a swap by a previous call to
---  End_Package_Scope (e.g. from the freezing mechanism).
-Priv_Elmt := First_Elmt (Private_Dependents (Id));
-while Present (Priv_Elmt) loop
-Priv_Sub := Node (Priv_Elmt);
-if Present (Full_View (Priv_Sub)) then
-if Scope (Priv_Sub) = P
-or else not In_Open_Scopes (Scope (Priv_Sub))
-then
-Set_Is_Immediately_Visible (Priv_Sub, False);
-end if;
-if Is_Visible_Dependent (Priv_Sub) then
-Preserve_Full_Attributes
-(Priv_Sub, Full_View (Priv_Sub));
-Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
-Exchange_Declarations (Priv_Sub);
-end if;
-end if;
-Next_Elmt (Priv_Elmt);
-end loop;
 --  Now restore the type itself to its private view
 Exchange_Declarations (Id);
 Do_Abstract_States : Boolean := False) return Boolean
 is
 E : Entity_Id;
 Requires_Body : Boolean := False;
---  Flag set when the unit has at least one construct that requries
+--  Flag set when the unit has at least one construct that requires
 --  completion in a body.
 begin
 --  Imported entity never requires body. Right now, only subprograms can
 --  be imported, but perhaps in the future we will allow import of
 Next_Entity (E);
 end loop;
 --  A [generic] package that defines at least one non-null abstract state
 --  requires a completion only when at least one other construct requires
---  a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not
+--  a completion in a body (SPARK RM 7.1.4(4) and (5)). This check is not
 --  performed if the caller requests this behavior.
 if Do_Abstract_States
 and then Ekind_In (Pack_Id, E_Generic_Package, E_Package)
 and then Has_Non_Null_Abstract_State (Pack_Id)

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_ch7.adb @ 145:1830386684a0