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

comparison gcc/ada/sem_ch4.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 4                               --
 --                                                                          --
 --                                 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- --
 --------------------------
 -- List_Operand_Interps --
 --------------------------
 procedure List_Operand_Interps (Opnd : Node_Id) is
-Nam   : Node_Id;
+Nam : Node_Id := Empty;
-pragma Warnings (Off, Nam);
+Err : Node_Id := N;
-Err   : Node_Id := N;
 begin
 if Is_Overloaded (Opnd) then
 if Nkind (Opnd) in N_Op then
 Nam := Opnd;
 -----------------------
 -- Analyze_Aggregate --
 -----------------------
---  Most of the analysis of Aggregates requires that the type be known,
+--  Most of the analysis of Aggregates requires that the type be known, and
---  and is therefore put off until resolution.
+--  is therefore put off until resolution of the context. Delta aggregates
+--  have a base component that determines the enclosing aggregate type so
+--  its type can be ascertained earlier. This also allows delta aggregates
+--  to appear in the context of a record type with a private extension, as
+--  per the latest update of AI12-0127.
 procedure Analyze_Aggregate (N : Node_Id) is
 begin
 if No (Etype (N)) then
-Set_Etype (N, Any_Composite);
+if Nkind (N) = N_Delta_Aggregate then
+declare
+Base : constant Node_Id := Expression (N);
+I  : Interp_Index;
+It : Interp;
+begin
+Analyze (Base);
+--  If the base is overloaded, propagate interpretations to the
+--  enclosing aggregate.
+if Is_Overloaded (Base) then
+Get_First_Interp (Base, I, It);
+Set_Etype (N, Any_Type);
+while Present (It.Nam) loop
+Add_One_Interp (N, It.Typ, It.Typ);
+Get_Next_Interp (I, It);
+end loop;
+else
+Set_Etype (N, Etype (Base));
+end if;
+end;
+else
+Set_Etype (N, Any_Composite);
+end if;
 end if;
 end Analyze_Aggregate;
 -----------------------
 -- Analyze_Allocator --
 --  construct where the out-mode actuals of this function may
 --  introduce conflicts.
 else
 declare
-Outermost : Node_Id;
+Outermost : Node_Id := Empty; -- init to avoid warning
 P         : Node_Id := N;
 begin
 while Present (P) loop
 --  For object declarations we can climb to the node from
 --  its object definition branch or from its initializing
 --  expression. We prefer to mark the child node as the
 --  outermost construct to avoid adding further complexity
 --  to the routine that will later take care of
 N_Object_Declaration)
 then
 Outermost := P;
 end if;
---  Avoid climbing more than needed!
+--  Avoid climbing more than needed
 exit when Stop_Subtree_Climbing (Nkind (P))
 or else (Nkind (P) = N_Range
 and then not
 Nkind_In (Parent (P), N_In, N_Not_In));
 --  If the call has been rewritten from a prefixed call, the first
 --  parameter has been analyzed, but may need a subsequent
 --  dereference, so skip its analysis now.
-if N /= Original_Node (N)
+if Is_Rewrite_Substitution (N)
 and then Nkind (Original_Node (N)) = Nkind (N)
 and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N)))
 and then Present (Parameter_Associations (N))
 and then Present (Etype (First (Parameter_Associations (N))))
 then
 elsif From_Limited_With (Etype (N))
 and then Present (Non_Limited_View (Etype (N)))
 then
 Set_Etype (N, Non_Limited_View (Etype (N)));
+--  If there is no completion for the type, this may be because
+--  there is only a limited view of it and there is nothing in
+--  the context of the current unit that has required a regular
+--  compilation of the unit containing the type. We recognize
+--  this unusual case by the fact that that unit is not analyzed.
+--  Note that the call being analyzed is in a different unit from
+--  the function declaration, and nothing indicates that the type
+--  is a limited view.
+elsif Ekind (Scope (Etype (N))) = E_Package
+and then Present (Limited_View (Scope (Etype (N))))
+and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N))))
+then
+Error_Msg_NE
+("cannot call function that returns limited view of}",
+N, Etype (N));
+Error_Msg_NE
+("\there must be a regular with_clause for package & in the "
+& "current unit, or in some unit in its context",
+N, Scope (Etype (N)));
+Set_Etype (N, Any_Type);
 end if;
 end if;
 end if;
 end Analyze_Call;
 --  Call Analyze_Choices and Check_Choices to do the rest of the work
 else
 Analyze_Choices (Alternatives (N), Exp_Type);
 Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
