diff mbox

[Ada] Crash processing private type whose parent is an interface type

Message ID 20100909094818.GA7437@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Sept. 9, 2010, 9:48 a.m. UTC 
The compiler may crash processing a derivation of a private type that
has interfaces. The source of this problem is that when the parent of
a private type is an interface, the parent of its full-view may be
any type that covers such interface (and this detail caused an assert
failure in the frontend).

The following test must compile silently:

package Pkg_1 is
   type Iface_1 is interface;

   type Iface_2 is interface and Iface_1;
   function Prim_1 (Self : Iface_2) return Boolean is abstract;

   type Typ_1 is new Iface_1 with null record;
   procedure Finalize (Self : Typ_1);

   type Typ_2 is new Typ_1 and Iface_2 with null record;
   function Prim_1 (Self : Typ_2) return Boolean;
end;

with Pkg_1; use Pkg_1;
package Pkg_2 is
   type Test_Typ is new Iface_2 with private;       --  Test
private
   type Test_Typ is new Typ_2 with null record;
end;

with Pkg_2; use Pkg_2;
package Pkg_3 is
   type Test_DT is new Test_Typ with null record;
end;

Command: gcc -c -gnat05 pkg_3.ads

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-09-09  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Derive_Subprogram): The code that checks if a
	dispatching primitive covers some interface primitive is incomplete.
	Replace such code by the invocation of a new subprogram that provides
	this functionality.
	* sem_ch6.ads (Is_Interface_Conformant): Add missing documentation.
	* sem_ch6.adb (Check_Missing_Return): Minor reformating
	(Check_Convention): Complete if-statement conditition when reporting
	errors (to avoid assertion failure).
	* sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously
	located in exp_ch3. Relocated inside Analyze_Freeze_Entity.
	(Analyze_Freeze_Entity): Invoke routine that adds the spec of non
	overridden null interface primitives.
	* sem_type.adb (Is_Ancestor): If the parent of the partial view of a
	private type is an interface then use the parent of its full view to
	climb to its ancestor type.
	* sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram.
	(Check_Dispatching_Operation): Extend assertion to handle wrappers of
	null interface primitives.
	(Is_Null_Interface_Primitive): New subprogram.
	* exp_ch3.adb (Make_Null_Procedure_Specs): Removed.
	(Expand_Freeze_Record_Type): Do not generate specs of null interface
	subprograms because they are now generated by Analyze_Freeze_Entity.
diff mbox

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 164058)
+++ sem_ch3.adb	(working copy)
@@ -12284,10 +12284,6 @@  package body Sem_Ch3 is
          end if;
       end Set_Derived_Name;
 
-      --  Local variables
-
-      Parent_Overrides_Interface_Primitive : Boolean := False;
-
    --  Start of processing for Derive_Subprogram
 
    begin
@@ -12295,23 +12291,6 @@  package body Sem_Ch3 is
          New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
       Set_Ekind (New_Subp, Ekind (Parent_Subp));
 
-      --  Check whether the parent overrides an interface primitive
-
-      if Is_Overriding_Operation (Parent_Subp) then
-         declare
-            E : Entity_Id := Parent_Subp;
-         begin
-            while Present (Overridden_Operation (E)) loop
-               E := Ultimate_Alias (Overridden_Operation (E));
-            end loop;
-
-            Parent_Overrides_Interface_Primitive :=
-              Is_Dispatching_Operation (E)
-                and then Present (Find_Dispatching_Type (E))
-                and then Is_Interface (Find_Dispatching_Type (E));
-         end;
-      end if;
-
       --  Check whether the inherited subprogram is a private operation that
       --  should be inherited but not yet made visible. Such subprograms can
       --  become visible at a later point (e.g., the private part of a public
@@ -12380,7 +12359,10 @@  package body Sem_Ch3 is
       --  overrides an interface primitive because interface primitives
       --  must be visible in the partial view of the parent (RM 7.3 (7.3/2))
 
-      elsif Parent_Overrides_Interface_Primitive then
+      elsif Ada_Version >= Ada_05
+         and then Is_Dispatching_Operation (Parent_Subp)
+         and then Covers_Some_Interface (Parent_Subp)
+      then
          Set_Derived_Name;
 
       --  Otherwise, the type is inheriting a private operation, so enter
Index: sem_type.adb
===================================================================
--- sem_type.adb	(revision 164058)
+++ sem_type.adb	(working copy)
@@ -2619,7 +2619,19 @@  package body Sem_Type is
                return True;
 
             elsif Etype (Par) /= Par then
-               Par := Etype (Par);
+
+               --  If this is a private type and its parent is an interface
+               --  then use the parent of the full view (which is a type that
+               --  implements such interface)
+
+               if Is_Private_Type (Par)
+                 and then Is_Interface (Etype (Par))
+                 and then Present (Full_View (Par))
+               then
+                  Par := Etype (Full_View (Par));
+               else
+                  Par := Etype (Par);
+               end if;
             else
                return False;
             end if;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 164056)
