Patchwork [Ada] Storage_Error due to large object size

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 6, 2013, 10:31 a.m.
Message ID <20130206103158.GA28217@adacore.com>
Download mbox | patch
Permalink /patch/218535/
State New
Headers show

Comments

Arnaud Charlet - Feb. 6, 2013, 10:31 a.m.
This patch corrects the decoration of type attribute Has_Unknown_Discriminants
when building the full view of a private subtype.

------------
-- Source --
------------

--  root.ads

package Root is
end Root;

--  root-scopes.ads

package Root.Scopes is
   type Scope_T is interface;
   function Scope_Of (Scope_Name : String) return Scope_T is abstract;
end Root.Scopes;

--  root-scopes-basics.ads

private package Root.Scopes.Basics is
   type Scope_T
     (Length : Natural) is abstract new Root.Scopes.Scope_T with
   record
      Name : String (1 .. Length) := (others => ' ');
   end record;
end Root.Scopes.Basics;

--  root-scopes-domains.ads

private with Root.Scopes.Basics;

generic
package Root.Scopes.Domains is
   type Scope_T (<>) is new Root.Scopes.Scope_T with private;
   overriding function Scope_Of (Scope_Name : String) return Scope_T;

private
   subtype Parent_T is Root.Scopes.Basics.Scope_T;

   type Scope_T is new Parent_T with record
      Comp : Integer;
   end record;
end Root.Scopes.Domains;

--  root-scopes-domains.adb

package body Root.Scopes.Domains is
   function Scope_Of (Scope_Name : String) return Scope_T is
   begin
      return (Length => Scope_Name'Length,
              Name   => Scope_Name,
              Comp   => 5);
   end Scope_Of;
end Root.Scopes.Domains;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Root.Scopes.Domains;

procedure Main is
   package Inst is new Root.Scopes.Domains;
   subtype Scope_T is Inst.Scope_T;

   S_1 : constant Scope_T := Inst.Scope_Of ("One");
   S_2 : Scope_T renames S_1;
   S_3 : Scope_T := Inst.Scope_Of ("Three");

begin
   Put_Line ("OK");
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q -gnat05 main.adb
$ ./main
OK

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

2013-02-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb (Complete_Private_Subtype): Inherit the
	Has_Unknown_Discriminants from the full view of the base type.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 195788)
+++ sem_ch3.adb	(working copy)
@@ -10255,15 +10255,17 @@ 
               Protected_Kind   =>
             Copy_Node (Priv, Full);
 
-            Set_Has_Discriminants  (Full, Has_Discriminants (Full_Base));
-            Set_First_Entity       (Full, First_Entity (Full_Base));
-            Set_Last_Entity        (Full, Last_Entity (Full_Base));
+            Set_Has_Discriminants (Full, Has_Discriminants (Full_Base));
+            Set_Has_Unknown_Discriminants
+              (Full, Has_Unknown_Discriminants (Full_Base));
+            Set_First_Entity      (Full, First_Entity (Full_Base));
+            Set_Last_Entity       (Full, Last_Entity (Full_Base));
 
          when others =>
             Copy_Node (Full_Base, Full);
-            Set_Chars          (Full, Chars (Priv));
-            Conditional_Delay  (Full, Priv);
-            Set_Sloc           (Full, Sloc (Priv));
+            Set_Chars         (Full, Chars (Priv));
+            Conditional_Delay (Full, Priv);
+            Set_Sloc          (Full, Sloc (Priv));
       end case;
 
       Set_Next_Entity (Full, Save_Next_Entity);
@@ -17388,7 +17390,6 @@ 
       if Is_Private_Type (Id_B) then
          Append_Elmt (Id, Private_Dependents (Id_B));
       end if;
-
    end Prepare_Private_Subtype_Completion;
 
    ---------------------------