-end if;
+if Exp_Type = Universal_Integer and then not Others_Present then
-if Exp_Type = Universal_Integer and then not Others_Present then
+Error_Msg_N
-Error_Msg_N
+("case on universal integer requires OTHERS choice", Expr);
-("case on universal integer requires OTHERS choice", Expr);
+end if;
 end if;
 end Analyze_Case_Expression;
 ---------------------------
 -- Analyze_Comparison_Op --
 --  Start of processing for Analyze_Membership_Op
 begin
 Analyze_Expression (L);
-if No (R) and then Ada_Version >= Ada_2012 then
+if No (R) then
+pragma Assert (Ada_Version >= Ada_2012);
 Analyze_Set_Membership;
 Check_Function_Writable_Actuals (N);
 return;
 end if;
 if Nkind (R) = N_Range
 or else (Nkind (R) = N_Attribute_Reference
 Skip_First : Boolean := False)
 is
 Actuals : constant List_Id   := Parameter_Associations (N);
 Prev_T  : constant Entity_Id := Etype (N);
+--  Recognize cases of prefixed calls that have been rewritten in
+--  various ways. The simplest case is a rewritten selected component,
+--  but it can also be an already-examined indexed component, or a
+--  prefix that is itself a rewritten prefixed call that is in turn
+--  an indexed call (the syntactic ambiguity involving the indexing of
+--  a function with defaulted parameters that returns an array).
+--  A flag Maybe_Indexed_Call might be useful here ???
 Must_Skip  : constant Boolean := Skip_First
 or else Nkind (Original_Node (N)) = N_Selected_Component
 or else
 (Nkind (Original_Node (N)) = N_Indexed_Component
-and then Nkind (Prefix (Original_Node (N)))
+and then Nkind (Prefix (Original_Node (N))) =
-= N_Selected_Component);
+N_Selected_Component)
+or else
+(Nkind (Parent (N)) = N_Function_Call
+and then Is_Array_Type (Etype (Name (N)))
+and then Etype (Original_Node (N)) =
+Component_Type (Etype (Name (N)))
+and then Nkind (Original_Node (Parent (N))) =
+N_Selected_Component);
 --  The first formal must be omitted from the match when trying to find
 --  a primitive operation that is a possible interpretation, and also
 --  after the call has been rewritten, because the corresponding actual
 --  is already known to be compatible, and because this may be an
 --  indexing of a call with default parameters.
 end if;
 Comp := First_Entity (T);
 while Present (Comp) loop
 if Chars (Comp) = Chars (Sel)
-and then Is_Visible_Component (Comp)
+and then Is_Visible_Component (Comp, Sel)
 then
 --  AI05-105:  if the context is an object renaming with
 --  an anonymous access type, the expected type of the
 --  object must be anonymous. This is a name resolution rule.
 if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call
 and then Parent (Loop_Par) /= N
 then
 --  The parser cannot distinguish between a loop specification
---  and an iterator specification. If after pre-analysis the
+--  and an iterator specification. If after preanalysis the
 --  proper form has been recognized, rewrite the expression to
 --  reflect the right kind. This is needed for proper ASIS
 --  navigation. If expansion is enabled, the transformation is
 --  performed when the expression is rewritten as a loop.
 Get_Next_Interp (I2, It2);
 end loop;
 end if;
 end Check_High_Bound;
------------------------------
+--------------------------------
--- Is_Universal_Expression --
+-- Check_Universal_Expression --
------------------------------
+--------------------------------
 procedure Check_Universal_Expression (N : Node_Id) is
 begin
 if Etype (N) = Universal_Integer
 and then Nkind (N) /= N_Integer_Literal
 Is_Private_Op := True;
 end if;
 end if;
-Next_Entity (Comp);
+--  Do not examine private operations if not within scope of
+--  the synchronized type.
 exit when not In_Scope
 and then
 Comp = First_Private_Entity (Base_Type (Prefix_Type));