+++ sem_ch6.adb	(working copy)
@@ -1714,7 +1714,7 @@  package body Sem_Ch6 is
            and then Present (Spec_Id)
            and then No_Return (Spec_Id)
          then
-               Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
+            Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
          end if;
       end Check_Missing_Return;
 
@@ -4037,7 +4037,9 @@  package body Sem_Ch6 is
                   Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
                   Error_Msg_Sloc   := Sloc (Op);
 
-                  if Comes_From_Source (Op) then
+                  if Comes_From_Source (Op)
+                    or else No (Alias (Op))
+                  then
                      if not Is_Overriding_Operation (Op) then
                         Error_Msg_N ("\\primitive % defined #", Typ);
                      else
Index: sem_ch6.ads
===================================================================
--- sem_ch6.ads	(revision 164000)
+++ sem_ch6.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -183,9 +183,9 @@  package Sem_Ch6 is
      (Tagged_Type : Entity_Id;
       Iface_Prim  : Entity_Id;
       Prim        : Entity_Id) return Boolean;
-   --  Returns true if both primitives have a matching name and they are also
-   --  type conformant. Special management is done for functions returning
-   --  interfaces.
+   --  Returns true if both primitives have a matching name, they are type
+   --  conformant, and Prim is defined in the scope of Tagged_Type. Special
+   --  management is done for functions returning interfaces.
 
    function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
    --  Determine whether two callable entities (subprograms, entries,
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 164058)
+++ sem_ch13.adb	(working copy)
@@ -44,6 +44,7 @@  with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
@@ -2356,6 +2357,106 @@  package body Sem_Ch13 is
    procedure Analyze_Freeze_Entity (N : Node_Id) is
       E : constant Entity_Id := Entity (N);
 
+      function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
+      --  Ada 2005 (AI-251): Makes specs for null procedures associated with
+      --  null procedures inherited from interface types that have not been
+      --  overridden. Only one null procedure will be created for a given
+      --  set of inherited null procedures with homographic profiles.
+
+      -------------------------------
+      -- Make_Null_Procedure_Specs --
+      -------------------------------
+
+      function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id
+      is
+         Decl_List      : constant List_Id    := New_List;
+         Loc            : constant Source_Ptr := Sloc (Tag_Typ);
+         Formal         : Entity_Id;
+         Formal_List    : List_Id;
+         New_Param_Spec : Node_Id;
+         Parent_Subp    : Entity_Id;
+         Prim_Elmt      : Elmt_Id;
+         Proc_Decl      : Node_Id;
+         Subp           : Entity_Id;
+
+      begin
+         Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+         while Present (Prim_Elmt) loop
+            Subp := Node (Prim_Elmt);
+
+            --  If a null procedure inherited from an interface has not been
+            --  overridden, then we build a null procedure declaration to
+            --  override the inherited procedure.
+
+            Parent_Subp := Alias (Subp);
+
+            if Present (Parent_Subp)
+              and then Is_Null_Interface_Primitive (Parent_Subp)
+            then
+               Formal_List := No_List;
+               Formal := First_Formal (Subp);
+
+               if Present (Formal) then
+                  Formal_List := New_List;
+
+                  while Present (Formal) loop
+
+                     --  Copy the parameter spec including default expressions
+
+                     New_Param_Spec :=
+                       New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+
+                     --  Generate a new defining identifier for the new formal.
+                     --  required because New_Copy_Tree does not duplicate
+                     --  semantic fields (except itypes).
+
+                     Set_Defining_Identifier (New_Param_Spec,
+                       Make_Defining_Identifier (Sloc (Formal),
+                         Chars => Chars (Formal)));
+
+                     --  For controlling arguments we must change their
+                     --  parameter type to reference the tagged type (instead
+                     --  of the interface type)
+
+                     if Is_Controlling_Formal (Formal) then
+                        if Nkind (Parameter_Type (Parent (Formal)))
+                          = N_Identifier
+                        then
+                           Set_Parameter_Type (New_Param_Spec,
+                             New_Occurrence_Of (Tag_Typ, Loc));
+
+                        else pragma Assert
+                               (Nkind (Parameter_Type (Parent (Formal)))
+                                  = N_Access_Definition);
+                           Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+                             New_Occurrence_Of (Tag_Typ, Loc));
+                        end if;
+                     end if;
+
+                     Append (New_Param_Spec, Formal_List);
+
+                     Next_Formal (Formal);
+                  end loop;
+               end if;
+
+               Proc_Decl :=
+                 Make_Subprogram_Declaration (Loc,
+                   Make_Procedure_Specification (Loc,
+                     Defining_Unit_Name =>
+                       Make_Defining_Identifier (Loc, Chars (Subp)),
+                     Parameter_Specifications => Formal_List,
+                     Null_Present => True));
+               Append_To (Decl_List, Proc_Decl);
+            end if;
+
+            Next_Elmt (Prim_Elmt);
+         end loop;
+
+         return Decl_List;
+      end Make_Null_Procedure_Specs;
+
+   --  Start of processing for Analyze_Freeze_Entity
+
    begin
       --  For tagged types covering interfaces add internal entities that link
       --  the primitives of the interfaces with the primitives that cover them.
