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

comparison gcc/ada/sem_ch3.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 3                               --
 --                                                                          --
 --                                 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_Ch8;   use Sem_Ch8;
 with Sem_Ch13;  use Sem_Ch13;
 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_Elim;  use Sem_Elim;
 with Sem_Eval;  use Sem_Eval;
 with Sem_Mech;  use Sem_Mech;
 with Sem_Res;   use Sem_Res;
 with Sem_Smem;  use Sem_Smem;
 (T   : Entity_Id;
 Def : Node_Id);
 --  Create a new ordinary fixed point type, and apply the constraint to
 --  obtain subtype of it.
+procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id);
+--  Wrapper on Preanalyze_Spec_Expression for default expressions, so that
+--  In_Default_Expr can be properly adjusted.
 procedure Prepare_Private_Subtype_Completion
 (Id          : Entity_Id;
 Related_Nod : Node_Id);
 --  Id is a subtype of some private type. Creates the full declaration
 --  associated with Id whenever possible, i.e. when the full declaration
 Set_Convention (Desig_Type, Convention_Protected);
 else
 Set_Ekind (T_Name, E_Access_Subprogram_Type);
 end if;
-Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
+Set_Can_Use_Internal_Rep     (T_Name,
+not Always_Compatible_Rep_On_Target);
 Set_Etype                    (T_Name, T_Name);
 Init_Size_Align              (T_Name);
 Set_Directly_Designated_Type (T_Name, Desig_Type);
+--  If the access_to_subprogram is not declared at the library level,
+--  it can only point to subprograms that are at the same or deeper
+--  accessibility level. The corresponding subprogram type might
+--  require an activation record when compiling for C.
+Set_Needs_Activation_Record  (Desig_Type,
+not Is_Library_Level_Entity (T_Name));
 Generate_Reference_To_Formals (T_Name);
 --  Ada 2005 (AI-231): Propagate the null-excluding attribute
 --  Apply legality checks in RM 6.1.1 (10-13) concerning
 --  nonconforming preconditions in both an ancestor and
 --  a progenitor operation.
+--  If the operation is a primitive wrapper it is an explicit
+--  (overriding) operqtion and all is fine.
 if Present (Anc)
 and then Has_Non_Trivial_Precondition (Anc)
 and then Has_Non_Trivial_Precondition (Iface_Prim)
 then
 if Is_Abstract_Subprogram (Prim)
 or else
 (Ekind (Prim) = E_Procedure
 and then Nkind (Parent (Prim)) =
 N_Procedure_Specification
 and then Null_Present (Parent (Prim)))
+or else Is_Primitive_Wrapper (Prim)
 then
 null;