+Next_Entity (Comp);
 end loop;
 --  If the scope is a current instance, the prefix cannot be an
 --  expression of the same type, unless the selector designates a
 --  public operation (otherwise that would represent an attempt to
 --  well fall through and generate a compilation error anyway.
 Comp := First_Component (Base_Type (Prefix_Type));
 while Present (Comp) loop
 if Chars (Comp) = Chars (Sel)
-and then Is_Visible_Component (Comp)
+and then Is_Visible_Component (Comp, Sel)
 then
 Set_Entity_With_Checks (Sel, Comp);
 Generate_Reference (Comp, Sel);
 Set_Etype (Sel, Etype (Comp));
 Set_Etype (N,   Etype (Comp));
 return;
 end if;
 Comp  := First_Entity (Prefix);
 while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
-if Is_Visible_Component (Comp) then
+if Is_Visible_Component (Comp, Sel) then
 if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
 Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
 case Nr_Of_Suggestions is
 when 1      => Suggestion_1 := Comp;
 Save_Interps (Subprog, Node_To_Replace);
 else
 --  The type of the subprogram may be a limited view obtained
 --  transitively from another unit. If full view is available,
---  use it to analyze call.
+--  use it to analyze call. If there is no nonlimited view, then
+--  this is diagnosed when analyzing the rewritten call.
 declare
 T : constant Entity_Id := Etype (Subprog);
 begin
 if From_Limited_With (T) then
 procedure Traverse_Homonyms
 (Anc_Type : Entity_Id;
 Error    : out Boolean)
 is
-Cls_Type    : Entity_Id;
+function First_Formal_Match
-Hom         : Entity_Id;
+(Subp_Id : Entity_Id;
-Hom_Ref     : Node_Id;
+Typ     : Entity_Id) return Boolean;
-Success     : Boolean;
+--  Predicate to verify that the first foramal of class-wide
+--  subprogram Subp_Id matches type Typ of the prefix.
+------------------------
+-- First_Formal_Match --
+------------------------
+function First_Formal_Match
+(Subp_Id : Entity_Id;
+Typ     : Entity_Id) return Boolean
+is
+Ctrl : constant Entity_Id := First_Formal (Subp_Id);
+begin
+return
+Present (Ctrl)
+and then
+(Base_Type (Etype (Ctrl)) = Typ
+or else
+(Ekind (Etype (Ctrl)) = E_Anonymous_Access_Type
+and then
+Base_Type (Designated_Type (Etype (Ctrl))) =
+Typ));
+end First_Formal_Match;
+--  Local variables
+CW_Typ : constant Entity_Id := Class_Wide_Type (Anc_Type);
+Candidate : Entity_Id;
+--  If homonym is a renaming, examine the renamed program
+Hom      : Entity_Id;
+Hom_Ref  : Node_Id;
+Success  : Boolean;
+--  Start of processing for Traverse_Homonyms
 begin
 Error := False;
-Cls_Type := Class_Wide_Type (Anc_Type);
-Hom := Current_Entity (Subprog);
 --  Find a non-hidden operation whose first parameter is of the
 --  class-wide type, a subtype thereof, or an anonymous access
 --  to same. If in an instance, the operation can be considered
 --  even if hidden (it may be hidden because the instantiation
 --  is expanded after the containing package has been analyzed).
+--  If the subprogram is a generic actual in an enclosing instance,
+--  it appears as a renaming that is a candidate interpretation as
+--  well.
+Hom := Current_Entity (Subprog);
 while Present (Hom) loop
 if Ekind_In (Hom, E_Procedure, E_Function)
-and then (not Is_Hidden (Hom) or else In_Instance)
+and then Present (Renamed_Entity (Hom))
-and then Scope (Hom) = Scope (Base_Type (Anc_Type))
+and then Is_Generic_Actual_Subprogram (Hom)
-and then Present (First_Formal (Hom))
+and then In_Open_Scopes (Scope (Hom))
-and then
+then
-(Base_Type (Etype (First_Formal (Hom))) = Cls_Type
+Candidate := Renamed_Entity (Hom);
-or else
+else
-(Is_Access_Type (Etype (First_Formal (Hom)))
+Candidate := Hom;
-and then
+end if;
-Ekind (Etype (First_Formal (Hom))) =
-E_Anonymous_Access_Type
+if Ekind_In (Candidate, E_Function, E_Procedure)
-and then
+and then (not Is_Hidden (Candidate) or else In_Instance)
-Base_Type
+and then Scope (Candidate) = Scope (Base_Type (Anc_Type))
-(Designated_Type (Etype (First_Formal (Hom)))) =
+and then First_Formal_Match (Candidate, CW_Typ)
-Cls_Type))
 then
 --  If the context is a procedure call, ignore functions
 --  in the name of the call.
-if Ekind (Hom) = E_Function
+if Ekind (Candidate) = E_Function
 and then Nkind (Parent (N)) = N_Procedure_Call_Statement
 and then N = Name (Parent (N))
 then
 goto Next_Hom;
 --  If the context is a function call, ignore procedures
 --  in the name of the call.
-elsif Ekind (Hom) = E_Procedure
+elsif Ekind (Candidate) = E_Procedure
 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
 then
 goto Next_Hom;
 end if;
-Set_Etype (Call_Node, Any_Type);
+Set_Etype         (Call_Node, Any_Type);
 Set_Is_Overloaded (Call_Node, False);
 Success := False;
 if No (Matching_Op) then
-Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog));
+Hom_Ref := New_Occurrence_Of (Candidate, Sloc (Subprog));
-Set_Etype (Call_Node, Any_Type);
+Set_Etype  (Call_Node, Any_Type);
+Set_Name   (Call_Node, Hom_Ref);
 Set_Parent (Call_Node, Parent (Node_To_Replace));
