diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/ca/ca11008.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/ca/ca11008.a | 216 |
1 files changed, 216 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11008.a b/gcc/testsuite/ada/acats/tests/ca/ca11008.a new file mode 100644 index 000000000..1161fbe0c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11008.a @@ -0,0 +1,216 @@ +-- CA11008.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a private child package can use entities declared in the +-- visible part of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing types and objects used +-- by the system. Declare a private child package that uses the parent +-- components to provide functionality to the system. +-- +-- The tagged file type defined in the parent has defaults for all +-- component fields. Prior to initialization, these values are checked +-- to ensure a correct start condition. The initial subprogram is +-- called, which utilizes the functionality provided in the private +-- child package. This subprogram changes the fields of the file object +-- to something other than the default values, and this process is then +-- verified at the conclusion of the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package CA11008_0 is -- Package OS. + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System, Bypass); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Max_Files : constant File_Descriptor_Type := 100; + Constant_Name : constant File_Name_Type := "AdaFileName"; + File_Counter : Integer := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + + -- + + function Get_File_Name return File_Name_Type; + + function Initialize_File return File_Descriptor_Type; + +end CA11008_0; -- Package OS. + + --=================================================================-- + +-- Subprograms that perform the actual file operations are contained in a +-- private package so that they are not accessible to any client. + +private package CA11008_0.CA11008_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent + -- object. + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function. + File_Mode : File_Mode_Type := Read_Write) -- Parent literal. + return File_Descriptor_Type; -- Parent type. + +end CA11008_0.CA11008_1; -- Package OS.Internals + + --=================================================================-- + +package body CA11008_0.CA11008_1 is -- Package body OS.Internals + + function Next_Available_File return File_Descriptor_Type is + begin + Private_File_Counter := Private_File_Counter + 1; + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ----------------------------------------------------------------- + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function + File_Mode : File_Mode_Type := Read_Write) -- Parent literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent object + File_Table(Number).Name := File_Name; -- Default parameter value + File_Table(Number).Mode := File_Mode; -- Default parameter value + File_Table(Number).Acct_Access := User; + File_Table(Number).Current_Status := Open; + return (Number); + end Initialize; + +end CA11008_0.CA11008_1; -- Package body OS.Internals + + --=================================================================-- + +with CA11008_0.CA11008_1; -- Private child package "withed" by + -- parent body. + +package body CA11008_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (Constant_Name); -- Of course if this was a real function, the + end Get_File_Name; -- user would be asked to input a name, or + -- there would be some type of similar process. + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + function Initialize_File return File_Descriptor_Type is + begin + return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + +end CA11008_0; -- Package body OS + + --=================================================================-- + +with CA11008_0; -- with Package OS. +with Report; + +procedure CA11008 is + + package OS renames CA11008_0; + use OS; + Ada_File_Key : File_Descriptor_Type := Default_Descriptor; + +begin + + -- This test indicates one approach to file management operations. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a user situation, that being the implementation of certain functions + -- being provided in a child package, with the parent package body + -- utilizing these implementations. + + Report.Test ("CA11008", "Check that a private child package can use " & + "entities declared in the visible part of its " & + "parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + if (Ada_File_Key /= Default_Descriptor) or else + (File_Table(1).Descriptor /= (Default_Descriptor) or + (File_Table(1).Name /= Default_Filename)) or else + (File_Table(1).Acct_Access /= (Default_Permission) or + (File_Table(1).Mode /= Default_Mode)) or else + (File_Table(1).Current_Status /= Default_Status) + then + Report.Failed ("Initial condition failure"); + end if; + + -- Call the initialization function. This will result in the resetting + -- of the fields associated with the first entry in the File_Table (this + -- is the first call of Initialize_File). + -- No parameters are necessary for this call, due to the default values + -- provided in the private child package routine Initialize. + + Ada_File_Key := Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not ((File_Table(1).Descriptor = Ada_File_Key) and then + (File_Table(1).Name = Constant_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + +end CA11008; |