---  The inherited operation must be overridden
+--  The operation is inherited and must be overridden
 elsif not Comes_From_Source (Prim) then
 Error_Msg_NE
 ("&inherits non-conforming preconditions and must "
 & "be overridden (RM 6.1.1 (10-16)",
 begin
 if Is_Limited_Record (Typ) then
 return True;
---  If the root type is limited (and not a limited interface)
+--  If the root type is limited (and not a limited interface) so is
---  so is the current type
+--  the current type.
 elsif Is_Limited_Record (R)
 and then (not Is_Interface (R) or else not Is_Limited_Interface (R))
 then
 return True;
 --  Else the type may have a limited interface progenitor, but a
---  limited record parent.
+--  limited record parent that is not an interface.
-elsif R /= P and then Is_Limited_Record (P) then
+elsif R /= P
+and then Is_Limited_Record (P)
+and then not Is_Interface (P)
+then
 return True;
 else
 return False;
 end if;
 --    Type_Invariant
 --
 --  Context denotes the owner of the declarative list.
 procedure Check_Entry_Contracts;
---  Perform a pre-analysis of the pre- and postconditions of an entry
+--  Perform a preanalysis of the pre- and postconditions of an entry
 --  declaration. This must be done before full resolution and creation
 --  of the parameter block, etc. to catch illegal uses within the
 --  contract expression. Full analysis of the expression is done when
 --  the contract is processed.
 --  Post-freezing actions
 if Present (L) then
 Context := Parent (L);
---  Analyze the contracts of packages and their bodies
+--  Certain contract annocations have forward visibility semantics and
+--  must be analyzed after all declarative items have been processed.
-if Nkind (Context) = N_Package_Specification
+--  This timing ensures that entities referenced by such contracts are
-and then L = Visible_Declarations (Context)
+--  visible.
-then
+--  Analyze the contract of an immediately enclosing package spec or
+--  body first because other contracts may depend on its information.
+if Nkind (Context) = N_Package_Body then
+Analyze_Package_Body_Contract (Defining_Entity (Context));
+elsif Nkind (Context) = N_Package_Specification then
 Analyze_Package_Contract (Defining_Entity (Context));
+end if;
-elsif Nkind (Context) = N_Package_Body then
-Analyze_Package_Body_Contract (Defining_Entity (Context));
+--  Analyze the contracts of various constructs in the declarative
-end if;
+--  list.
---  Analyze the contracts of various constructs now due to the delayed
---  visibility needs of their aspects and pragmas.
 Analyze_Contracts (L);
 if Nkind (Context) = N_Package_Body then
 --  restore the original state conditions.
 Remove_Visible_Refinements (Corresponding_Spec (Context));
 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
-elsif Nkind (Context) = N_Package_Declaration then
+elsif Nkind (Context) = N_Package_Specification then
 --  Partial state refinements are visible up to the end of the
 --  package spec declarations. Hide the partial state refinements
 --  from visibility to restore the original state conditions.
-Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
+Remove_Partial_Visible_Refinements (Defining_Entity (Context));
 end if;
 --  Verify that all abstract states found in any package declared in
 --  the input declarative list have proper refinements. The check is
 --  performed only when the context denotes a block, entry, package,
 --  to the high level optimizer).
 if not Analyzed (T) then
 Set_Analyzed (T);
+--  Set the SPARK mode from the current context
+Set_SPARK_Pragma           (T, SPARK_Mode_Pragma);
+Set_SPARK_Pragma_Inherited (T);
 case Nkind (Def) is
 when N_Access_To_Subprogram_Definition =>
 Access_Subprogram_Declaration (T, Def);
 --  If this is a remote access to subprogram, we must create the
 --  derivations.
 if Is_Type (T) and then Has_Predicates (T) then
 Set_Has_Predicates (Def_Id);
 end if;
+--  Save the scenario for examination by the ABE Processing
+--  phase.
+Record_Elaboration_Scenario (N);
 when N_Enumeration_Type_Definition =>
 Enumeration_Type_Declaration (T, Def);
 when N_Floating_Point_Definition =>
 --  In this case, the discriminants (if any) must match
 T := Find_Type_Name (N);
-Set_Ekind (T, E_Incomplete_Type);
+Set_Ekind            (T, E_Incomplete_Type);
-Init_Size_Align (T);
+Set_Etype            (T, T);
-Set_Is_First_Subtype (T, True);
+Set_Is_First_Subtype (T);
-Set_Etype (T, T);
+Init_Size_Align      (T);
+--  Set the SPARK mode from the current context
+Set_SPARK_Pragma           (T, SPARK_Mode_Pragma);
+Set_SPARK_Pragma_Inherited (T);
 --  Ada 2005 (AI-326): Minimum decoration to give support to tagged
 --  incomplete types.
 if Tagged_Present (N) then
 --  indicating the count is unknown.
 function Delayed_Aspect_Present return Boolean;
 --  If the declaration has an expression that is an aggregate, and it
 --  has aspects that require delayed analysis, the resolution of the
---  aggregate must be deferred to the freeze point of the objet. This
+--  aggregate must be deferred to the freeze point of the object. This
 --  special processing was created for address clauses, but it must
 --  also apply to Alignment. This must be done before the aspect
 --  specifications are analyzed because we must handle the aggregate
 --  before the analysis of the object declaration is complete.
 return False;
 end Delayed_Aspect_Present;
 --  Local variables
-Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+Saved_GM  : constant Ghost_Mode_Type := Ghost_Mode;
---  Save the Ghost mode to restore on exit
+Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
+--  Save the Ghost-related attributes to restore on exit
 Related_Id : Entity_Id;
 --  Start of processing for Analyze_Object_Declaration
 or else Delayed_Aspect_Present)
 then
 Set_Etype (E, T);
 else