-Set_Name (Call_Node, Hom_Ref);
 Analyze_One_Call
 (N          => Call_Node,
-Nam        => Hom,
+Nam        => Candidate,
 Report     => Report_Error,
 Success    => Success,
 Skip_First => True);
 Matching_Op :=
-Valid_Candidate (Success, Call_Node, Hom);
+Valid_Candidate (Success, Call_Node, Candidate);
 else
 Analyze_One_Call
 (N          => Call_Node,
-Nam        => Hom,
+Nam        => Candidate,
 Report     => Report_Error,
 Success    => Success,
 Skip_First => True);
 --  The same operation may be encountered on two homonym
 --  traversals, before and after looking at interfaces.
 --  Check for this case before reporting a real ambiguity.
-if Present (Valid_Candidate (Success, Call_Node, Hom))
+if Present
+(Valid_Candidate (Success, Call_Node, Candidate))
 and then Nkind (Call_Node) /= N_Function_Call
-and then Hom /= Matching_Op
+and then Candidate /= Matching_Op
 then
 Error_Msg_NE ("ambiguous call to&", N, Hom);
 Report_Ambiguity (Matching_Op);
 Report_Ambiguity (Hom);
 Error := True;
 return;
 end if;
 declare
 Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
-CW_Result     : Boolean;
+Ignore        : Boolean;
-Prim_Result   : Boolean;
+Prim_Result   : Boolean := False;
-pragma Unreferenced (CW_Result);
 begin
 if not CW_Test_Only then
 Prim_Result :=
 Try_Primitive_Operation
 --  Check if there is a class-wide subprogram covering the
 --  primitive. This check must be done even if a candidate
 --  was found in order to report ambiguous calls.
 if not Prim_Result then
-CW_Result :=
+Ignore :=
 Try_Class_Wide_Operation
 (Call_Node       => New_Call_Node,
 Node_To_Replace => Node_To_Replace);
 --  If we found a primitive we search for class-wide subprograms
 --  using a duplicate of the call node (done to avoid missing its
 --  decoration if there is no ambiguity).
 else
-CW_Result :=
+Ignore :=
 Try_Class_Wide_Operation
 (Call_Node       => Dup_Call_Node,
 Node_To_Replace => Node_To_Replace);
 end if;
 end;
 ---------------------------
 -- Is_Private_Overriding --
 ---------------------------
 function Is_Private_Overriding (Op : Entity_Id) return Boolean is
-Visible_Op : constant Entity_Id := Homonym (Op);
+Visible_Op : Entity_Id;
 begin
-return Present (Visible_Op)
+--  The subprogram may be overloaded with both visible and private
-and then Scope (Op) = Scope (Visible_Op)
+--  entities with the same name. We have to scan the chain of
-and then not Comes_From_Source (Visible_Op)
+--  homonyms to determine whether there is a previous implicit
-and then Alias (Visible_Op) = Op
+--  declaration in the same scope that is overridden by the
-and then not Is_Hidden (Visible_Op);
+--  private candidate.
+Visible_Op := Homonym (Op);
+while Present (Visible_Op) loop
+if Scope (Op) /= Scope (Visible_Op) then
+return False;
+elsif not Comes_From_Source (Visible_Op)
+and then Alias (Visible_Op) = Op
+and then not Is_Hidden (Visible_Op)
+then
+return True;
+end if;
+Visible_Op := Homonym (Visible_Op);
+end loop;
+return False;
 end Is_Private_Overriding;
 -----------------
 -- Names_Match --
 -----------------
 elsif Is_Protected_Type (Obj_Type) then
 return
 Present (Original_Protected_Subprogram (Prim_Op))
 and then Chars (Original_Protected_Subprogram (Prim_Op)) =
 Chars (Subprog);
+--  In an instance, the selector name may be a generic actual that
+--  renames a primitive operation of the type of the prefix.
+elsif In_Instance and then Present (Current_Entity (Subprog)) then
+declare
+Subp : constant Entity_Id := Current_Entity (Subprog);
+begin
+if Present (Subp)
+and then Is_Subprogram (Subp)
+and then Present (Renamed_Entity (Subp))
+and then Is_Generic_Actual_Subprogram (Subp)
+and then Chars (Renamed_Entity (Subp)) = Chars (Prim_Op)
+then
+return True;
+end if;
+end;
 end if;
 return False;
 end Names_Match;

Mercurial > hg > CbC > CbC_gcc

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