diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11010.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11010.a | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11010.a new file mode 100644 index 000000000..b13efd798 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11010.a @@ -0,0 +1,254 @@ +-- CA11010.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 +-- private part of its parent unit. +-- +-- TEST DESCRIPTION: +-- Declare a parent package containing private types, objects, +-- and functions used by the system. Declare a private child package that +-- uses the parent components to provide functionality to the system. +-- +-- Declare an array of files with default values for all +-- component fields of the files (records). Check the initial state of +-- a specified file for proper default values. Perform the file "creation" +-- (initialization), which will modify the fields of the record object. +-- Again verify the file object to determine whether the fields have been +-- reset properly. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- + +package CA11010_0 is -- Package OS. + + type File_Descriptor_Type is private; + + Default_Descriptor : constant File_Descriptor_Type; + + function Initialize_File return File_Descriptor_Type; + procedure Verify_Initial_Conditions (Status : out Boolean); + function Final_Conditions_Valid return Boolean; + +private + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System); + 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 := " "; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + Max_Files : constant File_Descriptor_Type := 100; + + 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; + File_Counter : Integer := 0; + + -- + + function Get_File_Name return File_Name_Type; + +end CA11010_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 CA11010_0.CA11010_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent priv. object. + + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function. + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal. + return File_Descriptor_Type; -- Parent type. + +end CA11010_0.CA11010_1; -- Package OS.Internals + + --=================================================================-- + +package body CA11010_0.CA11010_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 priv. function + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent priv. 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 CA11010_0.CA11010_1; -- Package body OS.Internals + + --=================================================================-- + +with CA11010_0.CA11010_1; -- Private child package "withed" by + -- parent body. + +package body CA11010_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); -- If this was a real function, the user + end Get_File_Name; -- would be asked to input a name, or there + -- would be some type of similar processing. + + -- 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 (CA11010_0.CA11010_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + + -- + -- Separate subunits. + -- + + procedure Verify_Initial_Conditions (Status : out Boolean) is separate; + + function Final_Conditions_Valid return Boolean is separate; + +end CA11010_0; -- Package body OS + + --=================================================================-- + +separate (CA11010_0) +procedure Verify_Initial_Conditions (Status : out Boolean) is +begin + Status := False; + if (File_Table(1).Descriptor = Default_Descriptor) and then + (File_Table(1).Name = Default_Filename) and then + (File_Table(1).Acct_Access = Default_Permission) and then + (File_Table(1).Mode = Default_Mode) and then + (File_Table(1).Current_Status = Default_Status) + then + Status := True; + end if; +end Verify_Initial_Conditions; + + --=================================================================-- + +separate (CA11010_0) +function Final_Conditions_Valid return Boolean is +begin + if ((File_Table(1).Descriptor /= Default_Descriptor) and then + (File_Table(1).Name = An_Ada_File_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 + return (True); + else + return (False); + end if; +end Final_Conditions_Valid; + + --=================================================================-- + +with CA11010_0; -- with Package OS. +with Report; + +procedure CA11010 is + + package OS renames CA11010_0; + + Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor; + Initialization_Status : Boolean := False; + +begin + + -- This test indicates one approach to a file management operation. + -- 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 ("CA11010", "Check that a private child package can use " & + "entities declared in the private 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. + + OS.Verify_Initial_Conditions (Initialization_Status); + + if not Initialization_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/only 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 := OS.Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not OS.Final_Conditions_Valid then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + +end CA11010; |