+--  If the expression is a formal that is a "subprogram pointer"
+--  this is illegal in accessibility terms (see RM 3.10.2 (13.1/2)
+--  and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force
+--  the corresponding check, as is done for assignments.
+if Is_Entity_Name (E)
+and then Present (Entity (E))
+and then Is_Formal (Entity (E))
+and then
+Ekind (Etype (Entity (E))) = E_Anonymous_Access_Subprogram_Type
+and then Ekind (T) /= E_Anonymous_Access_Subprogram_Type
+then
+Rewrite (E, Convert_To (T, Relocate_Node (E)));
+end if;
 Resolve (E, T);
 end if;
 --  No further action needed if E is a call to an inlined function
 --  which returns an unconstrained type and it has been expanded into
 --  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   => Id,
+(N_Id     => Id,
-Checks => True);
+Checks   => True,
+Warnings => True);
 --  Initialize alignment and size and capture alignment setting
 Init_Alignment               (Id);
 Init_Esize                   (Id);
 if Ekind (Id) = E_Variable then
 Check_No_Hidden_State (Id);
 end if;
-Restore_Ghost_Mode (Saved_GM);
+Restore_Ghost_Region (Saved_GM, Saved_IGR);
 end Analyze_Object_Declaration;
 ---------------------------
 -- Analyze_Others_Choice --
 ---------------------------
 Set_Convention       (T, Convention     (Parent_Type));
 Set_First_Rep_Item   (T, First_Rep_Item (Parent_Type));
 Set_Is_First_Subtype (T);
 Make_Class_Wide_Type (T);
+--  Set the SPARK mode from the current context
+Set_SPARK_Pragma           (T, SPARK_Mode_Pragma);
+Set_SPARK_Pragma_Inherited (T);
 if Unknown_Discriminants_Present (N) then
 Set_Discriminant_Constraint (T, No_Elist);
 end if;
 --  type with constraints. In this case the entity has been introduced
 --  in the private declaration.
 --  Finally this happens in some complex cases when validity checks are
 --  enabled, where the same subtype declaration may be analyzed twice.
---  This can happen if the subtype is created by the pre-analysis of
+--  This can happen if the subtype is created by the preanalysis of
 --  an attribute tht gives the range of a loop statement, and the loop
 --  itself appears within an if_statement that will be rewritten during
 --  expansion.
 if Skip
 --  (no aspects to examine on the generated declaration).
 if not Comes_From_Source (N) then
 Set_Ekind (Id, Ekind (T));
-if Present (Predicate_Function (T)) then
+if Present (Predicate_Function (Id)) then
+null;
+elsif Present (Predicate_Function (T)) then
 Set_Predicate_Function (Id, Predicate_Function (T));
 elsif Present (Ancestor_Subtype (T))
-and then Has_Predicates (Ancestor_Subtype (T))
 and then Present (Predicate_Function (Ancestor_Subtype (T)))
 then
 Set_Predicate_Function (Id,
 Predicate_Function (Ancestor_Subtype (T)));
 end if;
 Set_Scalar_Range         (Id, Scalar_Range       (T));
 Set_Is_Character_Type    (Id, Is_Character_Type  (T));
 Set_Is_Constrained       (Id, Is_Constrained     (T));
 Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
 Set_RM_Size              (Id, RM_Size            (T));
-Inherit_Predicate_Flags  (Id, T);
 when Ordinary_Fixed_Point_Kind =>
 Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
 Set_Scalar_Range         (Id, Scalar_Range       (T));
 Set_Small_Value          (Id, Small_Value        (T));
 Set_Ekind                (Id, E_Signed_Integer_Subtype);
 Set_Scalar_Range         (Id, Scalar_Range       (T));
 Set_Is_Constrained       (Id, Is_Constrained     (T));
 Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
 Set_RM_Size              (Id, RM_Size            (T));
-Inherit_Predicate_Flags  (Id, T);
 when Modular_Integer_Kind =>
 Set_Ekind                (Id, E_Modular_Integer_Subtype);
 Set_Scalar_Range         (Id, Scalar_Range       (T));
 Set_Is_Constrained       (Id, Is_Constrained     (T));
 Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
 Set_RM_Size              (Id, RM_Size            (T));
