diff gcc/testsuite/gnat.dg/subpools1.adb @ 19:2b5abeee2509 default tip

update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/gnat.dg/subpools1.adb	Mon May 25 07:50:57 2020 +0900
@@ -0,0 +1,82 @@
+-- { dg-do compile }
+
+with System.Storage_Elements;
+with System.Storage_Pools.Subpools;
+
+procedure Subpools1 is
+
+   use System.Storage_Pools.Subpools;
+
+   package Local_Pools is
+
+      use System.Storage_Elements;
+
+      type Local_Pool is new Root_Storage_Pool_With_Subpools with null record;
+
+      overriding
+      function Create_Subpool (Pool: in out Local_Pool)
+                               return not null Subpool_Handle;
+
+      overriding
+      procedure Allocate_From_Subpool
+        (Pool                    : in out Local_Pool;
+         Storage_Address         :    out System.Address;
+         Size_In_Storage_Elements: in     Storage_Count;
+         Alignment               : in     Storage_Count;
+         Subpool                 : in     not null Subpool_Handle);
+
+      overriding
+      procedure Deallocate_Subpool
+        (Pool   : in out Local_Pool;
+         Subpool: in out Subpool_Handle) is null;
+
+   end Local_Pools;
+
+   package body Local_Pools is
+
+      type Local_Subpool is new Root_Subpool with null record;
+
+      Dummy_Subpool: aliased Local_Subpool;
+
+      overriding
+      function Create_Subpool (Pool: in out Local_Pool)
+                               return not null Subpool_Handle 
+      is 
+      begin 
+         return Result: not null Subpool_Handle 
+           := Dummy_Subpool'Unchecked_Access
+         do
+            Set_Pool_Of_Subpool (Result, Pool);
+         end return;
+      end;
+
+      overriding
+      procedure Allocate_From_Subpool
+        (Pool                    : in out Local_Pool;
+         Storage_Address         :    out System.Address;
+         Size_In_Storage_Elements: in     Storage_Count;
+         Alignment               : in     Storage_Count;
+         Subpool                 : in     not null Subpool_Handle)
+      is
+         type Storage_Array_Access is access Storage_Array;
+
+         New_Alloc: Storage_Array_Access
+           := new Storage_Array (1 .. Size_In_Storage_Elements + Alignment);
+      begin
+         for SE of New_Alloc.all loop
+            Storage_Address := SE'Address;
+            exit when Storage_Address mod Alignment = 0;
+         end loop;
+      end;
+
+   end Local_Pools;
+
+   A_Pool: Local_Pools.Local_Pool;
+
+   type Integer_Access is access Integer with Storage_Pool => A_Pool;
+
+   X: Integer_Access := new Integer; 
+
+begin
+   null;
+end;