[Ada] Predicates on partial views

[Arnaud Charlet]

This patch fixes some errors in the handling of dynamic predicates applied to
private types.

Compiling and executing the following:

    gnatmake -q -gnata main
    main

must yield:

   Endevour
   Ariane5
   Failure to launch

---
with gnat.io;
with ada.assertions;
procedure Main is
   package SpaceShuttles is
      type SpaceShuttle (Name : not null access constant String) is
         tagged  private
      with
       Dynamic_Predicate => SpaceShuttle.name.all'length > 6;

       function Make (Ptr : not null access constant String) return
          SpaceShuttle;
   private
      type SpaceShuttle (Name : not null access constant String) is
         tagged null record;
   end SpaceShuttles;
   package body SpaceShuttles is
       function Make (Ptr : not null access constant String) return
          SpaceShuttle
       is
       begin
          return (Name => Ptr);
       end Make;
   end SpaceShuttles;
   use SpaceShuttles;

   Name : aliased constant String := "Endevour";
   Endevour : SpaceShuttles.SpaceShuttle(Name'Access);
   Her : aliased constant String := "Ariane5";
   Ariane : SpaceShuttle := Make (Her'access);
begin
   gnat.io.Put_Line(Endevour.name.all);
   gnat.io.Put_Line(Ariane.name.all);

   declare
      Dud : aliased constant String := "Ariane";
      Failure : SpaceShuttle := Make (Dud'access);
   begin
      null;
   end;

exception
   when Ada.Assertions.Assertion_Error =>
      gnat.io.put_line ("Failure to launch");
end Main;

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

2014-02-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Process_Full_View): Fix typo in the order of
	parameters when propagating predicate function to full view.
	(Find_Type_Of_Object): Freeze base type of object type to catch
	premature use of discriminated private type without a full view.

-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 207533)
+++ sem_ch3.adb	(working copy)
@@ -15772,8 +15772,12 @@
            and then No (Expression (P))
          then
             null;
+
+         --  Here we freeze the base type of object type to catch premature use
+         --  of discriminated private type without a full view.
+
          else
-            Insert_Actions (Obj_Def, Freeze_Entity (T, P));
+            Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P));
          end if;
 
       --  Ada 2005 AI-406: the object definition in an object declaration
@@ -18675,7 +18679,7 @@
          end;
       end if;
 
-      --  Ada 2005 AI 161: Check preelaboratable initialization consistency
+      --  Ada 2005 AI 161: Check preelaborable initialization consistency
 
       if Known_To_Have_Preelab_Init (Priv_T) then
 
@@ -18737,10 +18741,16 @@
          Set_Has_Inheritable_Invariants (Full_T);
       end if;
 
-      --  Propagate predicates to full type
+      --  Propagate predicates to full type, and predicate function if already
+      --  defined. It is not clear that this can actually happen? the partial
+      --  view cannot be frozen yet, and the predicate function has not been
+      --  built. Still it is a cheap check and seems safer to make it.
 
       if Has_Predicates (Priv_T) then
-         Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
+         if Present (Predicate_Function (Priv_T)) then
+            Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
+         end if;
+
          Set_Has_Predicates (Full_T);
       end if;
    end Process_Full_View;