gcc/testsuite/ada/acats/tests/ca/ca11008.a

   1 -- CA11008.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 a private child package can use entities declared in the
  28 --      visible part of its parent unit.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      Declare a parent package containing types and objects used
  32 --      by the system. Declare a private child package that uses the parent
  33 --      components to provide functionality to the system.
  34 --
  35 --      The tagged file type defined in the parent has defaults for all
  36 --      component fields.  Prior to initialization, these values are checked
  37 --      to ensure a correct start condition.  The initial subprogram is
  38 --      called, which utilizes the functionality provided in the private
  39 --      child package.  This subprogram changes the fields of the file object
  40 --      to something other than the default values, and this process is then
  41 --      verified at the conclusion of the test.
  42 --
  43 --
  44 -- CHANGE HISTORY:
  45 --      06 Dec 94   SAIC    ACVC 2.0
  46 --
  47 --!
  48
  49 package CA11008_0 is               -- Package OS.
  50
  51    type File_Descriptor_Type is new Integer;
  52    type File_Name_Type       is new String (1 .. 11);
  53    type Permission_Type      is (None, User, System, Bypass);
  54    type File_Mode_Type       is (Read_Only, Write_Only, Read_Write);
  55    type File_Status_Type     is (Open, Closed);
  56
  57    Default_Descriptor : constant File_Descriptor_Type := 0;
  58    Default_Permission : constant Permission_Type      := None;
  59    Default_Mode       : constant File_Mode_Type       := Read_Only;
  60    Default_Status     : constant File_Status_Type     := Closed;
  61    Default_Filename   : constant File_Name_Type       := "           ";
  62
  63    Max_Files          : constant File_Descriptor_Type := 100;
  64    Constant_Name      : constant File_Name_Type       := "AdaFileName";
  65    File_Counter       : Integer                       := 0;
  66
  67    type File_Type is tagged
  68       record
  69          Descriptor     : File_Descriptor_Type := Default_Descriptor;
  70          Name           : File_Name_Type       := Default_Filename;
  71          Acct_Access    : Permission_Type      := Default_Permission;
  72          Mode           : File_Mode_Type       := Default_Mode;
  73          Current_Status : File_Status_Type     := Default_Status;
  74       end record;
  75
  76    type File_Array_Type is array (1 .. Max_Files) of File_Type;
  77
  78    File_Table : File_Array_Type;
  79
  80    --
  81
  82    function Get_File_Name return File_Name_Type;
  83
  84    function Initialize_File return File_Descriptor_Type;
  85
  86 end CA11008_0;                     -- Package OS.
  87
  88      --=================================================================--
  89
  90 -- Subprograms that perform the actual file operations are contained in a
  91 -- private package so that they are not accessible to any client.
  92
  93 private package CA11008_0.CA11008_1 is  -- Package OS.Internals
  94
  95    Private_File_Counter : Integer renames File_Counter;          -- Parent
  96                                                                  -- object.
  97    function Initialize
  98      (File_Name : File_Name_Type := Get_File_Name;      -- Parent function.
  99       File_Mode : File_Mode_Type := Read_Write)         -- Parent literal.
 100      return File_Descriptor_Type;                       -- Parent type.
 101
 102 end CA11008_0.CA11008_1;             -- Package OS.Internals
 103
 104      --=================================================================--
 105
 106 package body CA11008_0.CA11008_1 is  -- Package body OS.Internals
 107
 108    function Next_Available_File return File_Descriptor_Type is
 109    begin
 110       Private_File_Counter := Private_File_Counter + 1;
 111       return (File_Descriptor_Type(File_Counter));
 112    end Next_Available_File;
 113    -----------------------------------------------------------------
 114    function Initialize
 115      (File_Name : File_Name_Type := Get_File_Name; -- Parent function
 116       File_Mode : File_Mode_Type := Read_Write)    -- Parent literal
 117      return File_Descriptor_Type is                -- Parent type
 118       Number : File_Descriptor_Type;
 119    begin
 120       Number := Next_Available_File;
 121       File_Table(Number).Descriptor := Number;     -- Parent object
 122       File_Table(Number).Name := File_Name;        -- Default parameter value
 123       File_Table(Number).Mode := File_Mode;        -- Default parameter value
 124       File_Table(Number).Acct_Access := User;
 125       File_Table(Number).Current_Status := Open;
 126       return (Number);
 127    end Initialize;
 128
 129 end CA11008_0.CA11008_1;           -- Package body OS.Internals
 130
 131      --=================================================================--
 132
 133 with CA11008_0.CA11008_1;          -- Private child package "withed" by
 134                                    -- parent body.
 135
 136 package body CA11008_0 is          -- Package body OS
 137
 138    function Get_File_Name return File_Name_Type is
 139    begin
 140       return (Constant_Name);   -- Of course if this was a real function, the
 141    end Get_File_Name;           -- user would be asked to input a name, or
 142                                 -- there would be some type of similar process.
 143
 144    -- This subprogram utilizes a call to a subprogram contained in a private
 145    -- child to perform the actual processing.
 146
 147    function Initialize_File return File_Descriptor_Type is
 148    begin
 149      return (CA11008_0.CA11008_1.Initialize);    -- No parameters are needed,
 150                                                  -- since defaults have been
 151                                                  -- provided.
 152    end Initialize_File;
 153
 154 end CA11008_0;                         -- Package body OS
 155
 156      --=================================================================--
 157
 158 with CA11008_0;                        -- with Package OS.
 159 with Report;
 160
 161 procedure CA11008 is
 162
 163    package OS renames CA11008_0;
 164    use OS;
 165    Ada_File_Key : File_Descriptor_Type := Default_Descriptor;
 166
 167 begin
 168
 169    -- This test indicates one approach to file management operations.
 170    -- It is not intended to demonstrate full functionality, but rather
 171    -- that the use of a private child package can provide a solution
 172    -- to a user situation, that being the implementation of certain functions
 173    -- being provided in a child package, with the parent package body
 174    -- utilizing these implementations.
 175
 176    Report.Test ("CA11008", "Check that a private child package can use "   &
 177                            "entities declared in the visible part of its " &
 178                            "parent unit");
 179
 180    -- Check initial conditions of the first entry in the file table.
 181    -- These are all default values provided in the declaration of the
 182    -- type File_Type.
 183
 184    if (Ada_File_Key                 /= Default_Descriptor)  or else
 185       (File_Table(1).Descriptor     /= (Default_Descriptor) or
 186       (File_Table(1).Name           /= Default_Filename))   or else
 187       (File_Table(1).Acct_Access    /= (Default_Permission) or
 188       (File_Table(1).Mode           /= Default_Mode))       or else
 189       (File_Table(1).Current_Status /= Default_Status)
 190    then
 191       Report.Failed ("Initial condition failure");
 192    end if;
 193
 194    -- Call the initialization function.  This will result in the resetting
 195    -- of the fields associated with the first entry in the File_Table (this
 196    -- is the first call of Initialize_File).
 197    -- No parameters are necessary for this call, due to the default values
 198    -- provided in the private child package routine Initialize.
 199
 200    Ada_File_Key := Initialize_File;
 201
 202    -- Verify that the initial conditions of the file table component have
 203    -- been properly modified by the initialization function.
 204
 205    if not ((File_Table(1).Descriptor     = Ada_File_Key)         and then
 206            (File_Table(1).Name           = Constant_Name) and then
 207            (File_Table(1).Acct_Access    = User)              and then
 208            not ((File_Table(1).Mode      = Default_Mode)      or else
 209                 (File_Table(1).Current_Status = Default_Status)))
 210    then
 211       Report.Failed ("Initialization processing failure");
 212    end if;
 213
 214    Report.Result;
 215
 216 end CA11008;