-Inherit_Predicate_Flags  (Id, T);
 when Class_Wide_Kind =>
 Set_Ekind                (Id, E_Class_Wide_Subtype);
 Set_Class_Wide_Type      (Id, Class_Wide_Type    (T));
 Set_Cloned_Subtype       (Id, T);
 end if;
 when others =>
 raise Program_Error;
 end case;
+--  If there is no constraint in the subtype indication, the
+--  declared entity inherits predicates from the parent.
+Inherit_Predicate_Flags (Id, T);
 end if;
 if Etype (Id) = Any_Type then
 goto Leave;
 end if;
 Pbase      : constant Entity_Id := Base_Type (Parent_Type);
 Ibase      : constant Entity_Id :=
 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
 Svg_Chars  : constant Name_Id   := Chars (Ibase);
 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
+Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase);
 begin
 Copy_Node (Pbase, Ibase);
 --  Restore Itype status after Copy_Node
 Set_Is_Itype (Ibase);
 Set_Associated_Node_For_Itype (Ibase, N);
 Set_Chars             (Ibase, Svg_Chars);
+Set_Prev_Entity       (Ibase, Svg_Prev_E);
 Set_Next_Entity       (Ibase, Svg_Next_E);
 Set_Sloc              (Ibase, Sloc (Derived_Type));
 Set_Scope             (Ibase, Scope (Derived_Type));
 Set_Freeze_Node       (Ibase, Empty);
 Set_Is_Frozen         (Ibase, False);
 is
 Loc           : constant Source_Ptr := Sloc (N);
 Tdef          : constant Node_Id    := Type_Definition (N);
 Indic         : constant Node_Id    := Subtype_Indication (Tdef);
 Parent_Base   : constant Entity_Id  := Base_Type (Parent_Type);
-Implicit_Base : Entity_Id;
+Implicit_Base : Entity_Id           := Empty;
 New_Indic     : Node_Id;
 procedure Make_Implicit_Base;
 --  If the parent subtype is constrained, the derived type is a subtype
 --  of an implicit base type derived from the parent base.
 Constraint_Present : constant Boolean :=
 Nkind (Subtype_Indication (Type_Definition (N))) =
 N_Subtype_Indication;
 D_Constraint   : Node_Id;
-New_Constraint : Elist_Id;
+New_Constraint : Elist_Id := No_Elist;
 Old_Disc       : Entity_Id;
 New_Disc       : Entity_Id;
 New_N          : Node_Id;
 begin
 Old_Disc := First_Discriminant (Parent_Type);
 while Present (Old_Disc) loop
 if No (Next_Entity (Old_Disc))
 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
 then
-Set_Next_Entity
+Link_Entities
 (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
 exit;
 end if;
 Next_Discriminant (Old_Disc);
 (N, Parent_Type, Derived_Type, Derive_Subps);
 --  Build the full derivation if this is not the anonymous derived
 --  base type created by Build_Derived_Record_Type in the constrained
 --  case (see point 5. of its head comment) since we build it for the
---  derived subtype. And skip it for protected types altogether, as
+--  derived subtype. And skip it for synchronized types altogether, as
 --  gigi does not use these types directly.
 if Present (Full_View (Parent_Type))
 and then not Is_Itype (Derived_Type)
-and then not (Ekind (Full_View (Parent_Type)) in Protected_Kind)
+and then not Is_Concurrent_Type (Full_View (Parent_Type))
 then
 declare
 Der_Base   : constant Entity_Id := Base_Type (Derived_Type);
 Discr      : Entity_Id;
 Last_Discr : Entity_Id;
 Parent_Base := Base_Type (Full_View (Parent_Type));
 else
 Parent_Base := Base_Type (Parent_Type);
 end if;
---  AI05-0115 : if this is a derivation from a private type in some
+--  AI05-0115: if this is a derivation from a private type in some
 --  other scope that may lead to invisible components for the derived
 --  type, mark it accordingly.
 if Is_Private_Type (Parent_Type) then
-if Scope (Parent_Type) = Scope (Derived_Type) then
+if Scope (Parent_Base) = Scope (Derived_Type) then
 null;
-elsif In_Open_Scopes (Scope (Parent_Type))
+elsif In_Open_Scopes (Scope (Parent_Base))
-and then In_Private_Part (Scope (Parent_Type))
+and then In_Private_Part (Scope (Parent_Base))
 then
 null;
 else
 Set_Has_Private_Ancestor (Derived_Type);
 --  in scope they must be inherited.
 elsif Has_Unknown_Discriminants (Parent_Type)
 and then
 (not Has_Discriminants (Parent_Type)
-or else not In_Open_Scopes (Scope (Parent_Type)))
+or else not In_Open_Scopes (Scope (Parent_Base)))
 then
 Set_Has_Unknown_Discriminants (Derived_Type);
 end if;
 if not Has_Unknown_Discriminants (Derived_Type)
 Copy_Dimensions_Of_Components (Derived_Type);
 --  Restore the fields saved prior to the New_Copy_Tree call
 --  and compute the stored constraint.
