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

   1 -- CA11003.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 public grandchild can utilize its ancestor unit's visible
  28 --      definitions.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      Declare a public package, public child package, and public
  32 --      grandchild package and library unit function.  Within the
  33 --      grandchild package and function, make use of components that are
  34 --      declared in the ancestor packages, both parent and grandparent.
  35 --
  36 --      Use the following ancestral components in the grandchildren library
  37 --      units:
  38 --                       Grandparent   Parent
  39 --          Type              X           X
  40 --          Constant          X           X
  41 --          Object            X           X
  42 --          Subprogram        X           X
  43 --          Exception         X           X
  44 --
  45 --
  46 -- CHANGE HISTORY:
  47 --      06 Dec 94   SAIC    ACVC 2.0
  48 --      21 Dec 94   SAIC    Modified procedure Create_File
  49 --      15 Nov 95   SAIC    Update and repair for ACVC 2.0.1
  50 --
  51 --!
  52
  53 package CA11003_0 is      -- Package OS
  54
  55    type File_Descriptor is new Integer;
  56    type File_Mode       is (Read_Only, Write_Only, Read_Write);
  57
  58    Null_File       : constant File_Descriptor := 0;
  59    Default_Mode    : constant File_Mode       := Read_Only;
  60    File_Data_Error : exception;
  61
  62    type File_Type is tagged
  63      record
  64         Descriptor : File_Descriptor := Null_File;
  65         Mode       : File_Mode       := Read_Write;
  66      end record;
  67
  68    System_File : File_Type;
  69
  70    function Next_Available_File return File_Descriptor;
  71
  72    procedure Reclaim_File_Descriptor;
  73
  74 end CA11003_0;               -- Package OS
  75
  76      --=================================================================--
  77
  78 package body CA11003_0 is    -- Package body OS
  79
  80    File_Count : Integer := 0;
  81
  82    function Next_Available_File return File_Descriptor is
  83    begin
  84       File_Count := File_Count + 1;
  85       return (File_Descriptor(File_Count));
  86    end Next_Available_File;
  87    --------------------------------------------------
  88    procedure Reclaim_File_Descriptor is
  89    begin
  90       null;                                        -- Dummy processing unit.
  91    end Reclaim_File_Descriptor;
  92
  93 end CA11003_0;                          -- Package body OS
  94
  95      --=================================================================--
  96
  97 package CA11003_0.CA11003_1 is          -- Child package OS.Operations
  98
  99    subtype File_Length_Type is Integer range 0 .. 1000;
 100    Min_File_Size : File_Length_Type := File_Length_Type'First;
 101    Max_File_Size : File_Length_Type := File_Length_Type'Last;
 102
 103    File_Duplication_Error : exception;
 104
 105    type Extended_File_Type is new File_Type with private;
 106
 107    procedure Create_File (Mode : in     File_Mode;
 108                           File :    out Extended_File_Type);
 109
 110    procedure Duplicate_File (Original  : in     Extended_File_Type;
 111                              Duplicate :    out Extended_File_Type);
 112
 113 private
 114    type Extended_File_Type is new File_Type with
 115       record
 116          Blocks : File_Length_Type := Min_File_Size;
 117       end record;
 118
 119    System_Extended_File : Extended_File_Type;
 120
 121 end CA11003_0.CA11003_1;                -- Child Package OS.Operations
 122
 123      --=================================================================--
 124
 125 package body CA11003_0.CA11003_1 is     -- Child package body OS.Operations
 126
 127    procedure Create_File
 128      (Mode : in     File_Mode;
 129       File :    out Extended_File_Type) is
 130    begin
 131       File.Descriptor := Next_Available_File;           -- Parent subprogram.
 132       File.Mode       := Default_Mode;                  -- Parent constant.
 133       File.Blocks     := Min_File_Size;
 134    end Create_File;
 135    --------------------------------------------------
 136    procedure Duplicate_File (Original  : in     Extended_File_Type;
 137                              Duplicate :    out Extended_File_Type) is
 138    begin
 139       Duplicate.Descriptor := Next_Available_File;      -- Parent subprogram.
 140       Duplicate.Mode       := Original.Mode;
 141       Duplicate.Blocks     := Original.Blocks;
 142    end Duplicate_File;
 143
 144 end CA11003_0.CA11003_1;                   -- Child package body OS.Operations
 145
 146      --=================================================================--
 147
 148 -- This package contains menu selectable operations for manipulating files.
 149 -- This abstraction builds on the capabilities available from ancestor
 150 -- packages.
 151
 152 package CA11003_0.CA11003_1.CA11003_2 is
 153
 154    procedure News (Mode : in     File_Mode;
 155                    File :    out Extended_File_Type);
 156
 157    procedure Copy (Original  : in     Extended_File_Type;
 158                    Duplicate :    out Extended_File_Type);
 159
 160    procedure Delete   (File : in Extended_File_Type);
 161
 162 end CA11003_0.CA11003_1.CA11003_2;  -- Grandchild package OS.Operations.Menu
 163
 164      --=================================================================--
 165
 166 -- Grandchild subprogram Validate
 167 function  CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type)
 168   return Boolean;
 169
 170      --=================================================================--
 171
 172 -- Grandchild subprogram Validate
 173 function  CA11003_0.CA11003_1.CA11003_3
 174   (File : in Extended_File_Type)                            -- Parent type.
 175   return Boolean is
 176
 177    function New_File_Validated (File : Extended_File_Type)
 178        return Boolean is
 179    begin
 180       if (File.Descriptor > System_File.Descriptor) and     -- Grandparent
 181          (File.Mode in File_Mode ) and                      -- object and type
 182          not ((File.Blocks < System_Extended_File.Blocks) or
 183               (File.Blocks > Max_File_Size))                -- Parent object
 184       then                                                  -- and constant.
 185          return True;
 186       else
 187          return False;
 188       end if;
 189    end New_File_Validated;
 190
 191 begin
 192    return (New_File_Validated (File)) and
 193           (File.Descriptor /= Null_File);              -- Grandparent constant.
 194
 195 end CA11003_0.CA11003_1.CA11003_3;      -- Grandchild subprogram Validate
 196
 197      --=================================================================--
 198
 199 with CA11003_0.CA11003_1.CA11003_3;
 200                                  -- Grandchild package body OS.Operations.Menu
 201 package body CA11003_0.CA11003_1.CA11003_2 is
 202
 203    procedure News (Mode : in     File_Mode;
 204                    File :    out Extended_File_Type) is   -- Parent type.
 205    begin
 206       Create_File (Mode, File);                           -- Parent subprogram.
 207       if not CA11003_0.CA11003_1.CA11003_3 (File) then
 208          raise File_Data_Error;                       -- Grandparent exception.
 209       end if;
 210    end News;
 211    --------------------------------------------------
 212    procedure Copy (Original  : in     Extended_File_Type;
 213                    Duplicate :    out Extended_File_Type) is
 214    begin
 215       Duplicate_File (Original, Duplicate);               -- Parent subprogram.
 216
 217       if Original.Descriptor = Duplicate.Descriptor then
 218          raise File_Duplication_Error;                    -- Parent exception.
 219       end if;
 220
 221    end Copy;
 222    --------------------------------------------------
 223    procedure Delete (File : in Extended_File_Type) is
 224    begin
 225       Reclaim_File_Descriptor;                            -- Grandparent
 226    end Delete;                                            -- subprogram.
 227
 228 end CA11003_0.CA11003_1.CA11003_2;
 229
 230      --=================================================================--
 231
 232 with CA11003_0.CA11003_1.CA11003_2;  -- Grandchild Pkg OS.Operations.Menu
 233 with CA11003_0.CA11003_1.CA11003_3;  -- Grandchild Ftn OS.Operations.Validate
 234 with Report;
 235
 236 procedure CA11003 is
 237
 238    package Menu renames CA11003_0.CA11003_1.CA11003_2;
 239
 240 begin
 241
 242    Report.Test ("CA11003", "Check that a public grandchild can utilize " &
 243                 "its ancestor unit's visible definitions");
 244
 245    File_Processing:         -- Validate all of the capabilities contained in
 246                             -- the Menu package by exercising them on specific
 247                             -- files.  This will demonstrate the use of child
 248                             -- and grandchild functionality based on components
 249                             -- that have been declared in the
 250                             -- parent/grandparent package.
 251    declare
 252
 253       function Validate (File : CA11003_0.CA11003_1.Extended_File_Type)
 254         return Boolean renames CA11003_0.CA11003_1.CA11003_3;
 255
 256       MacWrite_File,
 257       Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type;
 258       MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write;
 259
 260    begin
 261
 262       Menu.News (MacWrite_File_Mode, MacWrite_File);
 263
 264       if not Validate (MacWrite_File) then
 265          Report.Failed ("Incorrect initialization of files");
 266       end if;
 267
 268       Menu.Copy (MacWrite_File, Backup_Copy);
 269
 270       if not (Validate (MacWrite_File) and
 271               Validate (Backup_Copy))
 272       then
 273          Report.Failed ("Incorrect duplication of files");
 274       end if;
 275
 276       Menu.Delete (Backup_Copy);
 277
 278    exception
 279       when CA11003_0.File_Data_Error =>
 280           Report.Failed ("Exception raised during file validation");
 281       when CA11003_0.CA11003_1.File_Duplication_Error =>
 282           Report.Failed ("Exception raised during file duplication");
 283       when others =>
 284           Report.Failed ("Unexpected exception in test procedure");
 285
 286    end File_Processing;
 287
 288    Report.Result;
 289
 290 end CA11003;