home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_ch6.adb < prev    next >
Text File  |  1996-09-28  |  69KB  |  2,090 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              S E M _ C H 6                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.235 $                            --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Casing;   use Casing;
  27. with Checks;   use Checks;
  28. with Debug;    use Debug;
  29. with Einfo;    use Einfo;
  30. with Errout;   use Errout;
  31. with Expander; use Expander;
  32. with Lib;      use Lib;
  33. with Namet;    use Namet;
  34. with Nlists;   use Nlists;
  35. with Nmake;    use Nmake;
  36. with Opt;      use Opt;
  37. with Output;   use Output;
  38. with Sem;      use Sem;
  39. with Sem_Ch3;  use Sem_Ch3;
  40. with Sem_Ch4;  use Sem_Ch4;
  41. with Sem_Ch8;  use Sem_Ch8;
  42. with Sem_Ch12; use Sem_Ch12;
  43. with Sem_Disp; use Sem_Disp;
  44. with Sem_Dist; use Sem_Dist;
  45. with Sem_Eval; use Sem_Eval;
  46. with Sem_Prag; use Sem_Prag;
  47. with Sem_Res;  use Sem_Res;
  48. with Sem_Util; use Sem_Util;
  49. with Sinput;   use Sinput;
  50. with Stand;    use Stand;
  51. with Sinfo;    use Sinfo;
  52. with Sinfo.CN; use Sinfo.CN;
  53. with Snames;   use Snames;
  54. with Stringt;  use Stringt;
  55. with Style;
  56. with Tbuild;   use Tbuild;
  57. with Uintp;    use Uintp;
  58. with Urealp;   use Urealp;
  59.  
  60. package body Sem_Ch6 is
  61.  
  62.    -----------------------
  63.    -- Local Subprograms --
  64.    -----------------------
  65.  
  66.    procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
  67.    --  Analyze a generic subprogram body
  68.  
  69.    type Conformance_Type is
  70.      (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
  71.  
  72.    procedure Check_Conformance
  73.      (New_Id   : Entity_Id;
  74.       Old_Id   : Entity_Id;
  75.       Ctype    : Conformance_Type;
  76.       Errmsg   : Boolean;
  77.       Conforms : out Boolean;
  78.       Err_Loc  : Node_Id := Empty);
  79.  
  80.    --  GIven two entities, this procedure checks that the profiles associated
  81.    --  with these entities meet the conformance criterion given by the third
  82.    --  parameter. If they conform, Conforms is set True and control returns
  83.    --  to the caller. If they do not conform, Conforms is set to False, and
  84.    --  in addition, if Errmsg is True on the call, proper messages are output
  85.    --  to complain about the conformance failure. If Err_Loc is non_Empty
  86.    --  the error messages are placed on Err_Loc, if Err_Loc is empty, then
  87.    --  error messages are placed on the appropriate part of the construct
  88.    --  denoted by New_Id.
  89.  
  90.    procedure Enter_Overloaded_Entity (S : Entity_Id);
  91.    --  This procedure makes S, a new overloaded entity, into the first
  92.    --  visible entity with that name.
  93.  
  94.    function Fully_Conformant_Expressions (E1, E2 : Node_Id) return Boolean;
  95.    --  Determines if two expressions are fully conformant (RM 6.3.1(18-21))
  96.  
  97.    procedure Install_Entity (E : Entity_Id);
  98.    --  Make single entity visible. Used for generic formals as well.
  99.  
  100.    procedure Install_Formals (Id : Entity_Id);
  101.    --  On entry to a subprogram body, make the formals visible. Note
  102.    --  that simply placing the subprogram on the scope stack is not
  103.    --  sufficient: the formals must become the current entities for
  104.    --  their names.
  105.  
  106.    procedure Make_Inequality_Operator (S : Entity_Id);
  107.    --  Create the declaration for an inequality operator that is implicitly
  108.    --  created by a user-defined equality operator that yields a boolean.
  109.  
  110.    procedure May_Need_Actuals (Fun : Entity_Id);
  111.    --  Flag functions that can be called without parameters, i.e. those that
  112.    --  have no parameters, or those for which defaults exist for all parameters
  113.  
  114.    procedure Valid_Operator_Definition (Designator : Entity_Id);
  115.    --  Verify that an operator definition has the proper number of formals
  116.  
  117.    ---------------------------------------------
  118.    -- Analyze_Abstract_Subprogram_Declaration --
  119.    ---------------------------------------------
  120.  
  121.    procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
  122.       Designator : constant Entity_Id := Analyze_Spec (Specification (N));
  123.       ELU        : constant Entity_Id := Current_Scope;
  124.       Pure_Flag  : constant Boolean   := Is_Pure (ELU);
  125.       RCI_Flag   : constant Boolean   := Is_Remote_Call_Interface (ELU);
  126.       RT_Flag    : constant Boolean   := Is_Remote_Types (ELU);
  127.  
  128.    begin
  129.       New_Overloaded_Entity (Designator);
  130.       Set_Is_Abstract (Designator);
  131.       Check_Delayed_Subprogram (Designator);
  132.  
  133.       --  Entities declared in Pure unit should be set Is_Pure
  134.       --  Since 'Partition_ID cannot be applied to such an entity
  135.       --  Subprogram declared in RCI unit should be set
  136.       --  Is_Remote_Call_Interface, used to verify remote call.
  137.  
  138.       Set_Is_Pure (Designator, Pure_Flag);
  139.       Set_Is_Remote_Call_Interface (Designator, RCI_Flag);
  140.       Set_Is_Remote_Types (Designator, RT_Flag);
  141.  
  142.    end Analyze_Abstract_Subprogram_Declaration;
  143.  
  144.    ----------------------------
  145.    -- Analyze_Function_Call  --
  146.    ----------------------------
  147.  
  148.    procedure Analyze_Function_Call (N : Node_Id) is
  149.       P      : constant Node_Id := Name (N);
  150.       L      : constant List_Id := Parameter_Associations (N);
  151.       Actual : Node_Id;
  152.  
  153.    begin
  154.       Analyze (P);
  155.  
  156.       --  If error analyzing name, then set Any_Type as result type and return
  157.  
  158.       if Etype (P) = Any_Type then
  159.          Set_Etype (N, Any_Type);
  160.          return;
  161.       end if;
  162.  
  163.       --  Otherwise analyze the parameters
  164.  
  165.       if Present (L) then
  166.          Actual := First (L);
  167.  
  168.          while Present (Actual) loop
  169.             Analyze (Actual);
  170.             Actual := Next (Actual);
  171.          end loop;
  172.       end if;
  173.  
  174.       Analyze_Call (N);
  175.  
  176.    end Analyze_Function_Call;
  177.  
  178.    -------------------------------------
  179.    -- Analyze_Generic_Subprogram_Body --
  180.    -------------------------------------
  181.  
  182.    procedure Analyze_Generic_Subprogram_Body
  183.      (N      : Node_Id;
  184.       Gen_Id : Entity_Id)
  185.    is
  186.       Gen_Decl : constant Node_Id := Get_Declaration_Node (Gen_Id);
  187.       Spec     : Node_Id;
  188.       Kind     : constant Entity_Kind := Ekind (Gen_Id);
  189.       Nam      : Entity_Id;
  190.       New_N    : Node_Id;
  191.  
  192.    begin
  193.       --  Copy body, and disable expansion while analyzing the generic.
  194.  
  195.       New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
  196.       Rewrite_Substitute_Tree (N, New_N);
  197.       Expander_Mode_Save_And_Set (False);
  198.  
  199.       Spec := Specification (N);
  200.       --  Within the body of the generic, the subprogram is callable, and
  201.       --  behaves like the corresponding non-generic unit.
  202.  
  203.       Nam := Defining_Unit_Simple_Name (Spec);
  204.  
  205.       if Kind = E_Generic_Procedure
  206.         and then Nkind (Spec) /= N_Procedure_Specification
  207.       then
  208.          Error_Msg_N ("invalid body for generic procedure ", Nam);
  209.          return;
  210.  
  211.       elsif Kind = E_Generic_Function
  212.         and then Nkind (Spec) /= N_Function_Specification
  213.       then
  214.          Error_Msg_N ("invalid body for generic function ", Nam);
  215.          return;
  216.       end if;
  217.  
  218.       Set_Corresponding_Body (Gen_Decl, Nam);
  219.       Set_Corresponding_Spec (N, Gen_Id);
  220.       Set_Has_Completion (Gen_Id);
  221.  
  222.       if Nkind (N) = N_Subprogram_Body_Stub then
  223.          return;
  224.       end if;
  225.  
  226.       --  Make generic parameters immediately visible in the body. They are
  227.       --  needed to process the formals declarations. Then make the formals
  228.       --  visible in a separate step.
  229.  
  230.       New_Scope (Gen_Id);
  231.       declare
  232.          E : Entity_Id;
  233.  
  234.       begin
  235.          E := First_Entity (Gen_Id);
  236.          while Present (E) and then Ekind (E) not in Formal_Kind loop
  237.             Install_Entity (E);
  238.             E := Next_Entity (E);
  239.          end loop;
  240.  
  241.          Set_Use (Generic_Formal_Declarations (Gen_Decl));
  242.  
  243.          --  Now generic formals are visible, and the specification can be
  244.          --  analyzed, for subsequent conformance check.
  245.  
  246.          Nam := Analyze_Spec (Spec);
  247.  
  248.          if Present (E) then
  249.  
  250.             --  E is the first formal parameter, which must be the first
  251.             --  entity in the subprogram body.
  252.  
  253.             Set_First_Entity (Gen_Id, E);
  254.  
  255.             --  Now make formal parameters visible
  256.  
  257.             while Present (E) loop
  258.                Install_Entity (E);
  259.                E := Next_Formal (E);
  260.             end loop;
  261.          end if;
  262.       end;
  263.  
  264.       --  Visible generic entity is callable within its own body.
  265.  
  266.       Set_Ekind (Gen_Id, Ekind (Nam));
  267.       Set_Convention (Nam, Convention (Gen_Id));
  268.       Check_Fully_Conformant (Nam, Gen_Id, Nam);
  269.  
  270.       Set_Actual_Subtypes (N, Current_Scope);
  271.       Analyze_Declarations (Declarations (N));
  272.       Check_Completion;
  273.       Analyze (Handled_Statement_Sequence (N));
  274.  
  275.       Save_Global_References (Original_Node (N));
  276.  
  277.       --  Prior to exiting the scope, include generic formals again
  278.       --  in the set of local entities.
  279.  
  280.       Set_First_Entity (Gen_Id, First_Entity (Gen_Id));
  281.  
  282.       End_Scope;
  283.  
  284.       --  Outside of its body, unit is generic again.
  285.  
  286.       Set_Ekind (Gen_Id, Kind);
  287.       Expander_Mode_Restore;
  288.  
  289.    end Analyze_Generic_Subprogram_Body;
  290.  
  291.    -----------------------------
  292.    -- Analyze_Operator_Symbol --
  293.    -----------------------------
  294.  
  295.    --  An operator symbol such as "+" or "and" may appear in context where
  296.    --  the literal denotes an entity name, such as  "+"(x, y) or in a
  297.    --  context when it is just a string, as in  (conjunction = "or"). In
  298.    --  these cases the parser generates this node, and the semantics does
  299.    --  the disambiguation. Other such case are actuals in an instantiation,
  300.    --  the generic unit in an instantiation, and pragma arguments.
  301.  
  302.    procedure Analyze_Operator_Symbol (N : Node_Id) is
  303.       Par : Node_Id := Parent (N);
  304.  
  305.    begin
  306.       if        (Nkind (Par) = N_Function_Call and then N = Name (Par))
  307.         or else  Nkind (Par) = N_Function_Instantiation
  308.         or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
  309.         or else (Nkind (Par) = N_Pragma_Argument_Association
  310.                    and then not Is_Pragma_String_Literal (Par))
  311.         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
  312.       then
  313.          Find_Direct_Name (N);
  314.  
  315.       else
  316.          Change_Operator_Symbol_To_String_Literal (N);
  317.          Analyze (N);
  318.       end if;
  319.    end Analyze_Operator_Symbol;
  320.  
  321.    -----------------------------------
  322.    -- Analyze_Parameter_Association --
  323.    -----------------------------------
  324.  
  325.    procedure Analyze_Parameter_Association (N : Node_Id) is
  326.    begin
  327.       Analyze (Explicit_Actual_Parameter (N));
  328.    end Analyze_Parameter_Association;
  329.  
  330.    ----------------------------
  331.    -- Analyze_Procedure_Call --
  332.    ----------------------------
  333.  
  334.    procedure Analyze_Procedure_Call (N : Node_Id) is
  335.       P       : constant Node_Id := Name (N);
  336.       Actuals : constant List_Id := Parameter_Associations (N);
  337.       Actual  : Node_Id;
  338.       Loc     : Source_Ptr := Sloc (N);
  339.       New_N   : Node_Id;
  340.       S       : Entity_Id;
  341.  
  342.       procedure Analyze_And_Resolve;
  343.       --  Do Analyze and Resolve calls for procedure call
  344.  
  345.       procedure Analyze_And_Resolve is
  346.       begin
  347.          Analyze_Call (N);
  348.          Resolve (N, Standard_Void_Type);
  349.       end Analyze_And_Resolve;
  350.  
  351.    --  Start of processing for Analyze_Procedure_Call
  352.  
  353.    begin
  354.       --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote
  355.       --  a procedure call or an entry call. The prefix may denote an access
  356.       --  to subprogram type, in which case an implicit dereference applies.
  357.       --  If the prefix is an indexed component (without implicit defererence)
  358.       --  then the construct denotes a call to a member of an entire family.
  359.       --  If the prefix is a simple name, it may still denote a call to a
  360.       --  parameterless member of an entry family. Resolution of these various
  361.       --  interpretations is delicate.
  362.  
  363.       Analyze (P);
  364.  
  365.       --  If error analyzing prefix, then set Any_Type as result and return
  366.  
  367.       if Etype (P) = Any_Type then
  368.          Set_Etype (N, Any_Type);
  369.          return;
  370.       end if;
  371.  
  372.       --  Otherwise analyze the parameters
  373.  
  374.       if Present (Actuals) then
  375.          Actual := First (Actuals);
  376.  
  377.          while Present (Actual) loop
  378.             Analyze (Actual);
  379.             Actual := Next (Actual);
  380.          end loop;
  381.       end if;
  382.  
  383.       --  Special processing for Elab_Spec and Elab_Body calls
  384.  
  385.       if Nkind (P) = N_Attribute_Reference
  386.         and then (Attribute_Name (P) = Name_Elab_Spec
  387.                    or else Attribute_Name (P) = Name_Elab_Body)
  388.       then
  389.          if Present (Actuals) then
  390.             Error_Msg_N
  391.               ("no parameters allowed for this call", First (Actuals));
  392.             return;
  393.          end if;
  394.  
  395.          Set_Etype (N, Standard_Void_Type);
  396.          Set_Analyzed (N);
  397.  
  398.       elsif Is_Entity_Name (P)
  399.         and then Ekind (Entity (P)) /= E_Entry_Family
  400.       then
  401.          Analyze_And_Resolve;
  402.  
  403.       --  If the prefix is the simple name of an entry family, this is
  404.       --  a parameterless call from within the task body itself.
  405.  
  406.       elsif Is_Entity_Name (P)
  407.         and then Nkind (P) = N_Identifier
  408.         and then Ekind (Entity (P)) = E_Entry_Family
  409.         and then Present (Actuals)
  410.         and then No (Next (First (Actuals)))
  411.       then
  412.          --  Can be call to parameterless entry family. What appears to be
  413.          --  the sole argument is in fact the entry index. Rewrite prefix
  414.          --  of node accordingly. Source representation is unchanged by this
  415.          --  transformation.
  416.  
  417.          New_N :=
  418.            Make_Indexed_Component (Loc,
  419.              Prefix =>
  420.                Make_Selected_Component (Loc,
  421.                  Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
  422.                  Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
  423.              Expressions => Actuals);
  424.          Set_Name (N, New_N);
  425.          Set_Etype (New_N, Standard_Void_Type);
  426.          Set_Parameter_Associations (N, No_List);
  427.          Analyze_And_Resolve;
  428.  
  429.       elsif Nkind (P) = N_Explicit_Dereference then
  430.          if Ekind (Etype (P)) = E_Subprogram_Type then
  431.             Analyze_And_Resolve;
  432.          else
  433.             Error_Msg_N ("expect access to procedure in call", P);
  434.          end if;
  435.  
  436.       --  The name can be a selected component or an indexed component
  437.       --  that yields an access to subprogram. Such a prefix is legal if
  438.       --  the call has parameter associations.
  439.  
  440.       elsif Is_Access_Type (Etype (P))
  441.         and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type
  442.       then
  443.          if Present (Actuals) then
  444.             Analyze_And_Resolve;
  445.          else
  446.             Error_Msg_N ("missing explicit dereference in call ", N);
  447.          end if;
  448.  
  449.       --  If not an access to subprogram, then the prefix must resolve to
  450.       --  the name of an entry, entry family, or protected operation.
  451.  
  452.       --  For the case of a simple entry call, P is a selected component
  453.       --  where the prefix is the task and the selector name is the entry.
  454.       --  A call to a protected procedure will have the same syntax.
  455.  
  456.       elsif Nkind (P) = N_Selected_Component
  457.         and then (Ekind (Entity (Selector_Name (P))) = E_Entry
  458.                     or else
  459.                   Ekind (Entity (Selector_Name (P))) = E_Procedure)
  460.       then
  461.          Analyze_And_Resolve;
  462.  
  463.       elsif Nkind (P) = N_Selected_Component
  464.         and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
  465.         and then Present (Actuals)
  466.         and then No (Next (First (Actuals)))
  467.       then
  468.          --  Can be call to parameterless entry family. What appears to be
  469.          --  the sole argument is in fact the entry index. Rewrite prefix
  470.          --  of node accordingly. Source representation is unchanged by this
  471.          --  transformation.
  472.  
  473.          New_N :=
  474.            Make_Indexed_Component (Loc,
  475.              Prefix => New_Copy (P),
  476.              Expressions => Actuals);
  477.          Set_Name (N, New_N);
  478.          Set_Etype (New_N, Standard_Void_Type);
  479.          Set_Parameter_Associations (N, No_List);
  480.          Analyze_And_Resolve;
  481.  
  482.       --  For the case of a reference to an element of an entry family, P is
  483.       --  an indexed component whose prefix is a selected component (task and
  484.       --  entry family), and whose index is the entry family index.
  485.  
  486.       elsif Nkind (P) = N_Indexed_Component
  487.         and then Nkind (Prefix (P)) = N_Selected_Component
  488.         and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family
  489.       then
  490.          Analyze_And_Resolve;
  491.  
  492.       --  If the prefix is the name of an entry family, it is a call from
  493.       --  within the task body itself.
  494.  
  495.       elsif Nkind (P) = N_Indexed_Component
  496.         and then Nkind (Prefix (P)) = N_Identifier
  497.         and then Ekind (Entity (Prefix (P))) = E_Entry_Family
  498.       then
  499.          New_N :=
  500.            Make_Selected_Component (Loc,
  501.              Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
  502.              Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
  503.          Rewrite_Substitute_Tree (Prefix (P), New_N);
  504.          Analyze (P);
  505.          Analyze_And_Resolve;
  506.  
  507.       --  Anything else is an error.
  508.  
  509.       else
  510.          Error_Msg_N ("Invalid procedure or entry call", N);
  511.       end if;
  512.    end Analyze_Procedure_Call;
  513.  
  514.    ------------------
  515.    -- Analyze_Spec --
  516.    ------------------
  517.  
  518.    function Analyze_Spec (N : Node_Id) return Entity_Id is
  519.       Designator : constant Entity_Id := Defining_Unit_Simple_Name (N);
  520.       Formals    : constant List_Id   := Parameter_Specifications (N);
  521.  
  522.    begin
  523.       if Nkind (N) = N_Function_Specification then
  524.          Set_Ekind (Designator, E_Function);
  525.          Find_Type (Subtype_Mark (N));
  526.          Set_Etype (Designator, Entity (Subtype_Mark (N)));
  527.  
  528.       else
  529.          Set_Ekind (Designator, E_Procedure);
  530.          Set_Etype (Designator, Standard_Void_Type);
  531.       end if;
  532.  
  533.       if Present (Formals) then
  534.          Set_Scope (Designator, Current_Scope);
  535.          New_Scope (Designator);
  536.          Process_Formals (Designator, Formals, N);
  537.          End_Scope;
  538.       end if;
  539.  
  540.       if Nkind (N) = N_Function_Specification then
  541.          if Nkind (Designator) = N_Defining_Operator_Symbol then
  542.             Valid_Operator_Definition (Designator);
  543.          end if;
  544.  
  545.          May_Need_Actuals (Designator);
  546.  
  547.          if Is_Abstract (Etype (Designator))
  548.            and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
  549.          then
  550.             Error_Msg_N
  551.               ("function that returns abstract type must be abstract", N);
  552.          end if;
  553.       end if;
  554.  
  555.       return Designator;
  556.    end Analyze_Spec;
  557.  
  558.    -----------------------------
  559.    -- Analyze_Subprogram_Body --
  560.    -----------------------------
  561.  
  562.    --  This procedure is called for regular subprogram bodies, generic bodies,
  563.    --  and for subprogram stubs of both kinds. In the case of stubs, only the
  564.    --  specification matters, and is used to create a proper declaration for
  565.    --  the subprogram, or to perform conformance checks.
  566.  
  567.    procedure Analyze_Subprogram_Body (N : Node_Id) is
  568.       Spec        : constant Node_Id    := Specification (N);
  569.       Nam         : constant Entity_Id  := Defining_Unit_Simple_Name (Spec);
  570.       Gen_Id      : constant Entity_Id  := Current_Entity_In_Scope (Nam);
  571.       Decls       : List_Id;
  572.       Loc         : Source_Ptr;
  573.       Subp        : Entity_Id;
  574.       Prev        : Entity_Id;
  575.       Last_Formal : Entity_Id;
  576.       Vsn_Name    : Name_Id;
  577.  
  578.    begin
  579.       if Debug_Flag_C then
  580.          Write_Str ("====  Compiling subprogram body ");
  581.          Write_Name (Chars (Nam));
  582.          Write_Str (" from ");
  583.          Write_Location (Sloc (N));
  584.          Write_Eol;
  585.       end if;
  586.  
  587.       Trace_Scope (N, Nam, " Analyze subprogram");
  588.       Set_Ekind (Nam, E_Subprogram_Body);
  589.  
  590.       --  Generic subprograms are handled separately. They always have
  591.       --  a generic specification. Determine whether current scope has
  592.       --  a previous declaration.
  593.  
  594.       if Present (Gen_Id)
  595.         and then not Is_Overloadable (Gen_Id)
  596.       then
  597.          if Ekind (Gen_Id) = E_Generic_Procedure
  598.            or else Ekind (Gen_Id) = E_Generic_Function
  599.          then
  600.             Analyze_Generic_Subprogram_Body (N, Gen_Id);
  601.             return;
  602.  
  603.          else
  604.             --  Previous entity conflicts with subprogram name.
  605.             --  Attempting to enter name will post error.
  606.  
  607.             Enter_Name (Nam);
  608.             return;
  609.          end if;
  610.  
  611.       --  Non-generic case, find the subprogram declaration, if one was
  612.       --  seen, or enter new overloaded entity in the current scope.
  613.  
  614.       else
  615.          Subp := Analyze_Spec (Spec);
  616.  
  617.          --  Get corresponding spec if not already set (the latter happens
  618.          --  in the case of a subprogram instantiation, where the field
  619.          --  was set during the instantiation)
  620.  
  621.          if Nkind (N) = N_Subprogram_Body_Stub
  622.            or else No (Corresponding_Spec (N))
  623.          then
  624.             Prev := Find_Corresponding_Spec (N);
  625.  
  626.          else
  627.             Prev := Corresponding_Spec (N);
  628.          end if;
  629.       end if;
  630.  
  631.       --  Place subprogram on scope stack, and make formals visible. If there
  632.       --  is a spec, the visible entity remains that of the spec. The defining
  633.       --  entity for the body is entered in the chain of entities in that case,
  634.       --  to insure that it is instantiated if it appears in  a generic unit.
  635.  
  636.       if Present (Prev) then
  637.          if Is_Abstract (Prev) then
  638.             Error_Msg_N ("an abstract subprogram cannot have a body", N);
  639.             return;
  640.          else
  641.             Set_Convention (Subp, Convention (Prev));
  642.             Check_Fully_Conformant (Subp, Prev, Subp);
  643.          end if;
  644.  
  645.          if Nkind (N) /= N_Subprogram_Body_Stub then
  646.             Set_Corresponding_Spec (N, Prev);
  647.             Install_Formals (Prev);
  648.             Last_Formal := Last_Entity (Prev);
  649.             New_Scope (Prev);
  650.          end if;
  651.  
  652.          Set_Corresponding_Body (Get_Declaration_Node (Prev), Subp);
  653.  
  654.       else
  655.          if Style_Check and then Comes_From_Source (Nam) then
  656.             Style.Body_With_No_Spec (N);
  657.          end if;
  658.  
  659.          New_Overloaded_Entity (Subp);
  660.  
  661.          if Nkind (N) /= N_Subprogram_Body_Stub then
  662.             Set_Acts_As_Spec (N);
  663.             Install_Formals (Subp);
  664.             New_Scope (Subp);
  665.          end if;
  666.  
  667.       end if;
  668.  
  669.       Set_Has_Completion (Subp);
  670.  
  671.       if Nkind (N) = N_Subprogram_Body_Stub then
  672.          return;
  673.  
  674.       else
  675.          Set_Actual_Subtypes (N, Current_Scope);
  676.          Analyze_Declarations (Declarations (N));
  677.          Check_Completion;
  678.  
  679.          --  Expand cleanup actions if necessary
  680.  
  681.          Analyze (Handled_Statement_Sequence (N));
  682.  
  683.          End_Scope;
  684.  
  685.          if Present (Prev) then
  686.  
  687.             --  Chain the declared entities on the id for the body.
  688.             --  The id for the spec only holds the formals.
  689.  
  690.             if Present (Last_Formal) then
  691.                Set_Next_Entity
  692.                  (Last_Entity (Subp), Next_Entity (Last_Formal));
  693.                Set_Next_Entity (Last_Formal, Empty);
  694.  
  695.             else
  696.                Set_First_Entity (Subp, First_Entity (Prev));
  697.                Set_First_Entity (Prev, Empty);
  698.             end if;
  699.          end if;
  700.       end if;
  701.  
  702.       --  If function, make sure we had at least one return statement
  703.  
  704.       if Ekind (Nam) = E_Function
  705.         or else Ekind (Nam) = E_Generic_Function
  706.       then
  707.          if (Present (Prev) and then Return_Present (Prev))
  708.            or else (No (Prev) and then Return_Present (Subp))
  709.          then
  710.             null;
  711.          else
  712.             Error_Msg_N ("missing RETURN statement in function body", N);
  713.          end if;
  714.       end if;
  715.  
  716.    end Analyze_Subprogram_Body;
  717.  
  718.    -------------------------
  719.    -- Set_Actual_Subtypes --
  720.    -------------------------
  721.  
  722.    procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is
  723.       Loc         : constant Source_Ptr := Sloc (N);
  724.       Decl        : Node_Id;
  725.       Formal      : Entity_Id;
  726.       T           : Entity_Id;
  727.  
  728.    begin
  729.       Formal := First_Formal (Subp);
  730.  
  731.       --  Expansion does not apply to initialization procedures, where
  732.       --  discriminants are handled specially.
  733.  
  734.       if Chars (Formal) = Name_uInit then
  735.          return;
  736.       end if;
  737.  
  738.       while Present (Formal) loop
  739.          T := Etype (Formal);
  740.  
  741.          if (Is_Array_Type (T)
  742.               and then not Is_Constrained (T))
  743.            or else (Ekind (T) = E_Record_Type
  744.                      and then Has_Discriminants (T))
  745.          then
  746.             Decl := Build_Actual_Subtype (T, Formal);
  747.  
  748.             if Nkind (N) = N_Accept_Statement then
  749.                if Present (Handled_Statement_Sequence (N)) then
  750.                   Prepend (Decl, Statements (Handled_Statement_Sequence (N)));
  751.                   Mark_Rewrite_Insertion (Decl);
  752.                else
  753.                   --  If the accept statement has no body, there will be
  754.                   --  no reference to the actuals, so no need to compute
  755.                   --  actual subtypes.
  756.  
  757.                   return;
  758.                end if;
  759.  
  760.             else
  761.                Prepend (Decl, Declarations (N));
  762.                Mark_Rewrite_Insertion (Decl);
  763.             end if;
  764.  
  765.             Analyze (Decl);
  766.             Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
  767.  
  768.          else
  769.             Set_Actual_Subtype (Formal, T);
  770.          end if;
  771.  
  772.          Formal := Next_Formal (Formal);
  773.       end loop;
  774.    end Set_Actual_Subtypes;
  775.  
  776.    ------------------------------------
  777.    -- Analyze_Subprogram_Declaration --
  778.    ------------------------------------
  779.  
  780.    procedure Analyze_Subprogram_Declaration (N : Node_Id) is
  781.       Designator : constant Entity_Id := Analyze_Spec (Specification (N));
  782.       ELU        : constant Entity_Id := Current_Scope;
  783.       Pure_Flag  : Boolean;
  784.       RCI_Flag   : Boolean;
  785.       RT_Flag    : Boolean;
  786.       Param_Spec : Node_Id;
  787.  
  788.    begin
  789.       --  Check for RCI unit subprogram declarations against in-lined
  790.       --  subprograms and subprograms having access parameter or limited
  791.       --  parameter without Read and Write (RM E.2.3(12-13)).
  792.  
  793.       Validate_RCI_Subprogram_Declaration (N);
  794.  
  795.       Trace_Scope
  796.         (N,
  797.          Defining_Unit_Simple_Name (Specification (N)),
  798.          " Analyze subprogram spec. ");
  799.  
  800.       if Debug_Flag_C then
  801.          Write_Str ("====  Compiling subprogram spec ");
  802.          Write_Name (Chars (Designator));
  803.          Write_Str (" from ");
  804.          Write_Location (Sloc (N));
  805.          Write_Eol;
  806.       end if;
  807.  
  808.       New_Overloaded_Entity (Designator);
  809.       Check_Delayed_Subprogram (Designator);
  810.       Set_Suppress_Elaboration_Checks (Designator,
  811.         Elaboration_Checks_Suppressed (Designator));
  812.  
  813.       --  Entities declared in Pure unit should be set Is_Pure
  814.       --  Since 'Partition_ID cannot be applied to such an entity
  815.       --  Subprogram declared in RCI unit should be set
  816.       --  Is_Remote_Call_Interface, used to verify remote call.
  817.  
  818.       if ELU /= Standard_Standard then
  819.          Pure_Flag := Is_Pure (ELU);
  820.          Set_Is_Pure (Designator, Pure_Flag);
  821.          RCI_Flag := Is_Remote_Call_Interface (ELU);
  822.          Set_Is_Remote_Call_Interface (Designator, RCI_Flag);
  823.          RT_Flag := Is_Remote_Types (ELU);
  824.          Set_Is_Remote_Types (Designator, RT_Flag);
  825.       end if;
  826.    end Analyze_Subprogram_Declaration;
  827.  
  828.    -----------------------
  829.    -- Check_Conformance --
  830.    -----------------------
  831.  
  832.    procedure Check_Conformance
  833.      (New_Id   : Entity_Id;
  834.       Old_Id   : Entity_Id;
  835.       Ctype    : Conformance_Type;
  836.       Errmsg   : Boolean;
  837.       Conforms : out Boolean;
  838.       Err_Loc  : Node_Id := Empty)
  839.    is
  840.       Old_Type   : constant Entity_Id := Etype (Old_Id);
  841.       New_Type   : constant Entity_Id := Etype (New_Id);
  842.       Old_Formal : Entity_Id;
  843.       New_Formal : Entity_Id;
  844.  
  845.       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
  846.       --  If neither T1 nor T2 are generic actual types, then verify
  847.       --  that the base types are equal. Otherwise T1 and T2 must be
  848.       --  on the same subtype chain. The whole purpose of this procedure
  849.       --  is to prevent spurious ambiguities in an instantiation that may
  850.       --  arise if two distinct generic types are instantiated with the
  851.       --  same actual.
  852.  
  853.       procedure Conformance_Error (Msg : String; N : Node_Id);
  854.       --  Post error message for conformance error on given node.
  855.       --  Two messages are output. The first points to the previous
  856.       --  declaration with a general "no conformance" message.
  857.       --  The second is the detailed reason, supplied as Msg. The
  858.       --  parameter N provide information for a possible & insertion
  859.       --  in the message, and also provides the location for posting
  860.       --  the message in the absence of a specified Err_Loc location.
  861.  
  862.       function Conforming_Types (Oldt, Newt : Entity_Id) return Boolean;
  863.       --  Check that two formal parameter types conform, checking both
  864.       --  for equality of base types, and where required statically
  865.       --  matching subtypes, depending on the setting of Ctype.
  866.  
  867.       function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
  868.       begin
  869.          if T1 = T2 then
  870.             return True;
  871.  
  872.          elsif Base_Type (T1) = Base_Type (T2) then
  873.  
  874.             --  The following is too permissive. A more precise test must
  875.             --  check that the generic actual is an ancestor subtype of the
  876.             --  other.
  877.  
  878.             return not Is_Generic_Actual_Type (T1)
  879.               or else not Is_Generic_Actual_Type (T2);
  880.  
  881.          else
  882.             return False;
  883.          end if;
  884.       end Base_Types_Match;
  885.  
  886.       procedure Conformance_Error (Msg : String; N : Node_Id) is
  887.          Enode : Node_Id;
  888.  
  889.       begin
  890.          Conforms := False;
  891.  
  892.          if Errmsg then
  893.             if No (Err_Loc) then
  894.                Enode := N;
  895.             else
  896.                Enode := Err_Loc;
  897.             end if;
  898.  
  899.             Error_Msg_Sloc := Sloc (Old_Id);
  900.  
  901.             case Ctype is
  902.                when Type_Conformant =>
  903.                   Error_Msg_N
  904.                     ("not type conformant with declaration#!", Enode);
  905.  
  906.                when Mode_Conformant =>
  907.                   Error_Msg_N
  908.                     ("not mode conformant with declaration#!", Enode);
  909.  
  910.                when Subtype_Conformant =>
  911.                   Error_Msg_N
  912.                     ("not subtype conformant with declaration#!", Enode);
  913.  
  914.                when Fully_Conformant =>
  915.                   Error_Msg_N
  916.                     ("not fully conformant with declaration#!", Enode);
  917.             end case;
  918.  
  919.             Error_Msg_NE (Msg, Enode, N);
  920.          end if;
  921.       end Conformance_Error;
  922.  
  923.       function Conforming_Types (Oldt, Newt : Entity_Id) return Boolean is
  924.       begin
  925.          --  First see if base types match
  926.  
  927.          if Base_Types_Match (Oldt, Newt) then
  928.             return Ctype <= Mode_Conformant
  929.               or else Subtypes_Statically_Match (Oldt, Newt);
  930.  
  931.          elsif Is_Incomplete_Or_Private_Type (Oldt)
  932.            and then Present (Full_View (Oldt))
  933.            and then Base_Types_Match (Full_View (Oldt), Newt)
  934.          then
  935.             return Ctype <= Mode_Conformant
  936.               or else Subtypes_Statically_Match (Full_View (Oldt), Newt);
  937.          end if;
  938.  
  939.          --  Test anonymous access type case. For this case, static subtype
  940.          --  matching is required for mode conformance (RM 6.3.1(15))
  941.  
  942.          if Ekind (Oldt) = E_Anonymous_Access_Type
  943.            and then Ekind (Newt) = E_Anonymous_Access_Type
  944.          then
  945.             declare
  946.                Old_Desig : Entity_Id;
  947.                New_Desig : Entity_Id;
  948.  
  949.             begin
  950.                Old_Desig := Directly_Designated_Type (Oldt);
  951.  
  952.                if Is_Incomplete_Or_Private_Type (Old_Desig)
  953.                  and then Present (Full_View (Old_Desig))
  954.                then
  955.                   Old_Desig := Full_View (Old_Desig);
  956.                end if;
  957.  
  958.                New_Desig := Directly_Designated_Type (Newt);
  959.  
  960.                if Is_Incomplete_Or_Private_Type (New_Desig)
  961.                  and then Present (Full_View (New_Desig))
  962.                then
  963.                   New_Desig := Full_View (New_Desig);
  964.                end if;
  965.  
  966.                return Base_Type (Old_Desig) = Base_Type (New_Desig)
  967.                  and then (Ctype = Type_Conformant
  968.                              or else
  969.                            Subtypes_Statically_Match (Old_Desig, New_Desig));
  970.             end;
  971.  
  972.          --  Otherwise definitely no match
  973.  
  974.          else
  975.             return False;
  976.          end if;
  977.  
  978.       end Conforming_Types;
  979.  
  980.    --  Start of processing for Check_Conformance
  981.  
  982.    begin
  983.       Conforms := True;
  984.  
  985.       --  If both are functions/operators, check return types conform
  986.  
  987.       if Old_Type /= Standard_Void_Type
  988.         and then New_Type /= Standard_Void_Type
  989.       then
  990.          if not Conforming_Types (Old_Type, New_Type) then
  991.             Conformance_Error ("return type does not match!", New_Id);
  992.             return;
  993.          end if;
  994.  
  995.       --  If either is a function/operator and the other isn't, error
  996.  
  997.       elsif Old_Type /= Standard_Void_Type
  998.         or else New_Type /= Standard_Void_Type
  999.       then
  1000.          Conformance_Error ("functions can only match functions!", New_Id);
  1001.          return;
  1002.       end if;
  1003.  
  1004.       --  In subtype conformant case, conventions must match (RM 6.3.1(16))
  1005.  
  1006.       if Ctype >= Subtype_Conformant then
  1007.          if Convention (Old_Id) /= Convention (New_Id) then
  1008.             Conformance_Error ("calling conventions do not match!", New_Id);
  1009.             return;
  1010.          end if;
  1011.       end if;
  1012.  
  1013.       --  Deal with parameters
  1014.  
  1015.       --  Note: we use the entity information, rather than going directly
  1016.       --  to the specification in the tree. This is not only simpler, but
  1017.       --  absolutely necessary for some cases of conformance tests between
  1018.       --  operators, where the declaration tree simply does not exist!
  1019.  
  1020.       Old_Formal := First_Formal (Old_Id);
  1021.       New_Formal := First_Formal (New_Id);
  1022.  
  1023.       while Present (Old_Formal) and then Present (New_Formal) loop
  1024.  
  1025.          --  Types must always match
  1026.  
  1027.          if not
  1028.            Conforming_Types (Etype (Old_Formal), Etype (New_Formal))
  1029.          then
  1030.             Conformance_Error ("type of & does not match!", New_Formal);
  1031.             return;
  1032.          end if;
  1033.  
  1034.          --  For mode conformance, mode must match
  1035.  
  1036.          if Ctype >= Mode_Conformant
  1037.            and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
  1038.          then
  1039.             Conformance_Error ("mode of & does not match!", New_Formal);
  1040.             return;
  1041.          end if;
  1042.  
  1043.          --  Full conformance checks
  1044.  
  1045.          if Ctype = Fully_Conformant then
  1046.  
  1047.             --  Names must match
  1048.  
  1049.             if Chars (Old_Formal) /= Chars (New_Formal) then
  1050.                Conformance_Error ("name & does not match!", New_Formal);
  1051.                return;
  1052.  
  1053.             --  And default expressions for in parameters
  1054.  
  1055.             elsif Parameter_Mode (Old_Formal) = E_In_Parameter then
  1056.  
  1057.                --  Make sure both expressions are analyzed and resolved.
  1058.                --  As a result of our decision to delay the analyze/resolve
  1059.                --  until the Freeze_All, we can encounter unanalyzed cases
  1060.                --  at this stage.
  1061.  
  1062.                if Present (Default_Value (Old_Formal)) then
  1063.                   Analyze (Default_Value (Old_Formal));
  1064.                   Resolve (Default_Value (Old_Formal), Etype (Old_Formal));
  1065.                end if;
  1066.  
  1067.                if Present (Default_Value (New_Formal)) then
  1068.                   Analyze (Default_Value (New_Formal));
  1069.                   Resolve (Default_Value (New_Formal), Etype (New_Formal));
  1070.                end if;
  1071.  
  1072.                if not
  1073.                  Fully_Conformant_Expressions
  1074.                    (Default_Value (Old_Formal), Default_Value (New_Formal))
  1075.                then
  1076.                   Conformance_Error
  1077.                     ("default expression for & does not match!", New_Formal);
  1078.                   return;
  1079.                end if;
  1080.             end if;
  1081.          end if;
  1082.  
  1083.          --  A couple of special checks for Ada 83 mode. These checks are
  1084.          --  skipped if either entity is an operator in package Standard.
  1085.          --  or if either old or new instance is not from the source program.
  1086.  
  1087.          if Ada_83
  1088.            and then Sloc (Old_Id) > Standard_Location
  1089.            and then Sloc (New_Id) > Standard_Location
  1090.            and then Comes_From_Source (Old_Id)
  1091.            and then Comes_From_Source (New_Id)
  1092.          then
  1093.             declare
  1094.                Old_Param : constant Node_Id := Declaration_Node (Old_Formal);
  1095.                New_Param : constant Node_Id := Declaration_Node (New_Formal);
  1096.  
  1097.             begin
  1098.                --  Explicit IN must be present or absent in both cases. This
  1099.                --  test is required only in the full conformance case.
  1100.  
  1101.                if In_Present (Old_Param) /= In_Present (New_Param)
  1102.                  and then Ctype = Fully_Conformant
  1103.                then
  1104.                   Conformance_Error
  1105.                     ("(Ada 83) IN must appear in both declarations",
  1106.                      New_Formal);
  1107.                   return;
  1108.                end if;
  1109.  
  1110.                --  Grouping (use of comma in param lists) must be the same
  1111.                --  This is where we catch a misconformance like:
  1112.  
  1113.                --    A,B : Integer
  1114.                --    A : Integer; B : Integer
  1115.  
  1116.                --  which are represented identically in the tree except
  1117.                --  for the setting of the flags More_Ids and Prev_Ids.
  1118.  
  1119.                if More_Ids (Old_Param) /= More_Ids (New_Param)
  1120.                  or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
  1121.                then
  1122.                   Conformance_Error
  1123.                     ("grouping of & does not match!", New_Formal);
  1124.                   return;
  1125.                end if;
  1126.             end;
  1127.          end if;
  1128.  
  1129.          Old_Formal := Next_Formal (Old_Formal);
  1130.          New_Formal := Next_Formal (New_Formal);
  1131.       end loop;
  1132.  
  1133.       if Present (Old_Formal) then
  1134.          Conformance_Error ("too few parameters!", New_Id);
  1135.          return;
  1136.  
  1137.       elsif Present (New_Formal) then
  1138.          Conformance_Error ("too many parameters!", New_Formal);
  1139.          return;
  1140.       end if;
  1141.  
  1142.    end Check_Conformance;
  1143.  
  1144.    ------------------------------
  1145.    -- Check_Delayed_Subprogram --
  1146.    ------------------------------
  1147.  
  1148.    procedure Check_Delayed_Subprogram (Designator : Entity_Id) is
  1149.       F : Entity_Id;
  1150.  
  1151.       procedure Possible_Freeze (T : Entity_Id);
  1152.       --  T is the type of either a formal parameter or of the return type.
  1153.       --  If T is not yet frozen and needs a delayed freeze, then the
  1154.       --  subprogram itself must be delayed.
  1155.  
  1156.       procedure Possible_Freeze (T : Entity_Id) is
  1157.       begin
  1158.          if Has_Delayed_Freeze (T)
  1159.            and then not Is_Frozen (T)
  1160.          then
  1161.             Set_Has_Delayed_Freeze (Designator);
  1162.  
  1163.          elsif Is_Access_Type (T)
  1164.            and then Has_Delayed_Freeze (Designated_Type (T))
  1165.            and then not Is_Frozen (Designated_Type (T))
  1166.          then
  1167.             Set_Has_Delayed_Freeze (Designator);
  1168.          end if;
  1169.       end Possible_Freeze;
  1170.  
  1171.    --  Start of processing for Check_Delayed_Subprogram
  1172.  
  1173.    begin
  1174.       --  Never need to freeze abstract subprogram
  1175.  
  1176.       if Is_Abstract (Designator) then
  1177.          return;
  1178.       end if;
  1179.  
  1180.       --  Need delayed freeze if return type itself needs a delayed
  1181.       --  freeze and is not yet frozen.
  1182.  
  1183.       Possible_Freeze (Etype (Designator));
  1184.       Possible_Freeze (Base_Type (Etype (Designator))); -- needed ???
  1185.  
  1186.       --  Need delayed freeze if any of the formal types themselves need
  1187.       --  a delayed freeze and are not yet frozen.
  1188.  
  1189.       F := First_Formal (Designator);
  1190.       while Present (F) loop
  1191.          Possible_Freeze (Etype (F));
  1192.          Possible_Freeze (Base_Type (Etype (F))); -- needed ???
  1193.          F := Next_Formal (F);
  1194.       end loop;
  1195.    end Check_Delayed_Subprogram;
  1196.  
  1197.    ----------------------------
  1198.    -- Check_Fully_Conformant --
  1199.    ----------------------------
  1200.  
  1201.    procedure Check_Fully_Conformant
  1202.      (New_Id  : Entity_Id;
  1203.       Old_Id  : Entity_Id;
  1204.       Err_Loc : Node_Id := Empty)
  1205.    is
  1206.       Result : Boolean;
  1207.  
  1208.    begin
  1209.       Check_Conformance
  1210.         (New_Id, Old_Id, Fully_Conformant, True, Result, Err_Loc);
  1211.    end Check_Fully_Conformant;
  1212.  
  1213.    ---------------------------
  1214.    -- Check_Mode_Conformant --
  1215.    ---------------------------
  1216.  
  1217.    procedure Check_Mode_Conformant
  1218.      (New_Id  : Entity_Id;
  1219.       Old_Id  : Entity_Id;
  1220.       Err_Loc : Node_Id := Empty)
  1221.    is
  1222.       Result : Boolean;
  1223.  
  1224.    begin
  1225.       Check_Conformance
  1226.         (New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc);
  1227.    end Check_Mode_Conformant;
  1228.  
  1229.    ------------------------------
  1230.    -- Check_Subtype_Conformant --
  1231.    ------------------------------
  1232.  
  1233.    procedure Check_Subtype_Conformant
  1234.      (New_Id  : Entity_Id;
  1235.       Old_Id  : Entity_Id;
  1236.       Err_Loc : Node_Id := Empty)
  1237.    is
  1238.       Result : Boolean;
  1239.  
  1240.    begin
  1241.       Check_Conformance
  1242.         (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
  1243.    end Check_Subtype_Conformant;
  1244.  
  1245.    ---------------------------
  1246.    -- Check_Type_Conformant --
  1247.    ---------------------------
  1248.  
  1249.    procedure Check_Type_Conformant
  1250.      (New_Id  : Entity_Id;
  1251.       Old_Id  : Entity_Id;
  1252.       Err_Loc : Node_Id := Empty)
  1253.    is
  1254.       Result : Boolean;
  1255.  
  1256.    begin
  1257.       Check_Conformance
  1258.         (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc);
  1259.    end Check_Type_Conformant;
  1260.  
  1261.    -----------------------------
  1262.    -- Enter_Overloaded_Entity --
  1263.    -----------------------------
  1264.  
  1265.    procedure Enter_Overloaded_Entity (S : Entity_Id) is
  1266.       E : Entity_Id;
  1267.  
  1268.    begin
  1269.       E := Current_Entity_In_Scope (S);
  1270.  
  1271.       if Present (E) then
  1272.          Set_Has_Homonym (E);
  1273.          Set_Has_Homonym (S);
  1274.       end if;
  1275.  
  1276.       E := Current_Entity (S);
  1277.       Set_Is_Immediately_Visible (S);
  1278.       Set_Current_Entity (S);
  1279.       Set_Scope (S, Current_Scope);
  1280.       Set_Homonym (S, E);
  1281.  
  1282.       Append_Entity (S, Current_Scope);
  1283.       Set_Public_Status (S);
  1284.  
  1285.       if Debug_Flag_E then
  1286.          Write_Str ("New overloaded entity chain: ");
  1287.          Write_Name (Chars (S));
  1288.          E := S;
  1289.  
  1290.          while Present (E) loop
  1291.             Write_Str (" "); Write_Int (Int (E));
  1292.             E := Homonym (E);
  1293.          end loop;
  1294.  
  1295.          Write_Eol;
  1296.       end if;
  1297.  
  1298.       --  If this is a  user-defined equality operator that is not
  1299.       --  a derived subprogram, create the corresponding inequality.
  1300.  
  1301.       if Chars (S) = Name_Op_Eq
  1302.         and then Etype (S) = Standard_Boolean
  1303.         and then Present (Parent (S))
  1304.         and then not Is_Tagged_Type (Etype (First_Formal (S)))
  1305.       then
  1306.          Make_Inequality_Operator (S);
  1307.       end if;
  1308.  
  1309.    end Enter_Overloaded_Entity;
  1310.  
  1311.    -----------------------------
  1312.    -- Find_Corresponding_Spec --
  1313.    -----------------------------
  1314.  
  1315.    function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
  1316.       Spec       : constant Node_Id   := Specification (N);
  1317.       Designator : constant Entity_Id := Defining_Unit_Simple_Name (Spec);
  1318.       E          : Entity_Id;
  1319.  
  1320.    begin
  1321.       E := Current_Entity (Designator);
  1322.  
  1323.       while Present (E) loop
  1324.  
  1325.          if Scope (E) = Current_Scope
  1326.            and then Ekind (E) = Ekind (Designator)
  1327.            and then Type_Conformant (E, Designator)
  1328.          then
  1329.             if not Has_Completion (E) then
  1330.  
  1331.                if Nkind (N) /= N_Subprogram_Body_Stub then
  1332.                   Set_Corresponding_Spec (N, E);
  1333.                end if;
  1334.  
  1335.                Set_Has_Completion (E);
  1336.                return E;
  1337.  
  1338.             --  If body already exists, this is an error unless the
  1339.             --  previous declaration is the implicit declaration of
  1340.             --  a derived subprogram.
  1341.  
  1342.             elsif No (Alias (E)) and then not Is_Internal (E) then
  1343.                Error_Msg_N ("duplicate subprogram body", N);
  1344.             end if;
  1345.          end if;
  1346.  
  1347.          E := Homonym (E);
  1348.       end loop;
  1349.  
  1350.       --  On exit, we know that no previous declaration of subprogram exists
  1351.  
  1352.       return Empty;
  1353.    end Find_Corresponding_Spec;
  1354.  
  1355.    ----------------------
  1356.    -- Fully_Conformant --
  1357.    ----------------------
  1358.  
  1359.    function Fully_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
  1360.       Result : Boolean;
  1361.  
  1362.    begin
  1363.       Check_Conformance (New_Id, Old_Id, Fully_Conformant, False, Result);
  1364.       return Result;
  1365.    end Fully_Conformant;
  1366.  
  1367.    ----------------------------------
  1368.    -- Fully_Conformant_Expressions --
  1369.    ----------------------------------
  1370.  
  1371.    function Fully_Conformant_Expressions (E1, E2 : Node_Id) return Boolean is
  1372.       function FCE (E1, E2 : Node_Id) return Boolean
  1373.         renames Fully_Conformant_Expressions;
  1374.  
  1375.       function FCL (L1, L2 : List_Id) return Boolean;
  1376.       --  Compare elements of two lists for conformance
  1377.  
  1378.       function FCL (L1, L2 : List_Id) return Boolean is
  1379.          N1, N2 : Node_Id;
  1380.  
  1381.       begin
  1382.          if L1 = No_List then
  1383.             N1 := Empty;
  1384.          else
  1385.             N1 := First (L1);
  1386.          end if;
  1387.  
  1388.          if L2 = No_List then
  1389.             N2 := Empty;
  1390.          else
  1391.             N2 := First (L2);
  1392.          end if;
  1393.  
  1394.          while Present (N1) and then Present (N2) loop
  1395.             if not FCE (N1, N2) then
  1396.                return False;
  1397.             end if;
  1398.  
  1399.             N1 := Next (N1);
  1400.             N2 := Next (N2);
  1401.          end loop;
  1402.  
  1403.          return No (N1) and then No (N2);
  1404.       end FCL;
  1405.  
  1406.    --  Start of processing for Fully_Conformant_Expressions
  1407.  
  1408.    begin
  1409.       --  Trivially conformant if both expressions are empty
  1410.  
  1411.       if No (E1) and No (E2) then
  1412.          return True;
  1413.  
  1414.       --  Non-conformant if paren count does not match. Note: if some idiot
  1415.       --  complains that we don't do this right for more than 15 levels of
  1416.       --  parentheses, they will be treated with the respect they deserve!
  1417.  
  1418.       elsif Paren_Count (E1) /= Paren_Count (E2) then
  1419.          return False;
  1420.  
  1421.       --  If same entities are referenced, then they are conformant
  1422.       --  even if they have different forms (RM 8.3.1(19-20)).
  1423.  
  1424.       elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
  1425.          return Entity (E1) = Entity (E2);
  1426.  
  1427.       --  Otherwise we must have the same syntactic entity
  1428.  
  1429.       elsif Nkind (E1) /= Nkind (E2) then
  1430.          return False;
  1431.  
  1432.       --  Both expressions must be rewritten or not to be conformant
  1433.  
  1434.       elsif Is_Rewrite_Substitution (E1) then
  1435.          if not Is_Rewrite_Substitution (E2) then
  1436.             return False;
  1437.  
  1438.          --  If both nodes are rewritten compare trees before rewrite
  1439.  
  1440.          else
  1441.             return FCE (Original_Node (E1), Original_Node (E2));
  1442.          end if;
  1443.  
  1444.       --  At this point, we specialize by node type
  1445.  
  1446.       else
  1447.          case Nkind (E1) is
  1448.  
  1449.             when N_Aggregate =>
  1450.                return
  1451.                  FCL (Expressions (E1), Expressions (E2))
  1452.                    and then FCL (Component_Associations (E1),
  1453.                                  Component_Associations (E2));
  1454.  
  1455.             when N_Allocator =>
  1456.                return
  1457.                  FCE (Expression (E1), Expression (E2));
  1458.  
  1459.             when N_Attribute_Reference =>
  1460.                return
  1461.                  Attribute_Name (E1) = Attribute_Name (E2)
  1462.                    and then FCL (Expressions (E1), Expressions (E2));
  1463.  
  1464.             when N_Binary_Op =>
  1465.                return
  1466.                  Entity (E1) = Entity (E2)
  1467.                    and then FCE (Left_Opnd  (E1), Left_Opnd  (E2))
  1468.                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
  1469.  
  1470.             when N_And_Then | N_Or_Else | N_In | N_Not_In =>
  1471.                return
  1472.                  FCE (Left_Opnd  (E1), Left_Opnd  (E2))
  1473.                    and then
  1474.                  FCE (Right_Opnd (E1), Right_Opnd (E2));
  1475.  
  1476.             when N_Character_Literal =>
  1477.                return
  1478.                  Char_Literal_Value (E1) = Char_Literal_Value (E2);
  1479.  
  1480.             when N_Component_Association =>
  1481.                return
  1482.                  FCL (Choices (E1), Choices (E2))
  1483.                    and then FCE (Expression (E1), Expression (E2));
  1484.  
  1485.             when N_Concat_Multiple =>
  1486.                return
  1487.                  FCL (Expressions (E1), Expressions (E2));
  1488.  
  1489.             when N_Conditional_Expression =>
  1490.                return
  1491.                  FCL (Expressions (E1), Expressions (E2));
  1492.  
  1493.             when N_Explicit_Dereference =>
  1494.                return
  1495.                  FCE (Prefix (E1), Prefix (E2));
  1496.  
  1497.             when N_Extension_Aggregate =>
  1498.                return
  1499.                  FCL (Expressions (E1), Expressions (E2))
  1500.                    and then Null_Record_Present (E1) =
  1501.                             Null_Record_Present (E2)
  1502.                    and then FCL (Component_Associations (E1),
  1503.                                Component_Associations (E2));
  1504.  
  1505.             when N_Function_Call =>
  1506.                return
  1507.                  FCE (Name (E1), Name (E2))
  1508.                    and then FCL (Parameter_Associations (E1),
  1509.                                  Parameter_Associations (E2));
  1510.  
  1511.             when N_Indexed_Component =>
  1512.                return
  1513.                  FCE (Prefix (E1), Prefix (E2))
  1514.                    and then FCL (Expressions (E1), Expressions (E2));
  1515.  
  1516.             when N_Integer_Literal =>
  1517.                return (Intval (E1) = Intval (E2));
  1518.  
  1519.             when N_Null =>
  1520.                return True;
  1521.  
  1522.             when N_Operator_Symbol =>
  1523.                return
  1524.                  Chars (E1) = Chars (E2);
  1525.  
  1526.             when N_Others_Choice =>
  1527.                return True;
  1528.  
  1529.             when N_Parameter_Association =>
  1530.                return
  1531.                  FCE (Selector_Name (E1), Selector_Name (E2))
  1532.                    and then FCE (Explicit_Actual_Parameter (E1),
  1533.                                  Explicit_Actual_Parameter (E2));
  1534.  
  1535.             when N_Qualified_Expression =>
  1536.                return
  1537.                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
  1538.                    and then FCE (Expression (E1), Expression (E2));
  1539.  
  1540.             when N_Range =>
  1541.                return
  1542.                  FCE (Low_Bound (E1), Low_Bound (E2))
  1543.                    and then FCE (High_Bound (E1), High_Bound (E2));
  1544.  
  1545.             when N_Real_Literal =>
  1546.                return (Realval (E1) = Realval (E2));
  1547.  
  1548.             when N_Selected_Component =>
  1549.                return
  1550.                  FCE (Prefix (E1), Prefix (E2))
  1551.                    and then FCE (Selector_Name (E1), Selector_Name (E2));
  1552.  
  1553.             when N_Slice =>
  1554.                return
  1555.                  FCE (Prefix (E1), Prefix (E2))
  1556.                    and then FCE (Discrete_Range (E1), Discrete_Range (E2));
  1557.  
  1558.             when N_String_Literal =>
  1559.                declare
  1560.                   S1 : constant String_Id := Strval (E1);
  1561.                   S2 : constant String_Id := Strval (E2);
  1562.                   L1 : constant Nat       := String_Length (S1);
  1563.                   L2 : constant Nat       := String_Length (S2);
  1564.  
  1565.                begin
  1566.                   if L1 /= L2 then
  1567.                      return False;
  1568.  
  1569.                   else
  1570.                      for J in 1 .. L1 loop
  1571.                         if Get_String_Char (S1, J) /=
  1572.                            Get_String_Char (S2, J)
  1573.                         then
  1574.                            return False;
  1575.                         end if;
  1576.                      end loop;
  1577.  
  1578.                      return True;
  1579.                   end if;
  1580.                end;
  1581.  
  1582.             when N_Type_Conversion =>
  1583.                return
  1584.                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
  1585.                    and then FCE (Expression (E1), Expression (E2));
  1586.  
  1587.             when N_Unary_Op =>
  1588.                return
  1589.                  Entity (E1) = Entity (E2)
  1590.                    and then FCE (Right_Opnd (E1), Right_Opnd (E2));
  1591.  
  1592.             when N_Unchecked_Type_Conversion =>
  1593.                return
  1594.                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
  1595.                    and then FCE (Expression (E1), Expression (E2));
  1596.  
  1597.             --  All other node types cannot appear in this context. Strictly
  1598.             --  we should do a pragma Assert (False). Instead we just ignore
  1599.             --  the nodes. This means that if anyone makes a mistake in the
  1600.             --  expander and mucks an expression tree irretrievably, the
  1601.             --  result will be a failure to detect a (probably very obscure)
  1602.             --  case of non-conformance, which is better than bombing on some
  1603.             --  case where two expressions do in fact conform.
  1604.  
  1605.             when others =>
  1606.                return True;
  1607.  
  1608.          end case;
  1609.       end if;
  1610.    end Fully_Conformant_Expressions;
  1611.  
  1612.    --------------------
  1613.    -- Install_Entity --
  1614.    --------------------
  1615.  
  1616.    procedure Install_Entity (E : Entity_Id) is
  1617.       Prev : constant Entity_Id := Current_Entity (E);
  1618.  
  1619.    begin
  1620.       Set_Is_Immediately_Visible (E);
  1621.       Set_Current_Entity (E);
  1622.       Set_Homonym (E, Prev);
  1623.    end Install_Entity;
  1624.  
  1625.    ---------------------
  1626.    -- Install_Formals --
  1627.    ---------------------
  1628.  
  1629.    procedure Install_Formals (Id : Entity_Id) is
  1630.       F : Entity_Id;
  1631.  
  1632.    begin
  1633.       F := First_Formal (Id);
  1634.  
  1635.       while Present (F) loop
  1636.          Install_Entity (F);
  1637.          F := Next_Formal (F);
  1638.       end loop;
  1639.    end Install_Formals;
  1640.  
  1641.    ------------------------------
  1642.    -- Make_Inequality_Operator --
  1643.    ------------------------------
  1644.  
  1645.    --  S is the defining identifier of an equality operator. We build a
  1646.    --  subprogram declaration with the rignt signature. This operation is
  1647.    --  intrinsic, because it is always expanded as the negation of the
  1648.    --  call to the equality function.
  1649.  
  1650.    procedure Make_Inequality_Operator (S : Entity_Id) is
  1651.       Loc     : constant Source_Ptr := Sloc (S);
  1652.       Decl    : Node_Id;
  1653.       Formals : List_Id;
  1654.       Op_Name : Entity_Id;
  1655.       Stat    : Node_Id;
  1656.       Typ     : constant Entity_Id := Etype (First_Formal (S));
  1657.  
  1658.       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
  1659.       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
  1660.  
  1661.    begin
  1662.       Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
  1663.  
  1664.       Formals := New_List (
  1665.         Make_Parameter_Specification (Loc,
  1666.           Defining_Identifier => A,
  1667.           Parameter_Type =>
  1668.             New_Reference_To (Etype (First_Formal (S)), Loc)),
  1669.  
  1670.         Make_Parameter_Specification (Loc,
  1671.           Defining_Identifier => B,
  1672.           Parameter_Type =>
  1673.             New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
  1674.  
  1675.       Decl :=
  1676.         Make_Subprogram_Declaration (Loc,
  1677.           Specification => Make_Function_Specification (Loc,
  1678.             Defining_Unit_Name => Op_Name,
  1679.             Parameter_Specifications => Formals,
  1680.             Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)));
  1681.  
  1682.       Insert_After (Get_Declaration_Node (S), Decl);
  1683.       Mark_Rewrite_Insertion (Decl);
  1684.       Analyze (Decl);
  1685.       Set_Has_Completion (Op_Name);
  1686.       Set_Is_Intrinsic_Subprogram (Op_Name);
  1687.  
  1688.    end Make_Inequality_Operator;
  1689.  
  1690.    ----------------------
  1691.    -- May_Need_Actuals --
  1692.    ----------------------
  1693.  
  1694.    procedure May_Need_Actuals (Fun : Entity_Id) is
  1695.       F : Entity_Id;
  1696.       B : Boolean;
  1697.  
  1698.    begin
  1699.       F := First_Formal (Fun);
  1700.       B := True;
  1701.  
  1702.       while Present (F) loop
  1703.          if No (Default_Value (F)) then
  1704.             B := False;
  1705.             exit;
  1706.          end if;
  1707.  
  1708.          F := Next_Formal (F);
  1709.       end loop;
  1710.  
  1711.       Set_Needs_No_Actuals (Fun, B);
  1712.    end May_Need_Actuals;
  1713.  
  1714.    ---------------------
  1715.    -- Mode_Conformant --
  1716.    ---------------------
  1717.  
  1718.    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
  1719.       Result : Boolean;
  1720.  
  1721.    begin
  1722.       Check_Conformance (New_Id, Old_Id, Mode_Conformant, False, Result);
  1723.       return Result;
  1724.    end Mode_Conformant;
  1725.  
  1726.    ---------------------------
  1727.    -- New_Overloaded_Entity --
  1728.    ---------------------------
  1729.  
  1730.    procedure New_Overloaded_Entity (S : Entity_Id) is
  1731.       E        : Entity_Id := Current_Entity_In_Scope (S);
  1732.       Prev_Vis : Entity_Id := Empty;
  1733.  
  1734.    begin
  1735.       if No (E) then
  1736.          Enter_Overloaded_Entity (S);
  1737.          Check_Dispatching_Operation (S, Empty);
  1738.  
  1739.       elsif not Is_Overloadable (E) then
  1740.  
  1741.          --  Check for spurious conflict produced by a subprogram that has the
  1742.          --  same name as that of the enclosing generic package. The conflict
  1743.          --  occurs within an instance, between the subprogram and the renaming
  1744.          --  declaration for the package. After the subprogram, the package
  1745.          --  renaming declaration becomes hidden.
  1746.  
  1747.          if Ekind (E) = E_Package
  1748.            and then Present (Renamed_Object (E))
  1749.            and then Renamed_Object (E) = Current_Scope
  1750.            and then Nkind (Parent (Renamed_Object (E))) =
  1751.              N_Package_Specification
  1752.            and then Present (Generic_Parent (Parent (Renamed_Object (E))))
  1753.          then
  1754.             Set_Is_Private (E);
  1755.             Set_Is_Immediately_Visible (E, False);
  1756.             Enter_Overloaded_Entity (S);
  1757.             Set_Homonym (S, Homonym (E));
  1758.             Check_Dispatching_Operation (S, Empty);
  1759.          else
  1760.             Error_Msg_N ("duplicate identifier:&", S);
  1761.          end if;
  1762.  
  1763.       else
  1764.          --  E exists and is overloadable. Determine whether S is the body
  1765.          --  of E, a new overloaded entity with a different signature, or
  1766.          --  an error altogether.
  1767.  
  1768.          while Present (E) and then Scope (E) = Current_Scope loop
  1769.             if Type_Conformant (E, S) then
  1770.  
  1771.                --  If the old and new entities have the same profile and
  1772.                --  one is not the body of the other, then this is an error,
  1773.                --  unless one of them is implicitly declared.
  1774.  
  1775.                if Present (Alias (S)) then
  1776.  
  1777.                   --  When an derived operation is overloaded it may be
  1778.                   --  due to the fact that the full view of a private extension
  1779.                   --  re-inherits. It has to be dealt with.
  1780.  
  1781.                   Check_Operation_From_Private_View (S, E);
  1782.  
  1783.                   --  In any case the derived operation remains hidden by
  1784.                   --  the existing declaration.
  1785.  
  1786.                   return;
  1787.  
  1788.                elsif Present (Alias (E)) or else Is_Internal (E) then
  1789.  
  1790.                   --  E is a derived operation or an internal operator which
  1791.                   --  is being overridden. Remove E from further visibility.
  1792.                   --  Furthermore, if E is a dispatching operation, it must be
  1793.                   --  replaced in the list of primitive operations of its type
  1794.  
  1795.                   declare
  1796.                      Prev : Entity_Id;
  1797.  
  1798.                   begin
  1799.                      Prev := First_Entity (Current_Scope);
  1800.  
  1801.                      while Next_Entity (Prev) /= E loop
  1802.                         Prev := Next_Entity (Prev);
  1803.                      end loop;
  1804.  
  1805.                      --  E must be removed both from the entity_list of the
  1806.                      --  current scope, and from the visibility chain
  1807.  
  1808.                      if Debug_Flag_E then
  1809.                         Write_Str ("Override implicit operation ");
  1810.                         Write_Int (Int (E));
  1811.                         Write_Eol;
  1812.                      end if;
  1813.  
  1814.                      --  If E is a predefined concatenation, it stands for four
  1815.                      --  different operations. As a result, a single explicit
  1816.                      --  declaration does not hide it. In a possible ambiguous
  1817.                      --  situation, Disambiguate chooses the user-defined op,
  1818.                      --  so it is correct to retain the previous internal one.
  1819.  
  1820.                      if Chars (E) /= Name_Op_Concat then
  1821.  
  1822.                         --  Find predecessor of E in Homonym chain.
  1823.  
  1824.                         if E = Current_Entity (E) then
  1825.                            Prev_Vis := Empty;
  1826.                         else
  1827.                            Prev_Vis := Current_Entity (E);
  1828.                            while Homonym (Prev_Vis) /= E loop
  1829.                               Prev_Vis := Homonym (Prev_Vis);
  1830.                            end loop;
  1831.                         end if;
  1832.  
  1833.                         if Prev_Vis /= Empty then
  1834.  
  1835.                            --  Skip E in the visibility chain
  1836.  
  1837.                            Set_Homonym (Prev_Vis, Homonym (E));
  1838.  
  1839.                         else
  1840.                            Set_Name_Entity_Id (Chars (E), Homonym (E));
  1841.                         end if;
  1842.  
  1843.                         Set_Next_Entity (Prev, Next_Entity (E));
  1844.  
  1845.                         if No (Next_Entity (Prev)) then
  1846.                            Set_Last_Entity (Current_Scope, Prev);
  1847.                         end if;
  1848.                      end if;
  1849.  
  1850.                      Enter_Overloaded_Entity (S);
  1851.  
  1852.                      if Is_Dispatching_Operation (E) then
  1853.                         Check_Dispatching_Operation (S, E);
  1854.                      else
  1855.                         Check_Dispatching_Operation (S, Empty);
  1856.                      end if;
  1857.  
  1858.                      return;
  1859.                   end;
  1860.  
  1861.                --  Here we have a real error (identical profile)
  1862.  
  1863.                else
  1864.                   Error_Msg_Sloc := Sloc (E);
  1865.                   Error_Msg_N ("& conflicts with declaration#", S);
  1866.                   return;
  1867.                end if;
  1868.  
  1869.             else
  1870.                null;
  1871.             end if;
  1872.  
  1873.             Prev_Vis := E;
  1874.             E := Homonym (E);
  1875.          end loop;
  1876.  
  1877.          --  On exit, we know that S is a new entity
  1878.  
  1879.          Enter_Overloaded_Entity (S);
  1880.          Check_Dispatching_Operation (S, Empty);
  1881.       end if;
  1882.  
  1883.    end New_Overloaded_Entity;
  1884.  
  1885.    ---------------------
  1886.    -- Process_Formals --
  1887.    ---------------------
  1888.  
  1889.    procedure Process_Formals
  1890.      (S           : Entity_Id;
  1891.       T           : List_Id;
  1892.       Related_Nod : Node_Id)
  1893.    is
  1894.       Param_Spec  : Node_Id;
  1895.       Formal      : Entity_Id;
  1896.       Formal_Type : Entity_Id;
  1897.       Default     : Node_Id;
  1898.  
  1899.    begin
  1900.       --  In order to prevent premature use of the formals in the same formal
  1901.       --  part, the Ekind is left undefined until all default expressions are
  1902.       --  analyzed. The Ekind is established in a separate loop at the end.
  1903.  
  1904.       Param_Spec := First (T);
  1905.  
  1906.       while Present (Param_Spec) loop
  1907.  
  1908.          --  Case of ordinary parameters
  1909.  
  1910.          if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then
  1911.             Find_Type (Parameter_Type (Param_Spec));
  1912.             Formal_Type := Entity (Parameter_Type (Param_Spec));
  1913.  
  1914.             if Ekind (Formal_Type) = E_Incomplete_Type
  1915.               or else (Is_Class_Wide_Type (Formal_Type)
  1916.                         and then Ekind (Root_Type (Formal_Type)) =
  1917.                                                          E_Incomplete_Type)
  1918.             then
  1919.                if Nkind (Parent (T)) /= N_Access_Function_Definition
  1920.                  and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
  1921.                then
  1922.                   Error_Msg_N ("invalid use of incomplete type", Param_Spec);
  1923.                end if;
  1924.             end if;
  1925.  
  1926.          else
  1927.             --  An access formal type
  1928.  
  1929.             Formal_Type :=
  1930.               Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
  1931.          end if;
  1932.  
  1933.          Formal := Defining_Identifier (Param_Spec);
  1934.          Enter_Name (Formal);
  1935.          Set_Etype (Formal, Formal_Type);
  1936.  
  1937.          Default :=  Expression (Param_Spec);
  1938.  
  1939.          if Present (Default) then
  1940.             if Out_Present (Param_Spec) then
  1941.                Error_Msg_N
  1942.                  ("default initialization only allowed for IN parameters",
  1943.                   Param_Spec);
  1944.             end if;
  1945.  
  1946.             --  Do the special preanalysis of the expression (see section on
  1947.             --  "Handling of Default Expressions" in the spec of package Sem).
  1948.  
  1949.             Analyze_Default_Expression (Default, Formal_Type);
  1950.          end if;
  1951.  
  1952.          Param_Spec := Next (Param_Spec);
  1953.       end loop;
  1954.  
  1955.       --  Now set the kind (mode) of each formal
  1956.  
  1957.       Param_Spec := First (T);
  1958.  
  1959.       while Present (Param_Spec) loop
  1960.          Formal := Defining_Identifier (Param_Spec);
  1961.          Set_Formal_Mode (Formal);
  1962.  
  1963.          if Ekind (Formal) = E_In_Parameter then
  1964.             Set_Default_Value (Formal, Expression (Param_Spec));
  1965.  
  1966.          else
  1967.             --  Set default value of Actual_Subtype. Will be recomputed
  1968.             --  within body if type is unconstrained.
  1969.  
  1970.             Set_Actual_Subtype (Formal, Etype (Formal));
  1971.          end if;
  1972.  
  1973.          Param_Spec := Next (Param_Spec);
  1974.       end loop;
  1975.  
  1976.    end Process_Formals;
  1977.  
  1978.    ---------------------
  1979.    -- Set_Formal_Mode --
  1980.    ---------------------
  1981.  
  1982.    procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
  1983.       Spec : constant Node_Id := Parent (Formal_Id);
  1984.  
  1985.    begin
  1986.       if Out_Present (Spec) then
  1987.  
  1988.          if Ekind (Scope (Formal_Id)) = E_Function
  1989.            or else Ekind (Scope (Formal_Id)) = E_Generic_Function
  1990.          then
  1991.             Error_Msg_N ("functions can only have IN parameters", Spec);
  1992.             Set_Ekind (Formal_Id, E_In_Parameter);
  1993.  
  1994.          elsif In_Present (Spec) then
  1995.             Set_Ekind (Formal_Id, E_In_Out_Parameter);
  1996.  
  1997.          else
  1998.             Set_Ekind (Formal_Id, E_Out_Parameter);
  1999.          end if;
  2000.  
  2001.       else
  2002.          Set_Ekind (Formal_Id, E_In_Parameter);
  2003.       end if;
  2004.    end Set_Formal_Mode;
  2005.  
  2006.    ------------------------
  2007.    -- Subtype_Conformant --
  2008.    ------------------------
  2009.  
  2010.    function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
  2011.       Result : Boolean;
  2012.  
  2013.    begin
  2014.       Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
  2015.       return Result;
  2016.    end Subtype_Conformant;
  2017.  
  2018.    ---------------------
  2019.    -- Type_Conformant --
  2020.    ---------------------
  2021.  
  2022.    function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
  2023.       Result : Boolean;
  2024.  
  2025.    begin
  2026.       Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
  2027.       return Result;
  2028.    end Type_Conformant;
  2029.  
  2030.    -------------------------------
  2031.    -- Valid_Operator_Definition --
  2032.    -------------------------------
  2033.  
  2034.    procedure Valid_Operator_Definition (Designator : Entity_Id) is
  2035.       N    : Integer := 0;
  2036.       F    : Entity_Id;
  2037.       Id   : constant Name_Id := Chars (Designator);
  2038.       N_OK : Boolean;
  2039.  
  2040.    begin
  2041.       F := First_Formal (Designator);
  2042.  
  2043.       while Present (F) loop
  2044.          N := N + 1;
  2045.  
  2046.          if Present (Default_Value (F)) then
  2047.             Error_Msg_N
  2048.               ("default values not allowed for operator parameters",
  2049.                Parent (F));
  2050.          end if;
  2051.  
  2052.          F := Next_Formal (F);
  2053.       end loop;
  2054.  
  2055.       --  Verify that user-defined operators have proper number of arguments
  2056.       --  First case of operators which can only be unary
  2057.  
  2058.       if Id = Name_Op_Not
  2059.         or else Id = Name_Op_Abs
  2060.       then
  2061.          N_OK := (N = 1);
  2062.  
  2063.       --  Case of operators which can be unary or binary
  2064.  
  2065.       elsif Id = Name_Op_Add
  2066.         or Id = Name_Op_Subtract
  2067.       then
  2068.          N_OK := (N in 1 .. 2);
  2069.  
  2070.       --  All other operators can only be binary
  2071.  
  2072.       else
  2073.          N_OK := (N = 2);
  2074.       end if;
  2075.  
  2076.       if not N_OK then
  2077.          Error_Msg_N
  2078.            ("incorrect number of arguments for operator", Designator);
  2079.       end if;
  2080.  
  2081.       if Id = Name_Op_Ne
  2082.         and then Comes_From_Source (Designator)
  2083.         and then Etype (Designator) = Standard_Boolean then
  2084.          Error_Msg_N
  2085.             ("explicit definition of inequality not allowed", Designator);
  2086.       end if;
  2087.    end Valid_Operator_Definition;
  2088.  
  2089. end Sem_Ch6;
  2090.