-Set_Etype       (Derived_Type, Save_Etype);
+Set_Etype     (Derived_Type, Save_Etype);
-Set_Next_Entity (Derived_Type, Save_Next_Entity);
+Link_Entities (Derived_Type, Save_Next_Entity);
 if Has_Discriminants (Derived_Type) then
 Set_Discriminant_Constraint
 (Derived_Type, Save_Discr_Constr);
 Set_Stored_Constraint
 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
 Replace_Components (Derived_Type, New_Decl);
 end if;
 --  Insert the new derived type declaration
 or else (Nkind (Constr) = N_Attribute_Reference
 and then Attribute_Name (Constr) = Name_Range)
 then
 Error_Msg_N
 ("a range is not a valid discriminant constraint", Constr);
+Discr_Expr (D) := Error;
+elsif Nkind (Constr) = N_Subtype_Indication then
+Error_Msg_N
+("a subtype indication is not a valid discriminant constraint",
+Constr);
 Discr_Expr (D) := Error;
 else
 Process_Discriminant_Expression (Constr, Discr);
 Discr_Expr (D) := Constr;
 Set_Chars         (Full, Chars (Priv));
 Conditional_Delay (Full, Priv);
 Set_Sloc          (Full, Sloc (Priv));
 end case;
-Set_Next_Entity               (Full, Save_Next_Entity);
+Link_Entities                 (Full, Save_Next_Entity);
 Set_Homonym                   (Full, Save_Homonym);
 Set_Associated_Node_For_Itype (Full, Related_Nod);
 --  Set common attributes for all subtypes: kind, convention, etc.
 Set_Is_First_Subtype (Full, False);
 Set_Scope            (Full, Scope (Priv));
 Set_Size_Info        (Full, Full_Base);
 Set_RM_Size          (Full, RM_Size (Full_Base));
 Set_Is_Itype         (Full);
+--  For the unusual case of a type with unknown discriminants whose
+--  completion is an array, use the proper full base.
+if Is_Array_Type (Full_Base)
+and then Has_Unknown_Discriminants (Priv)
+then
+Set_Etype (Full, Full_Base);
+end if;
 --  A subtype of a private-type-without-discriminants, whose full-view
 --  has discriminants with default expressions, is not constrained.
 if not Has_Discriminants (Priv) then
 --  Itypes must be analyzed with checks off (see package Itypes)
 Analyze (Subtyp_Decl, Suppress => All_Checks);
+if Is_Itype (Def_Id) and then Has_Predicates (T) then
+Inherit_Predicate_Flags (Def_Id, T);
+--  Indicate where the predicate function may be found
+if Is_Itype (T) then
+if Present (Predicate_Function (Def_Id)) then
+null;
+elsif Present (Predicate_Function (T)) then
+Set_Predicate_Function (Def_Id, Predicate_Function (T));
+else
+Set_Predicated_Parent (Def_Id, Predicated_Parent (T));
+end if;
+elsif No (Predicate_Function (Def_Id)) then
+Set_Predicated_Parent (Def_Id, T);
+end if;
+end if;
 return Def_Id;
 end Build_Subtype;
 ---------------------
 -- Get_Discr_Value --
 (Prot_Subt   : Entity_Id;
 Corr_Rec    : Entity_Id;
 Related_Nod : Node_Id) return Entity_Id
 is
 T_Sub : constant Entity_Id :=
-Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
+Create_Itype
+(Ekind        => E_Record_Subtype,
+Related_Nod  => Related_Nod,
+Related_Id   => Corr_Rec,
+Suffix       => 'C',
+Suffix_Index => -1);
 begin
 Set_Etype             (T_Sub, Corr_Rec);
 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
 Set_Is_Constrained    (T_Sub, True);
 end if;
 Set_Is_Volatile                (Full, Is_Volatile             (Priv));
 Set_Treat_As_Volatile          (Full, Treat_As_Volatile       (Priv));
 Set_Scope                      (Full, Scope                   (Priv));
+Set_Prev_Entity                (Full, Prev_Entity             (Priv));
 Set_Next_Entity                (Full, Next_Entity             (Priv));
 Set_First_Entity               (Full, First_Entity            (Priv));
 Set_Last_Entity                (Full, Last_Entity             (Priv));
 --  If access types have been recorded for later handling, keep them in
 --  rate such recognition.
 Set_Comes_From_Source (New_Compon, False);
 --  But it is a real entity, and a birth certificate must be properly
---  registered by entering it into the entity list.
+--  registered by entering it into the entity list, and setting its
+--  scope to the given subtype. This turns out to be useful for the
+--  LLVM code generator, but that scope is not used otherwise.
 Enter_Name (New_Compon);
+Set_Scope (New_Compon, Subt);
 return New_Compon;
 end Create_Component;
 -----------------------
 procedure Derive_Progenitor_Subprograms
 (Parent_Type : Entity_Id;
 Tagged_Type : Entity_Id)
 is