@@ -2374,6 +2475,21 @@  package body Sem_Ch13 is
         and then not Is_Interface (E)
         and then Has_Interfaces (E)
       then
+         --  Add specs of non-overridden null interface primitives. During
+         --  semantic analysis this is required to ensure consistency of the
+         --  contents of the list of primitives of the tagged type. Routine
+         --  Add_Internal_Interface_Entities will take care of adding to such
+         --  list the internal entities that link each interface primitive with
+         --  the primitive of Tagged_Type that covers it; hence these specs
+         --  must be added before invoking Add_Internal_Interface_Entities.
+         --  In the expansion this consistency is required to ensure that the
+         --  dispatch table slots associated with non-overridden null interface
+         --  primitives are properly filled.
+
+         if not Is_Abstract_Type (E) then
+            Insert_Actions (N, Make_Null_Procedure_Specs (E));
+         end if;
+
          --  This would be a good common place to call the routine that checks
          --  overriding of interface primitives (and thus factorize calls to
          --  Check_Abstract_Overriding located at different contexts in the
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 164000)
+++ sem_disp.adb	(working copy)
@@ -91,6 +91,81 @@  package body Sem_Disp is
       Append_Unique_Elmt (New_Op, List);
    end Add_Dispatching_Operation;
 
+   ---------------------------
+   -- Covers_Some_Interface --
+   ---------------------------
+
+   function Covers_Some_Interface (Prim : Entity_Id) return Boolean is
+      Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim);
+      Elmt        : Elmt_Id;
+      E           : Entity_Id;
+
+   begin
+      pragma Assert (Is_Dispatching_Operation (Prim));
+
+      --  Although this is a dispatching primitive we must check if its
+      --  dispatching type is available because it may be the primitive
+      --  of a private type not defined as tagged in its partial view.
+
+      if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then
+
+         --  If the tagged type is frozen then the internal entities associated
+         --  with interfaces are available in the list of primitives of the
+         --  tagged type and can be used to speed up this search.
+
+         if Is_Frozen (Tagged_Type) then
+            Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+            while Present (Elmt) loop
+               E := Node (Elmt);
+
+               if Present (Interface_Alias (E))
+                 and then Alias (E) = Prim
+               then
+                  return True;
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+
+         --  Otherwise we must collect all the interface primitives and check
+         --  if the Prim will override some interface primitive.
+
+         else
+            declare
+               Ifaces_List : Elist_Id;
+               Iface_Elmt  : Elmt_Id;
+               Iface       : Entity_Id;
+               Iface_Prim  : Entity_Id;
+
+            begin
+               Collect_Interfaces (Tagged_Type, Ifaces_List);
+               Iface_Elmt := First_Elmt (Ifaces_List);
+               while Present (Iface_Elmt) loop
+                  Iface := Node (Iface_Elmt);
+
+                  Elmt := First_Elmt (Primitive_Operations (Iface));
+                  while Present (Elmt) loop
+                     Iface_Prim := Node (Elmt);
+
+                     if Chars (E) = Chars (Prim)
+                       and then Is_Interface_Conformant
+                                  (Tagged_Type, Iface_Prim, Prim)
+                     then
+                        return True;
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+
+                  Next_Elmt (Iface_Elmt);
+               end loop;
+            end;
+         end if;
+      end if;
+
+      return False;
+   end Covers_Some_Interface;
+
    -------------------------------
    -- Check_Controlling_Formals --
    -------------------------------
