[Ada] Freezing the designated type of an access_to_subprogram_type

Message ID 20100617152444.GA14164@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet June 17, 2010, 3:24 p.m.
A type cannot be frozen if it is not yet fully defined. For the designated
type of an access_to_subprogram_type, all the types in its profile must be
fully defined before the subprogram type itself can be frozen.

The following must compile quietly:
with Statefull_Artifact_G;
procedure Main is
   type State is (CREATED, REVIEWED);
   type Activity is (REVIEW);

   package Requirement is
        new Statefull_Artifact_G (State, Activity, State'First);
end Main;
with Ada.Finalization;
   type State is (<>);
   type Activity is (<>);
   Initial_State : State := State'First;
package Statefull_Artifact_G is

   type Statefull_Artifact is
      abstract new Ada.Finalization.Controlled with private;

   type Guard is access function (This : Statefull_Artifact'Class)
                                  return Boolean;
   type State_Ref is access all State;
   type Guard_Map is array (State, Activity) of Guard;
   Guards : Guard_Map := (others => (others => null));

   type Statefull_Artifact is
      abstract new Ada.Finalization.Controlled with record
      Current_State : State_Ref := null;
   end record;
end Statefull_Artifact_G;

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

2010-06-17  Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb (Freeze_Expression): The designated type of an
	access_to_suprogram type can only be frozen if all types in its profile
	are fully defined.


Index: freeze.adb
--- freeze.adb	(revision 160905)
+++ freeze.adb	(working copy)
@@ -5306,6 +5306,26 @@  package body Freeze is
             return True;
+      --  For the designated type of an access to subprogram. all types in
+      --  the profile must be fully defined.
+      elsif Ekind (T) = E_Subprogram_Type then
+         declare
+            F : Entity_Id;
+         begin
+            F := First_Formal (T);
+            while Present (F) loop
+               if not Is_Fully_Defined (Etype (F)) then
+                  return False;
+               end if;
+               Next_Formal (F);
+            end loop;
+            return Is_Fully_Defined (Etype (T));
+         end;
          return not Is_Private_Type (T)
            or else Present (Full_View (Base_Type (T)));