-E          : Entity_Id;
+E           : Entity_Id;
-Elmt       : Elmt_Id;
+Elmt        : Elmt_Id;
-Iface      : Entity_Id;
+Iface       : Entity_Id;
-Iface_Elmt : Elmt_Id;
+Iface_Alias : Entity_Id;
-Iface_Subp : Entity_Id;
+Iface_Elmt  : Elmt_Id;
-New_Subp   : Entity_Id := Empty;
+Iface_Subp  : Entity_Id;
-Prim_Elmt  : Elmt_Id;
+New_Subp    : Entity_Id := Empty;
-Subp       : Entity_Id;
+Prim_Elmt   : Elmt_Id;
-Typ        : Entity_Id;
+Subp        : Entity_Id;
+Typ         : Entity_Id;
 begin
 pragma Assert (Ada_Version >= Ada_2005
 and then Is_Record_Type (Tagged_Type)
 and then Is_Tagged_Type (Tagged_Type)
 while Present (Iface_Elmt) loop
 Iface := Node (Iface_Elmt);
 Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
 while Present (Prim_Elmt) loop
-Iface_Subp := Node (Prim_Elmt);
+Iface_Subp  := Node (Prim_Elmt);
+Iface_Alias := Ultimate_Alias (Iface_Subp);
 --  Exclude derivation of predefined primitives except those
 --  that come from source, or are inherited from one that comes
 --  from source. Required to catch declarations of equality
 --  operators of interfaces. For example:
 --     type Iface is interface;
 --     function "=" (Left, Right : Iface) return Boolean;
 if not Is_Predefined_Dispatching_Operation (Iface_Subp)
-or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
+or else Comes_From_Source (Iface_Alias)
 then
-E := Find_Primitive_Covering_Interface
+E :=
-(Tagged_Type => Tagged_Type,
+Find_Primitive_Covering_Interface
-Iface_Prim  => Iface_Subp);
+(Tagged_Type => Tagged_Type,
+Iface_Prim  => Iface_Subp);
 --  If not found we derive a new primitive leaving its alias
 --  attribute referencing the interface primitive.
 if No (E) then
 and then not Error_Posted (N)
 then
 Error_Msg_N
 ("elementary or array type cannot have discriminants",
 Defining_Identifier (First (Discriminant_Specifications (N))));
-Set_Has_Discriminants (T, False);
+--  Unset Has_Discriminants flag to prevent cascaded errors, but
+--  only if we are not already processing a malformed syntax tree.
+if Is_Type (T) then
+Set_Has_Discriminants (T, False);
+end if;
 --  The type is allowed to have discriminants
 else
 Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
 and then Present (Stored_Constraint (Ti))
 and then not Is_Tagged_Type (Ti)
 then
 Result :=
 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
 else
 declare
-Td : constant Entity_Id := Etype (Ti);
+Td : Entity_Id := Etype (Ti);
 begin
+--  If the parent type is private, the full view may include
+--  renamed discriminants, and it is those stored values that
+--  may be needed (the partial view never has more information
+--  than the full view).
+if Is_Private_Type (Td) and then Present (Full_View (Td)) then
+Td := Full_View (Td);
+end if;
 if Td = Ti then
 Result := Discriminant;
 else
 if Present (Stored_Constraint (Ti)) then
 -- Inherit_Predicate_Flags --
 -----------------------------
 procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
 begin
+if Present (Predicate_Function (Subt)) then
+return;
+end if;
 Set_Has_Predicates (Subt, Has_Predicates (Par));
 Set_Has_Static_Predicate_Aspect
 (Subt, Has_Static_Predicate_Aspect (Par));
 Set_Has_Dynamic_Predicate_Aspect
 (Subt, Has_Dynamic_Predicate_Aspect (Par));
 --  A named subtype does not inherit the predicate function of its
 --  parent but an itype declared for a loop index needs the discrete
 --  predicate information of its parent to execute the loop properly.
+--  A non-discrete type may has a static predicate (for example True)
+--  but has no static_discrete_predicate.
 if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
 Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
-if Has_Static_Predicate (Par) then
+if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then
 Set_Static_Discrete_Predicate
 (Subt, Static_Discrete_Predicate (Par));
 end if;
 end if;
 end Inherit_Predicate_Flags;
 end if;
 --  This test only concerns tagged types
 if not Is_Tagged_Type (Original_Type) then
-return True;
+--  Check if this is a renamed discriminant (hidden either by the
+--  derived type or by some ancestor), unless we are analyzing code
+--  generated by the expander since it may reference such components
+--  (for example see the expansion of Deep_Adjust).
+if Ekind (C) = E_Discriminant and then Present (N) then
+return
+not Comes_From_Source (N)
+or else not Is_Completely_Hidden (C);
+else
+return True;
+end if;
 --  If it is _Parent or _Tag, there is no visibility issue
 elsif not Comes_From_Source (Original_Comp) then
 return True;
 procedure Make_Class_Wide_Type (T : Entity_Id) is
 CW_Type : Entity_Id;
 CW_Name : Name_Id;
 Next_E  : Entity_Id;
+Prev_E  : Entity_Id;
 begin
 if Present (Class_Wide_Type (T)) then
 --  The class-wide type is a partially decorated entity created for a
 --  Inherit root type characteristics
 CW_Name := Chars (CW_Type);
 Next_E  := Next_Entity (CW_Type);
+Prev_E  := Prev_Entity (CW_Type);
 Copy_Node (T, CW_Type);
 Set_Comes_From_Source (CW_Type, False);
 Set_Chars (CW_Type, CW_Name);
 Set_Parent (CW_Type, Parent (T));
+Set_Prev_Entity (CW_Type, Prev_E);
 Set_Next_Entity (CW_Type, Next_E);
 --  Ensure we have a new freeze node for the class-wide type. The partial
 --  view may have freeze action of its own, requiring a proper freeze
 --  node, and the same freeze node cannot be shared between the two
 -----------------------------------
 -- Preanalyze_Default_Expression --
 -----------------------------------
 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
-Save_In_Default_Expr : constant Boolean := In_Default_Expr;
+Save_In_Default_Expr    : constant Boolean := In_Default_Expr;
+Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
 begin
-In_Default_Expr := True;
+In_Default_Expr    := True;
-Preanalyze_Spec_Expression (N, T);
+In_Spec_Expression := True;
-In_Default_Expr := Save_In_Default_Expr;
+Preanalyze_With_Freezing_And_Resolve (N, T);
+In_Default_Expr    := Save_In_Default_Expr;
+In_Spec_Expression := Save_In_Spec_Expression;
 end Preanalyze_Default_Expression;
 --------------------------------
 -- Preanalyze_Spec_Expression --
 --------------------------------
 & "cannot have defaults", Expression (Discr));
 end if;
 end if;
 end if;
---  A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)).
+--  A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)).
 --  This check is relevant only when SPARK_Mode is on as it is not a
 --  standard Ada legality rule.
 if SPARK_Mode = On
 and then Is_Effectively_Volatile (Defining_Identifier (Discr))
 end if;
 end Collect_Implemented_Interfaces;
 --  Local variables
-Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+Saved_GM  : constant Ghost_Mode_Type := Ghost_Mode;
+Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
+--  Save the Ghost-related attributes to restore on exit
 Full_Indic  : Node_Id;
 Full_Parent : Entity_Id;
 Priv_Parent : Entity_Id;
 --  omit those inherited from the parent of the private view
 --  since they will be re-inherited later on.
 else
 Full_List := Primitive_Operations (Full_T);
 while Present (Prim_Elmt) loop
 Prim := Node (Prim_Elmt);
 if Comes_From_Source (Prim)
 and then not Contains (Prim, Full_List)
 and then (Chars (Prim) /= Name_Op_Ne
 or else Comes_From_Source (Prim))
 then
 Check_Controlling_Formals (Full_T, Prim);
-if not Is_Dispatching_Operation (Prim) then
+if Is_Suitable_Primitive (Prim)
+and then not Is_Dispatching_Operation (Prim)
+then
 Append_Elmt (Prim, Full_List);
-Set_Is_Dispatching_Operation (Prim, True);
+Set_Is_Dispatching_Operation (Prim);
 Set_DT_Position_Value (Prim, No_Uint);
 end if;
 elsif Is_Dispatching_Operation (Prim)
 and then Disp_Typ /= Full_T
 then
 --  Verify that it is not otherwise controlled by a
 --  formal or a return value of type T.
 Check_Controlling_Formals (Disp_Typ, Prim);
 end if;
 Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
 end if;
 end if;
 <<Leave>>
-Restore_Ghost_Mode (Saved_GM);
+Restore_Ghost_Region (Saved_GM, Saved_IGR);
 end Process_Full_View;
 -----------------------------------
 -- Process_Incomplete_Dependents --
 -----------------------------------
 begin
 --  Case of no constraints present
 if Nkind (S) /= N_Subtype_Indication then
 Find_Type (S);
+--  No way to proceed if the subtype indication is malformed. This
+--  will happen for example when the subtype indication in an object
+--  declaration is missing altogether and the expression is analyzed
+--  as if it were that indication.
+if not Is_Entity_Name (S) then
+return Any_Type;
+end if;
 Check_Incomplete (S);
 P := Parent (S);
 --  Ada 2005 (AI-231): Static check
 when Decimal_Fixed_Point_Kind =>
 Constrain_Decimal (Def_Id, S);
 when Enumeration_Kind =>
 Constrain_Enumeration (Def_Id, S);
-Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
 when Ordinary_Fixed_Point_Kind =>
 Constrain_Ordinary_Fixed (Def_Id, S);
 when Float_Kind =>
 Constrain_Float (Def_Id, S);
 when Integer_Kind =>
 Constrain_Integer (Def_Id, S);
-Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
 when Class_Wide_Kind
 | E_Incomplete_Type
 | E_Record_Subtype
 | E_Record_Type
 if Ekind (Def_Id) = E_Incomplete_Type then
 Set_Private_Dependents (Def_Id, New_Elmt_List);
 end if;
 when Private_Kind =>
-Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+--  A private type with unknown discriminants may be completed
+--  by an unconstrained array type.
+if Has_Unknown_Discriminants (Subtype_Mark_Id)
+and then Present (Full_View (Subtype_Mark_Id))
+and then Is_Array_Type (Full_View (Subtype_Mark_Id))
+then
+Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+--  ... but more commonly is completed by a discriminated record
+--  type.
+else
+Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+end if;
 --  The base type may be private but Def_Id may be a full view
 --  in an instance.
 if Is_Private_Type (Def_Id) then
 --  inherited from the base type.
 Set_Size_Info  (Def_Id,            (Subtype_Mark_Id));
 Set_Rep_Info   (Def_Id,            (Subtype_Mark_Id));
 Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+--  The anonymous subtype created for the subtype indication
+--  inherits the predicates of the parent.
+if Has_Predicates (Subtype_Mark_Id) then
+Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+--  Indicate where the predicate function may be found
+if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then
+Set_Predicated_Parent (Def_Id, Subtype_Mark_Id);
+end if;
+end if;
 return Def_Id;
 end if;
 end Process_Subtype;

Mercurial > hg > CbC > CbC_gcc

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