gcc/testsuite/ada/acats/tests/c3/c3a0015.a

   1 -- C3A0015.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     The Ada Conformity Assessment Authority (ACAA) holds unlimited
   6 --     rights in the software and documentation contained herein. Unlimited
   7 --     rights are the same as those granted by the U.S. Government for older
   8 --     parts of the Ada Conformity Assessment Test Suite, and are defined
   9 --     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
  10 --     intends to confer upon all recipients unlimited rights equal to those
  11 --     held by the ACAA. These rights include rights to use, duplicate,
  12 --     release or disclose the released technical data and computer software
  13 --     in whole or in part, in any manner and for any purpose whatsoever, and
  14 --     to have or permit others to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --    Check that a derived access type has the same storage pool as its
  28 --    parent.  (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)).
  29 --
  30 -- CHANGE HISTORY:
  31 --    24 JAN 2001   PHL   Initial version.
  32 --    29 JUN 2001   RLB   Reformatted for ACATS.
  33 --
  34 --!
  35 with System.Storage_Elements;
  36 use System.Storage_Elements;
  37 with System.Storage_Pools;
  38 use System.Storage_Pools;
  39 package C3A0015_0 is
  40
  41     type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with
  42         record
  43             First_Free : Storage_Count := 1;
  44             Contents : Storage_Array (1 .. Storage_Size);
  45         end record;
  46
  47     procedure Allocate (Pool : in out C3A0015_0.Pool;
  48                         Storage_Address : out System.Address;
  49                         Size_In_Storage_Elements : in Storage_Count;
  50                         Alignment : in Storage_Count);
  51
  52     procedure Deallocate (Pool : in out C3A0015_0.Pool;
  53                           Storage_Address : in System.Address;
  54                           Size_In_Storage_Elements : in Storage_Count;
  55                           Alignment : in Storage_Count);
  56
  57     function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count;
  58
  59 end C3A0015_0;
  60
  61 package body C3A0015_0 is
  62
  63     use System;
  64
  65     procedure Allocate (Pool : in out C3A0015_0.Pool;
  66                         Storage_Address : out System.Address;
  67                         Size_In_Storage_Elements : in Storage_Count;
  68                         Alignment : in Storage_Count) is
  69         Unaligned_Address : constant System.Address :=
  70            Pool.Contents (Pool.First_Free)'Address;
  71         Unalignment : Storage_Count;
  72     begin
  73         Unalignment := Unaligned_Address mod Alignment;
  74         if Unalignment = 0 then
  75             Storage_Address := Unaligned_Address;
  76             Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements;
  77         else
  78             Storage_Address :=
  79                Pool.Contents (Pool.First_Free + Alignment - Unalignment)'
  80                   Address;
  81             Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements +
  82                                   Alignment - Unalignment;
  83         end if;
  84     end Allocate;
  85
  86     procedure Deallocate (Pool : in out C3A0015_0.Pool;
  87                           Storage_Address : in System.Address;
  88                           Size_In_Storage_Elements : in Storage_Count;
  89                           Alignment : in Storage_Count) is
  90     begin
  91         if Storage_Address + Size_In_Storage_Elements =
  92            Pool.Contents (Pool.First_Free)'Address then
  93             -- Only deallocate if the block is at the end.
  94             Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements;
  95         end if;
  96     end Deallocate;
  97
  98     function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is
  99     begin
 100         return Pool.Storage_Size;
 101     end Storage_Size;
 102
 103 end C3A0015_0;
 104
 105 with Ada.Exceptions;
 106 use Ada.Exceptions;
 107 with Ada.Unchecked_Deallocation;
 108 with Report;
 109 use Report;
 110 with System.Storage_Elements;
 111 use System.Storage_Elements;
 112 with C3A0015_0;
 113 procedure C3A0015 is
 114
 115     type Standard_Pool is access Float;
 116     type Derived_Standard_Pool is new Standard_Pool;
 117     type Derived_Derived_Standard_Pool is new Derived_Standard_Pool;
 118
 119     type User_Defined_Pool is access Integer;
 120     type Derived_User_Defined_Pool is new User_Defined_Pool;
 121     type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool;
 122
 123     My_Pool : C3A0015_0.Pool (1024);
 124     for User_Defined_Pool'Storage_Pool use My_Pool;
 125
 126     generic
 127         type Designated is private;
 128         Value : Designated;
 129         type Acc is access Designated;
 130         type Derived_Acc is new Acc;
 131     procedure Check (Subtest : String; User_Defined_Pool : Boolean);
 132
 133     procedure Check (Subtest : String; User_Defined_Pool : Boolean) is
 134
 135         procedure Deallocate is
 136            new Ada.Unchecked_Deallocation (Object => Designated,
 137                                            Name => Acc);
 138         procedure Deallocate is
 139            new Ada.Unchecked_Deallocation (Object => Designated,
 140                                            Name => Derived_Acc);
 141
 142         First_Free : Storage_Count;
 143         X : Acc;
 144         Y : Derived_Acc;
 145     begin
 146         if User_Defined_Pool then
 147             First_Free := My_Pool.First_Free;
 148         end if;
 149         X := new Designated'(Value);
 150         if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
 151             Failed (Subtest &
 152                     " - Allocation didn't consume storage in the pool - 1");
 153         else
 154             First_Free := My_Pool.First_Free;
 155         end if;
 156
 157         Y := Derived_Acc (X);
 158         if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
 159             Failed (Subtest &
 160                     " - Conversion did consume storage in the pool - 1");
 161         end if;
 162         if Y.all /= Value then
 163             Failed (Subtest &
 164                     " - Incorrect allocation/conversion of access values - 1");
 165         end if;
 166
 167         Deallocate (Y);
 168         if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
 169             Failed (Subtest &
 170                     " - Deallocation didn't release storage from the pool - 1");
 171         else
 172             First_Free := My_Pool.First_Free;
 173         end if;
 174
 175         Y := new Designated'(Value);
 176         if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
 177             Failed (Subtest &
 178                     " - Allocation didn't consume storage in the pool - 2");
 179         else
 180             First_Free := My_Pool.First_Free;
 181         end if;
 182
 183         X := Acc (Y);
 184         if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
 185             Failed (Subtest &
 186                     " - Conversion did consume storage in the pool - 2");
 187         end if;
 188         if X.all /= Value then
 189             Failed (Subtest &
 190                     " - Incorrect allocation/conversion of access values - 2");
 191         end if;
 192
 193         Deallocate (X);
 194         if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
 195             Failed (Subtest &
 196                     " - Deallocation didn't release storage from the pool - 2");
 197         end if;
 198     exception
 199         when E: others =>
 200             Failed (Subtest & " - Exception " & Exception_Name (E) &
 201                     " raised - " & Exception_Message (E));
 202     end Check;
 203
 204
 205 begin
 206     Test ("C3A0015", "Check that a dervied access type has the same " &
 207                         "storage pool as its parent");
 208
 209     Comment ("Access types using the standard storage pool");
 210
 211     Std:
 212         declare
 213             procedure Check1 is
 214                new Check (Designated => Float,
 215                           Value => 3.0,
 216                           Acc => Standard_Pool,
 217                           Derived_Acc => Derived_Standard_Pool);
 218             procedure Check2 is
 219                new Check (Designated => Float,
 220                           Value => 4.0,
 221                           Acc => Standard_Pool,
 222                           Derived_Acc => Derived_Derived_Standard_Pool);
 223             procedure Check3 is
 224                new Check (Designated => Float,
 225                           Value => 5.0,
 226                           Acc => Derived_Standard_Pool,
 227                           Derived_Acc => Derived_Derived_Standard_Pool);
 228         begin
 229             Check1 ("Standard_Pool/Derived_Standard_Pool",
 230                     User_Defined_Pool => False);
 231             Check2 ("Standard_Pool/Derived_Derived_Standard_Pool",
 232                     User_Defined_Pool => False);
 233             Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool",
 234                     User_Defined_Pool => False);
 235         end Std;
 236
 237     Comment ("Access types using a user-defined storage pool");
 238
 239     User:
 240         declare
 241             procedure Check1 is
 242                new Check (Designated => Integer,
 243                           Value => 17,
 244                           Acc => User_Defined_Pool,
 245                           Derived_Acc => Derived_User_Defined_Pool);
 246             procedure Check2 is
 247                new Check (Designated => Integer,
 248                           Value => 18,
 249                           Acc => User_Defined_Pool,
 250                           Derived_Acc => Derived_Derived_User_Defined_Pool);
 251             procedure Check3 is
 252                new Check (Designated => Integer,
 253                           Value => 19,
 254                           Acc => Derived_User_Defined_Pool,
 255                           Derived_Acc => Derived_Derived_User_Defined_Pool);
 256         begin
 257             Check1 ("User_Defined_Pool/Derived_User_Defined_Pool",
 258                     User_Defined_Pool => True);
 259             Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool",
 260                     User_Defined_Pool => True);
 261             Check3
 262                ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool",
 263                 User_Defined_Pool => True);
 264         end User;
 265
 266     Result;
 267 end C3A0015;