gomp-20050608-branch/gcc/testsuite/ada/acats/tests/ca/ca11006.a

   1 -- CA11006.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     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 the private part of a child library unit can utilize
  28 --      its parent unit's private definition.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      Declare a package and public child package, both with private
  32 --      parts.  The child package will have a private extension of a type
  33 --      declared in the parent's private part.  In addition, the private
  34 --      part of the child package specification will make use of some of
  35 --      the components declared in the private part of the parent.
  36 --
  37 --
  38 -- CHANGE HISTORY:
  39 --      06 Dec 94   SAIC    ACVC 2.0
  40 --      15 Nov 95   SAIC    Update and repair for ACVC 2.0.1
  41 --
  42 --!
  43
  44 package CA11006_0 is      -- Package File_Package
  45
  46    type File_Descriptor is private;
  47    type File_Mode       is (Read_Only, Write_Only, Read_Write);
  48    type File_Type       is tagged private;
  49
  50    function  Next_Available_File return File_Descriptor;
  51
  52 private
  53
  54    type File_Measure    is range 0 .. 1000;
  55    type File_Descriptor is new Integer;
  56
  57    Null_File       : constant File_Descriptor := 0;
  58    Default_Mode    : constant File_Mode       := Read_Write;
  59
  60    type File_Type is tagged
  61      record
  62         Descriptor : File_Descriptor := Null_File;
  63         Mode       : File_Mode       := Default_Mode;
  64      end record;
  65
  66    System_File : File_Type;
  67
  68 end CA11006_0;               -- Package File_Package
  69
  70      --=================================================================--
  71
  72 package body CA11006_0 is    -- Package File_Package
  73
  74    File_Count : Integer := 0;
  75
  76    function Next_Available_File return File_Descriptor is
  77    begin
  78       File_Count := File_Count + 1;
  79       return File_Descriptor (File_Count);
  80    end Next_Available_File;
  81
  82 end CA11006_0;               -- Package File_Package
  83
  84      --=================================================================--
  85
  86 package CA11006_0.CA11006_1 is        -- Child package File_Package.Operations
  87
  88    type File_Length_Type   is private;
  89    type Extended_File_Type is new File_Type with private;
  90
  91    System_Extended_File : constant Extended_File_Type;
  92
  93    procedure Create_File (Mode : in     File_Mode;
  94                           File :    out Extended_File_Type);
  95
  96    procedure Compress_File (Original        : in     Extended_File_Type;
  97                             Compressed_File :    out Extended_File_Type);
  98
  99    function  Validate (File : in Extended_File_Type) return Boolean;
 100
 101    function  Validate_Compression (File : in Extended_File_Type)
 102      return Boolean;
 103                                    -- These two validation functions provide
 104                                    -- the capability to check the private
 105                                    -- components defined in the parent and
 106                                    -- child packages from within the client
 107                                    -- program.
 108 private
 109
 110    type File_Length_Type is new File_Measure;       -- Parent private type.
 111
 112    Min_File_Size : File_Length_Type := File_Length_Type'First;
 113    Max_File_Size : File_Length_Type := File_Length_Type'Last;
 114
 115    type Extended_File_Type is new File_Type with        -- Parent type.
 116       record
 117          Blocks : File_Length_Type := Min_File_Size;
 118       end record;
 119
 120    System_Extended_File : constant Extended_File_Type :=
 121      (Descriptor => System_File.Descriptor,      -- Parent private object.
 122       Mode       => Read_Only,                   -- Parent enumeration literal.
 123       Blocks     => Min_File_Size);
 124
 125
 126 end CA11006_0.CA11006_1;             -- Child Package File_Package.Operations
 127
 128      --=================================================================--
 129
 130                                 -- Child package body File_Package.Operations
 131 package body CA11006_0.CA11006_1 is
 132
 133    procedure Create_File
 134      (Mode : in     File_Mode;
 135       File :    out Extended_File_Type) is
 136    begin
 137       File.Descriptor := Next_Available_File;    -- Parent subprogram.
 138       File.Mode       := Default_Mode;           -- Parent private constant.
 139       File.Blocks     := Max_File_Size;
 140    end Create_File;
 141    ------------------------------------------------------------------------
 142    procedure Compress_File (Original        : in     Extended_File_Type;
 143                             Compressed_File :    out Extended_File_Type) is
 144    begin
 145       Compressed_File.Descriptor := Next_Available_File;
 146       Compressed_File.Mode       := Read_Only;
 147       Compressed_File.Blocks     := Original.Blocks / 2;  -- Simulated file
 148    end Compress_File;                                     -- compression.
 149    ------------------------------------------------------------------------
 150    function  Validate (File : in Extended_File_Type) return Boolean is
 151    begin
 152       if ((File.Descriptor /= System_Extended_File.Descriptor) and
 153           (File.Mode = Read_Write)                             and
 154           (File.Blocks = Max_File_Size))                       then
 155          return True;
 156       else
 157          return False;
 158       end if;
 159    end Validate;
 160    ------------------------------------------------------------------------
 161    function  Validate_Compression (File : in Extended_File_Type)
 162       return Boolean is
 163    begin
 164       if ((File.Descriptor /= System_File.Descriptor) and
 165           (File.Mode = Read_Only)                     and
 166           (File.Blocks = Max_File_Size/2))            then
 167          return True;
 168       else
 169          return False;
 170       end if;
 171    end Validate_Compression;
 172
 173 end CA11006_0.CA11006_1;         -- Child package body File_Package.Operations
 174
 175      --=================================================================--
 176
 177 with CA11006_0.CA11006_1;        -- with Child package File_Package.Operations
 178 with Report;
 179
 180 procedure CA11006 is
 181
 182    package File      renames CA11006_0;
 183    package File_Ops  renames CA11006_0.CA11006_1;
 184
 185    Validation_File_Mode : File.File_Mode := File.Read_Only;
 186    Validation_File,
 187    Storage_Copy         : File_Ops.Extended_File_Type;
 188
 189 begin
 190
 191    Report.Test ("CA11006", "Check that the private part of a child "  &
 192                            "library unit can utilize its parent "     &
 193                            "unit's private definition");
 194
 195    File_Ops.Create_File (Validation_File_Mode, Validation_File);
 196
 197    if not File_Ops.Validate (Validation_File) then
 198       Report.Failed ("Incorrect initialization of file");
 199    end if;
 200
 201    File_Ops.Compress_File (Validation_File, Storage_Copy);
 202
 203    if not (File_Ops.Validate (Validation_File) and
 204            File_Ops.Validate_Compression (Storage_Copy))
 205    then
 206       Report.Failed ("Incorrect compression of file");
 207    end if;
 208
 209    Report.Result;
 210
 211 end CA11006;