@@ -794,7 +869,10 @@  package body Sem_Disp is
          --     type by Make_Controlling_Function_Wrappers. However, attribute
          --     Is_Dispatching_Operation must be set to true.
 
-         --  2. Subprograms associated with stream attributes (built by
+         --  2. Ada 2005 (AI-251): Wrapper procedures of null interface
+         --     primitives.
+
+         --  3. Subprograms associated with stream attributes (built by
          --     New_Stream_Subprogram)
 
          if Present (Old_Subp)
@@ -805,9 +883,17 @@  package body Sem_Disp is
              ((Ekind (Subp) = E_Function
                 and then Is_Dispatching_Operation (Old_Subp)
                 and then Is_Null_Extension (Base_Type (Etype (Subp))))
+               or else
+                (Ekind (Subp) = E_Procedure
+                  and then Is_Dispatching_Operation (Old_Subp)
+                  and then Present (Alias (Old_Subp))
+                  and then Is_Null_Interface_Primitive
+                             (Ultimate_Alias (Old_Subp)))
                or else Get_TSS_Name (Subp) = TSS_Stream_Read
                or else Get_TSS_Name (Subp) = TSS_Stream_Write);
 
+            Check_Controlling_Formals (Tagged_Type, Subp);
+            Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
             Set_Is_Dispatching_Operation (Subp);
          end if;
 
@@ -1602,6 +1688,19 @@  package body Sem_Disp is
       end if;
    end Is_Dynamically_Tagged;
 
+   ---------------------------------
+   -- Is_Null_Interface_Primitive --
+   ---------------------------------
+
+   function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
+   begin
+      return Comes_From_Source (E)
+        and then Is_Dispatching_Operation (E)
+        and then Ekind (E) = E_Procedure
+        and then Null_Present (Parent (E))
+        and then Is_Interface (Find_Dispatching_Type (E));
+   end Is_Null_Interface_Primitive;
+
    --------------------------
    -- Is_Tag_Indeterminate --
    --------------------------
Index: sem_disp.ads
===================================================================
--- sem_disp.ads	(revision 164000)
+++ sem_disp.ads	(working copy)
@@ -66,6 +66,11 @@  package Sem_Disp is
    --  of "OldSubp" is adjusted to point to the inherited procedure of the
    --  full view because it is always this one which has to be called.
 
+   function Covers_Some_Interface (Prim : Entity_Id) return Boolean;
+   --  Returns true if Prim covers some interface primitive of its associated
+   --  tagged type. The tagged type of Prim must be frozen when this function
+   --  is invoked.
+
    function Find_Controlling_Arg (N : Node_Id) return Node_Id;
    --  Returns the actual controlling argument if N is dynamically tagged,
    --  and Empty if it is not dynamically tagged.
@@ -87,6 +92,9 @@  package Sem_Disp is
    --  an expression of a class_Wide type, or a call to a function with
    --  controlling result where at least one operand is dynamically tagged.
 
+   function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
+   --  Returns True if E is a null procedure that is an interface primitive
+
    function Is_Tag_Indeterminate (N : Node_Id) return Boolean;
    --  An expression is tag-indeterminate if it is a call that dispatches
    --  on result, and all controlling operands are also indeterminate.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 164055)
+++ exp_ch3.adb	(working copy)
@@ -312,14 +312,6 @@  package body Exp_Ch3 is
    --  invoking the inherited subprogram's parent subprogram and extended
    --  with a null association list.
 
