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, 0 insertions, 216 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11008.a b/gcc/testsuite/ada/acats/tests/ca/ca11008.a deleted file mode 100644 index 1161fbe0c3a..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11008.a +++ /dev/null @@ -1,216 +0,0 @@ --- 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; |