-   procedure Make_Null_Procedure_Specs
-     (Tag_Typ   : Entity_Id;
-      Decl_List : out List_Id);
-   --  Ada 2005 (AI-251): Makes specs for null procedures associated with any
-   --  null procedures inherited from an interface type that have not been
-   --  overridden. Only one null procedure will be created for a given set of
-   --  inherited null procedures with homographic profiles.
-
    function Predef_Spec_Or_Body
      (Loc      : Source_Ptr;
       Tag_Typ  : Entity_Id;
@@ -5886,7 +5878,6 @@  package body Exp_Ch3 is
 
       Wrapper_Decl_List   : List_Id := No_List;
       Wrapper_Body_List   : List_Id := No_List;
-      Null_Proc_Decl_List : List_Id := No_List;
 
    --  Start of processing for Expand_Freeze_Record_Type
 
@@ -6089,20 +6080,6 @@  package body Exp_Ch3 is
                Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
             end if;
 
-            --  Ada 2005 (AI-251): For a nonabstract type extension, build
-            --  null procedure declarations for each set of homographic null
-            --  procedures that are inherited from interface types but not
-            --  overridden. This is done to ensure that the dispatch table
-            --  entry associated with such null primitives are properly filled.
-
-            if Ada_Version >= Ada_05
-              and then Etype (Def_Id) /= Def_Id
-              and then not Is_Abstract_Type (Def_Id)
-            then
-               Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
-               Insert_Actions (N, Null_Proc_Decl_List);
-            end if;
-
             Set_Is_Frozen (Def_Id);
             Set_All_DT_Position (Def_Id);
 
@@ -8021,118 +7998,6 @@  package body Exp_Ch3 is
       end if;
    end Make_Eq_If;
 
-   -------------------------------
-   -- Make_Null_Procedure_Specs --
-   -------------------------------
-
-   procedure Make_Null_Procedure_Specs
-     (Tag_Typ   : Entity_Id;
-      Decl_List : out List_Id)
-   is
-      Loc : constant Source_Ptr := Sloc (Tag_Typ);
-
-      Formal         : Entity_Id;
-      Formal_List    : List_Id;
-      New_Param_Spec : Node_Id;
-      Parent_Subp    : Entity_Id;
-      Prim_Elmt      : Elmt_Id;
-      Proc_Decl      : Node_Id;
-      Subp           : Entity_Id;
-
-      function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
-      --  Returns True if E is a null procedure that is an interface primitive
-
-      ---------------------------------
-      -- Is_Null_Interface_Primitive --
-      ---------------------------------
-
-      function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
-      begin
-         return Comes_From_Source (E)
-           and then Is_Dispatching_Operation (E)
-           and then Ekind (E) = E_Procedure
-           and then Null_Present (Parent (E))
-           and then Is_Interface (Find_Dispatching_Type (E));
-      end Is_Null_Interface_Primitive;
-
-   --  Start of processing for Make_Null_Procedure_Specs
-
-   begin
-      Decl_List := New_List;
-      Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
-      while Present (Prim_Elmt) loop
-         Subp := Node (Prim_Elmt);
-
-         --  If a null procedure inherited from an interface has not been
-         --  overridden, then we build a null procedure declaration to
-         --  override the inherited procedure.
-
-         Parent_Subp := Alias (Subp);
-
-         if Present (Parent_Subp)
-           and then Is_Null_Interface_Primitive (Parent_Subp)
-         then
-            Formal_List := No_List;
-            Formal := First_Formal (Subp);
-
-            if Present (Formal) then
-               Formal_List := New_List;
-
-               while Present (Formal) loop
-
-                  --  Copy the parameter spec including default expressions
-
-                  New_Param_Spec :=
-                    New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
-
-                  --  Generate a new defining identifier for the new formal.
-                  --  required because New_Copy_Tree does not duplicate
-                  --  semantic fields (except itypes).
-
-                  Set_Defining_Identifier (New_Param_Spec,
-                    Make_Defining_Identifier (Sloc (Formal),
-                      Chars => Chars (Formal)));
-
-                  --  For controlling arguments we must change their
-                  --  parameter type to reference the tagged type (instead
-                  --  of the interface type)
-
-                  if Is_Controlling_Formal (Formal) then
-                     if Nkind (Parameter_Type (Parent (Formal)))
-                       = N_Identifier
-                     then
-                        Set_Parameter_Type (New_Param_Spec,
-                          New_Occurrence_Of (Tag_Typ, Loc));
-
-                     else pragma Assert
-                            (Nkind (Parameter_Type (Parent (Formal)))
-                               = N_Access_Definition);
-                        Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
-                          New_Occurrence_Of (Tag_Typ, Loc));
-                     end if;
-                  end if;
-
-                  Append (New_Param_Spec, Formal_List);
-
-                  Next_Formal (Formal);
-               end loop;
-            end if;
-
-            Proc_Decl :=
-              Make_Subprogram_Declaration (Loc,
-                Make_Procedure_Specification (Loc,
-                  Defining_Unit_Name =>
-                    Make_Defining_Identifier (Loc, Chars (Subp)),
-                  Parameter_Specifications => Formal_List,
-                  Null_Present => True));
-            Append_To (Decl_List, Proc_Decl);
-            Analyze (Proc_Decl);
-         end if;
-
-         Next_Elmt (Prim_Elmt);
-      end loop;
-   end Make_Null_Procedure_Specs;
-
    -------------------------------------
    -- Make_Predefined_Primitive_Specs --
    -------------------------------------