diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/ca')
50 files changed, 0 insertions, 10040 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11001.a b/gcc/testsuite/ada/acats/tests/ca/ca11001.a deleted file mode 100644 index c9d1e486ca5..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11001.a +++ /dev/null @@ -1,276 +0,0 @@ --- CA11001.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 child unit can be used to provide an alternate view and --- operations on a private type in its parent package. Check that a --- child unit can be a package. Check that a WITH of a child unit --- includes an implicit WITH of its ancestor unit. --- --- TEST DESCRIPTION: --- Declare a private type in a package specification. Declare --- subprograms for the type. --- --- Add a public child to the above package. Within the body of this --- package, access the private type. Declare operations to read and --- write to its parent private type. --- --- In the main program, "with" the child. Declare objects of the --- parent private type. Access the subprograms from both parent and --- child packages. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CA11001_0 is -- Cartesian_Complex --- This package represents a Cartesian view of a complex number. It contains --- a private type plus subprograms to construct and decompose a complex --- number. - - type Complex_Int is range 0 .. 100; - - type Complex_Type is private; - - Constant_Complex : constant Complex_Type; - - Complex_Error : exception; - - procedure Cartesian_Assign (R, I : in Complex_Int; - C : out Complex_Type); - - function Cartesian_Real_Part (C : Complex_Type) - return Complex_Int; - - function Cartesian_Imag_Part (C : Complex_Type) - return Complex_Int; - - function Complex (Real, Imaginary : Complex_Int) - return Complex_Type; - -private - type Complex_Type is -- Parent private type - record - Real, Imaginary : Complex_Int; - end record; - - Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0); - -end CA11001_0; -- Cartesian_Complex - ---=======================================================================-- - -package body CA11001_0 is -- Cartesian_Complex - - procedure Cartesian_Assign (R, I : in Complex_Int; - C : out Complex_Type) is - begin - C.Real := R; - C.Imaginary := I; - end Cartesian_Assign; - ------------------------------------------------------------- - function Cartesian_Real_Part (C : Complex_Type) - return Complex_Int is - begin - return C.Real; - end Cartesian_Real_Part; - ------------------------------------------------------------- - function Cartesian_Imag_Part (C : Complex_Type) - return Complex_Int is - begin - return C.Imaginary; - end Cartesian_Imag_Part; - ------------------------------------------------------------- - function Complex (Real, Imaginary : Complex_Int) - return Complex_Type is - begin - return (Real, Imaginary); - end Complex; - -end CA11001_0; -- Cartesian_Complex - ---=======================================================================-- - -package CA11001_0.CA11001_1 is -- Polar_Complex --- This public child provides a different view of the private type from its --- parent. It provides a polar view by the provision of subprograms which --- construct and decompose a complex number. - - procedure Polar_Assign (R, Theta : in Complex_Int; - C : out Complex_Type); - -- Complex_Type is a - -- record of CA11001_0 - - function Polar_Real_Part (C: Complex_Type) return Complex_Int; - - function Polar_Imag_Part (C: Complex_Type) return Complex_Int; - - function Equals_Const (Num : Complex_Type) return Boolean; - -end CA11001_0.CA11001_1; -- Polar_Complex - ---=======================================================================-- - -package body CA11001_0.CA11001_1 is -- Polar_Complex - - function Cos (Angle : Complex_Int) return Complex_Int is - Num : constant Complex_Int := 2; - begin - return (Angle * Num); -- not true Cosine function - end Cos; - ------------------------------------------------------------- - function Sine (Angle : Complex_Int) return Complex_Int is - begin - return 1; -- not true Sine function - end Sine; - ------------------------------------------------------------- - function Sqrt (Num : Complex_Int) - return Complex_Int is - begin - return (Num); -- not true Square root function - end Sqrt; - ------------------------------------------------------------- - function Tan (Angle : Complex_Int) return Complex_Int is - begin - return Angle; -- not true Tangent function - end Tan; - ------------------------------------------------------------- - procedure Polar_Assign (R, Theta : in Complex_Int; - C : out Complex_Type) is - begin - if R = 0 and Theta = 0 then - raise Complex_Error; - end if; - C.Real := R * Cos (Theta); - C.Imaginary := R * Sine (Theta); - end Polar_Assign; - ------------------------------------------------------------- - function Polar_Real_Part (C: Complex_Type) return Complex_Int is - begin - return Sqrt ((Cartesian_Imag_Part (C)) ** 2 + - (Cartesian_Real_Part (C)) ** 2); - end Polar_Real_Part; - ------------------------------------------------------------- - function Polar_Imag_Part (C: Complex_Type) return Complex_Int is - begin - return (Tan (Cartesian_Imag_Part (C) / - Cartesian_Real_Part (C))); - end Polar_Imag_Part; - ------------------------------------------------------------- - function Equals_Const (Num : Complex_Type) return Boolean is - begin - return Num.Real = Constant_Complex.Real and - Num.Imaginary = Constant_Complex.Imaginary; - end Equals_Const; - -end CA11001_0.CA11001_1; -- Polar_Complex - ---=======================================================================-- - -with CA11001_0.CA11001_1; -- Polar_Complex -with Report; - -procedure CA11001 is - - Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a - -- record of CA11001_0 - - Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2); - - Int_2 : CA11001_0.Complex_Int - := CA11001_0.Complex_Int (Report.Ident_Int (2)); - -begin - - Report.Test ("CA11001", "Check that a child unit can be used " & - "to provide an alternate view and operations " & - "on a private type in its parent package"); - - Basic_View_Subtest: - - begin - -- Assign using Cartesian coordinates. - CA11001_0.Cartesian_Assign - (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No); - - -- Read back in Polar coordinates. - -- Polar values are surrogates used in checking for correct - -- subprogram calls. - if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No), - CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/=" - (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No), - CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then - Report.Failed ("Incorrect Cartesian result"); - end if; - - end Basic_View_Subtest; - ------------------------------------------------------------- - Alternate_View_Subtest: - begin - -- Assign using Polar coordinates. - CA11001_0.CA11001_1.Polar_Assign - (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No); - - -- Read back in Cartesian coordinates. - if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part - (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or - CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2) - then - Report.Failed ("Incorrect Polar result"); - end if; - end Alternate_View_Subtest; - ------------------------------------------------------------- - Other_Subtest: - begin - -- Assign using Polar coordinates. - CA11001_0.CA11001_1.Polar_Assign - (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No); - - -- Compare with Complex_Num in CA11001_0. - if not CA11001_0.CA11001_1.Equals_Const (Complex_No) - then - Report.Failed ("Incorrect result"); - end if; - end Other_Subtest; - ------------------------------------------------------------- - Exception_Subtest: - begin - -- Raised parent's exception. - CA11001_0.CA11001_1.Polar_Assign - (CA11001_0.Complex_Int (Report.Ident_Int (0)), - CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No); - Report.Failed ("Exception was not raised"); - exception - when CA11001_0.Complex_Error => - null; - when others => - Report.Failed ("Unexpected exception raised in test"); - end Exception_Subtest; - - Report.Result; - -end CA11001; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11002.a b/gcc/testsuite/ada/acats/tests/ca/ca11002.a deleted file mode 100644 index 189e1944c77..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11002.a +++ /dev/null @@ -1,238 +0,0 @@ --- CA11002.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 public child can utilize its parent unit's visible --- definitions. --- --- TEST DESCRIPTION: --- Declare a parent package that contains the following: type, object, --- constant, exception, and subprograms. Declare a public child unit --- that utilizes the components found in the visible part of its parent. --- --- Demonstrate utilization of the following parent components in the --- child package: --- --- Parent --- Type X --- Constant X --- Object X --- Subprogram X --- Exception X --- --- This abstraction simulates a portion of a simple operating system. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CA11002_0 is -- Package OS. - - type File_Descriptor is new Integer; - type File_Mode is (Read_Only, Write_Only, Read_Write); - - Null_File : constant File_Descriptor := 0; - Default_Mode : constant File_Mode := Read_Only; - Active_Mode : constant File_Mode := Read_Write; - - type File_Type is - record - Descriptor : File_Descriptor := Null_File; - Mode : File_Mode := Default_Mode; - end record; - - System_File : File_Type; - File_Mode_Error : exception; - - function Next_Available_File return File_Descriptor; - - function Mode_Of_File (File : File_Type) return File_Mode; - -end CA11002_0; -- Package OS. - - --=================================================================-- - -package body CA11002_0 is -- Package body OS. - - File_Count : Integer := 0; - - function Next_Available_File return File_Descriptor is - begin - File_Count := File_Count + 1; - return (File_Descriptor(File_Count)); -- Type conversion. - end Next_Available_File; - -------------------------------------------------------------- - function Mode_Of_File (File : File_Type) return File_Mode is - Mode : File_Mode := File.Mode; - begin - return (Mode); - end Mode_Of_File; - -end CA11002_0; -- Package body OS. - - --=================================================================-- - -package CA11002_0.CA11002_1 is -- Child package OS.Operations. - - -- Dot qualification of types, objects, etc. from parent is not required - -- in a child unit. - - procedure Create_File (Mode : in File_Mode:= Active_Mode; - File : out File_Type); - -end CA11002_0.CA11002_1; -- Child package OS.Operations. - - --=================================================================-- - -with Report; -package body CA11002_0.CA11002_1 is -- Child package body OS.Operations. - - function New_File_Validated (File : File_Type) -- Ensure that a newly - return Boolean is -- created file has - Result : Boolean := False; -- appropriate values. - begin - if (File.Descriptor > System_File.Descriptor) and -- Parent object. - (File.Mode in File_Mode ) -- Parent type. - then - Result := True; - end if; - - return (Result); - - end New_File_Validated; - -------------------------------------------------------------- - procedure Create_File - (Mode : in File_Mode := Active_Mode; -- Parent constant. - File : out File_Type) is -- Parent type. - - New_File : File_Type; - - begin - New_File.Descriptor := Next_Available_File; -- Parent subprogram. - New_File.Mode := Mode; - - if New_File_Validated (File => New_File) then - File := New_File; - end if; - - end Create_File; - -end CA11002_0.CA11002_1; -- Child Package body OS.Operations. - - --=================================================================-- - --- Child library subprogram Convert_File_Mode specification. -procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type. - New_Mode : in File_Mode); -- Parent type. - - - --=================================================================-- -with Report; - --- Child library subprogram Convert_File_Mode body. -procedure CA11002_0.CA11002_2 (File : in out File_Type; - New_Mode : in File_Mode) is -begin - if File.Mode = New_Mode then - raise File_Mode_Error; -- Parent exception. - Report.Failed ("Exception not raised in child unit"); - else - File.Mode := New_Mode; - end if; -end CA11002_0.CA11002_2; - - --=================================================================-- - -with Report; -with CA11002_0.CA11002_1; -- Child package OS.Operations. -with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode, - -- Implicitly with parent, OS. -use CA11002_0; -- All user-defined operators directly - -- visible. -procedure CA11002 is -begin - - Report.Test ("CA11002", "Check that a public child can utilize its " & - "parent unit's visible definitions"); - - File_Creation: -- This processing block will demonstrate - -- use of child package subroutine that - -- takes advantage of components declared - -- in the parent package. - declare - User_File : File_Type; - begin - CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode - -- parameter used in - -- this call. - if (User_File.Descriptor = System_File.Descriptor) or - (User_File.Mode = Default_Mode) - then - Report.Failed ("Incorrect file creation"); - end if; - - end File_Creation; - - -------------------------------------------------------------- - File_Mode_Conversion: -- This processing block will demonstrate - -- the occurrence of a (forced) exception - -- being raised in a child subprogram, and - -- propagated to the caller. The exception - -- is handled, and the child subprogram - -- is called again, this time to perform - -- without error. - declare - procedure Convert_File_Mode (File : in out File_Type; - New_Mode : in File_Mode) renames CA11002_0.CA11002_2; - New_File : File_Type; - begin -- Raise an exception with this - -- illegal conversion operation - -- (attempt to change to current mode). - - Convert_File_Mode (File => New_File, - New_Mode => Default_Mode); - Report.Failed ("Exception should have been raised in child unit"); - - exception - when File_Mode_Error => -- Perform the conversion again, this - -- time with a different file mode. - - Convert_File_Mode (File => New_File, - New_Mode => CA11002_0.Active_Mode); - - if New_File.Mode /= Read_Write then - Report.Failed ("Incorrect result from mode conversion operation"); - end if; - - when others => - Report.Failed ("Unexpected exception raised in File_Mode_Conversion"); - - end File_Mode_Conversion; - - Report.Result; - -end CA11002; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11003.a b/gcc/testsuite/ada/acats/tests/ca/ca11003.a deleted file mode 100644 index ff894250ed0..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11003.a +++ /dev/null @@ -1,290 +0,0 @@ --- CA11003.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 public grandchild can utilize its ancestor unit's visible --- definitions. --- --- TEST DESCRIPTION: --- Declare a public package, public child package, and public --- grandchild package and library unit function. Within the --- grandchild package and function, make use of components that are --- declared in the ancestor packages, both parent and grandparent. --- --- Use the following ancestral components in the grandchildren library --- units: --- Grandparent Parent --- Type X X --- Constant X X --- Object X X --- Subprogram X X --- Exception X X --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Dec 94 SAIC Modified procedure Create_File --- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - -package CA11003_0 is -- Package OS - - type File_Descriptor is new Integer; - type File_Mode is (Read_Only, Write_Only, Read_Write); - - Null_File : constant File_Descriptor := 0; - Default_Mode : constant File_Mode := Read_Only; - File_Data_Error : exception; - - type File_Type is tagged - record - Descriptor : File_Descriptor := Null_File; - Mode : File_Mode := Read_Write; - end record; - - System_File : File_Type; - - function Next_Available_File return File_Descriptor; - - procedure Reclaim_File_Descriptor; - -end CA11003_0; -- Package OS - - --=================================================================-- - -package body CA11003_0 is -- Package body OS - - File_Count : Integer := 0; - - function Next_Available_File return File_Descriptor is - begin - File_Count := File_Count + 1; - return (File_Descriptor(File_Count)); - end Next_Available_File; - -------------------------------------------------- - procedure Reclaim_File_Descriptor is - begin - null; -- Dummy processing unit. - end Reclaim_File_Descriptor; - -end CA11003_0; -- Package body OS - - --=================================================================-- - -package CA11003_0.CA11003_1 is -- Child package OS.Operations - - subtype File_Length_Type is Integer range 0 .. 1000; - Min_File_Size : File_Length_Type := File_Length_Type'First; - Max_File_Size : File_Length_Type := File_Length_Type'Last; - - File_Duplication_Error : exception; - - type Extended_File_Type is new File_Type with private; - - procedure Create_File (Mode : in File_Mode; - File : out Extended_File_Type); - - procedure Duplicate_File (Original : in Extended_File_Type; - Duplicate : out Extended_File_Type); - -private - type Extended_File_Type is new File_Type with - record - Blocks : File_Length_Type := Min_File_Size; - end record; - - System_Extended_File : Extended_File_Type; - -end CA11003_0.CA11003_1; -- Child Package OS.Operations - - --=================================================================-- - -package body CA11003_0.CA11003_1 is -- Child package body OS.Operations - - procedure Create_File - (Mode : in File_Mode; - File : out Extended_File_Type) is - begin - File.Descriptor := Next_Available_File; -- Parent subprogram. - File.Mode := Default_Mode; -- Parent constant. - File.Blocks := Min_File_Size; - end Create_File; - -------------------------------------------------- - procedure Duplicate_File (Original : in Extended_File_Type; - Duplicate : out Extended_File_Type) is - begin - Duplicate.Descriptor := Next_Available_File; -- Parent subprogram. - Duplicate.Mode := Original.Mode; - Duplicate.Blocks := Original.Blocks; - end Duplicate_File; - -end CA11003_0.CA11003_1; -- Child package body OS.Operations - - --=================================================================-- - --- This package contains menu selectable operations for manipulating files. --- This abstraction builds on the capabilities available from ancestor --- packages. - -package CA11003_0.CA11003_1.CA11003_2 is - - procedure News (Mode : in File_Mode; - File : out Extended_File_Type); - - procedure Copy (Original : in Extended_File_Type; - Duplicate : out Extended_File_Type); - - procedure Delete (File : in Extended_File_Type); - -end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu - - --=================================================================-- - --- Grandchild subprogram Validate -function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type) - return Boolean; - - --=================================================================-- - --- Grandchild subprogram Validate -function CA11003_0.CA11003_1.CA11003_3 - (File : in Extended_File_Type) -- Parent type. - return Boolean is - - function New_File_Validated (File : Extended_File_Type) - return Boolean is - begin - if (File.Descriptor > System_File.Descriptor) and -- Grandparent - (File.Mode in File_Mode ) and -- object and type - not ((File.Blocks < System_Extended_File.Blocks) or - (File.Blocks > Max_File_Size)) -- Parent object - then -- and constant. - return True; - else - return False; - end if; - end New_File_Validated; - -begin - return (New_File_Validated (File)) and - (File.Descriptor /= Null_File); -- Grandparent constant. - -end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate - - --=================================================================-- - -with CA11003_0.CA11003_1.CA11003_3; - -- Grandchild package body OS.Operations.Menu -package body CA11003_0.CA11003_1.CA11003_2 is - - procedure News (Mode : in File_Mode; - File : out Extended_File_Type) is -- Parent type. - begin - Create_File (Mode, File); -- Parent subprogram. - if not CA11003_0.CA11003_1.CA11003_3 (File) then - raise File_Data_Error; -- Grandparent exception. - end if; - end News; - -------------------------------------------------- - procedure Copy (Original : in Extended_File_Type; - Duplicate : out Extended_File_Type) is - begin - Duplicate_File (Original, Duplicate); -- Parent subprogram. - - if Original.Descriptor = Duplicate.Descriptor then - raise File_Duplication_Error; -- Parent exception. - end if; - - end Copy; - -------------------------------------------------- - procedure Delete (File : in Extended_File_Type) is - begin - Reclaim_File_Descriptor; -- Grandparent - end Delete; -- subprogram. - -end CA11003_0.CA11003_1.CA11003_2; - - --=================================================================-- - -with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu -with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate -with Report; - -procedure CA11003 is - - package Menu renames CA11003_0.CA11003_1.CA11003_2; - -begin - - Report.Test ("CA11003", "Check that a public grandchild can utilize " & - "its ancestor unit's visible definitions"); - - File_Processing: -- Validate all of the capabilities contained in - -- the Menu package by exercising them on specific - -- files. This will demonstrate the use of child - -- and grandchild functionality based on components - -- that have been declared in the - -- parent/grandparent package. - declare - - function Validate (File : CA11003_0.CA11003_1.Extended_File_Type) - return Boolean renames CA11003_0.CA11003_1.CA11003_3; - - MacWrite_File, - Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type; - MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write; - - begin - - Menu.News (MacWrite_File_Mode, MacWrite_File); - - if not Validate (MacWrite_File) then - Report.Failed ("Incorrect initialization of files"); - end if; - - Menu.Copy (MacWrite_File, Backup_Copy); - - if not (Validate (MacWrite_File) and - Validate (Backup_Copy)) - then - Report.Failed ("Incorrect duplication of files"); - end if; - - Menu.Delete (Backup_Copy); - - exception - when CA11003_0.File_Data_Error => - Report.Failed ("Exception raised during file validation"); - when CA11003_0.CA11003_1.File_Duplication_Error => - Report.Failed ("Exception raised during file duplication"); - when others => - Report.Failed ("Unexpected exception in test procedure"); - - end File_Processing; - - Report.Result; - -end CA11003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110040.a b/gcc/testsuite/ada/acats/tests/ca/ca110040.a deleted file mode 100644 index 72cc6682eab..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca110040.a +++ /dev/null @@ -1,90 +0,0 @@ --- CA110040.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: --- See CA110042.AM --- --- TEST DESCRIPTION: --- See CA110042.AM --- --- TEST FILES: --- The following files comprise this test: --- --- => CA110040.A --- CA110041.A --- CA110042.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma --- Elaborate_Body. --- ---! - -package CA110040 is -- Package Computer_System. - pragma Elaborate_Body (CA110040); - - -- Types. - type ID_Type is range 1 .. 4; - type System_Account_Capacity is new ID_Type; - - type Account is tagged - record - User_ID : ID_Type; - end record; - - -- Constants. - Maximum_System_Accounts : constant System_Account_Capacity := - System_Account_Capacity'Last; - - System_Administrator : constant ID_Type := - ID_Type (System_Account_Capacity'First); - - Administrator_Account : constant Account := - (User_ID => System_Administrator); - - -- Objects. - Total_Accounts : System_Account_Capacity := 1; - - -- Exceptions. - Illegal_Account : exception; - Account_Limit_Exceeded : exception; - - -- Subprograms. - function Next_Available_ID return ID_Type; - -end CA110040; -- Package Computer_System. - - --=================================================================-- - -package body CA110040 is -- Package body Computer_System. - - function Next_Available_ID return ID_Type is - begin - Total_Accounts := Total_Accounts + 1; - return (ID_Type(Total_Accounts)); - end Next_Available_ID; - -end CA110040; -- Package body Computer_System. diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110041.a b/gcc/testsuite/ada/acats/tests/ca/ca110041.a deleted file mode 100644 index 954df7f4d68..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca110041.a +++ /dev/null @@ -1,118 +0,0 @@ --- CA110041.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: --- See CA110042.AM --- --- TEST DESCRIPTION: --- See CA110042.AM --- --- TEST FILES: --- The following files comprise this test: --- --- CA110040.A --- => CA110041.A --- CA110042.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -package CA110040.CA110041 is -- Child Package Computer_System.Manager - - type User_Account is new Account with private; - - procedure Initialize_User_Account (Acct : out User_Account); - -private - --- The private portion of this spec demonstrates that components contained --- in the visible part of the parent are directly visible in the private --- part of a public child. - - type Account_Access_Type is (None, Guest, User, System); - - type User_Account is new Account with -- Parent type. - record - Privilege : Account_Access_Type := None; - end record; - - System_Account : User_Account := - (User_ID => Administrator_Account.User_ID, -- Parent constant. - Privilege => System); -- User_ID has been - -- set to 1. - Auditor_Account : User_Account := - (User_ID => Next_Available_ID, -- Parent function. - Privilege => System); -- User_ID has been - -- set to 2. - Total_Authorized_Accounts : System_Account_Capacity - renames Total_Accounts; -- Parent object. - - Unauthorized_Account : exception - renames Illegal_Account; -- Parent exception - -end CA110040.CA110041; -- Child Package Computer_System.Manager - - --=================================================================-- - - -- Child Package body Computer_System.Manager -package body CA110040.CA110041 is - - function Account_Limit_Reached return Boolean is - begin - if Total_Authorized_Accounts = Maximum_System_Accounts then - return (True); - else - return (False); - end if; - end Account_Limit_Reached; - --------------------------------------------------------------- - function Valid_Account (Acct : User_Account) return Boolean is - Result : Boolean := False; - begin - if (Acct.User_ID /= System_Account.User_ID) and - (Acct.User_ID /= Auditor_Account.User_ID) - then - Result := True; - end if; - return (Result); - end Valid_Account; - --------------------------------------------------------------- - procedure Initialize_User_Account (Acct : out User_Account) is - begin - if Account_Limit_Reached then - raise Account_Limit_Exceeded; - else - Acct.User_ID := Next_Available_ID; - Acct.Privilege := User; - end if; - if not Valid_Account (Acct) then - raise Unauthorized_Account; - end if; - end Initialize_User_Account; - -end CA110040.CA110041; -- Child Package body Computer_System.Manager diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110050.a b/gcc/testsuite/ada/acats/tests/ca/ca110050.a deleted file mode 100644 index 88455762c96..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca110050.a +++ /dev/null @@ -1,99 +0,0 @@ --- CA110050.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: --- See CA110051.AM --- --- TEST DESCRIPTION: --- See CA110051.AM --- --- TEST FILES: --- The test consists of the following files: --- --- => CA110050.A --- CA110051.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Dec 94 SAIC Modified discriminant type --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma --- Elaborate_Body. --- ---! - -package CA110050_0 is -- Package Messages. - pragma Elaborate_Body (CA110050_0); - - type Descriptor is new Integer; - - Null_Descriptor_Value : constant Descriptor := 0; - Null_Message_Descriptor : constant Descriptor := 0; - - type Message_Type is tagged - record - Number : Descriptor := Null_Message_Descriptor; - end record; - - function Next_Available_Message return Descriptor; - -end CA110050_0; -- Package Messages. - - --=================================================================-- - -package body CA110050_0 is -- Package body Messages. - - Message_Count : Integer := 0; - - function Next_Available_Message return Descriptor is - begin - Message_Count := Message_Count + 5; - return (Descriptor(Message_Count)); - end Next_Available_Message; - -end CA110050_0; -- Package body Messages. - - --=================================================================-- - -package CA110050_0.CA110050_1 is -- Child package Messages.Text - - subtype Default_Length is Natural range 0 .. 80; - - type Text_Type (Max_Length : Default_Length := 0) is - record - Length : Default_Length := Max_Length; - Text_Field : String (1 .. Max_Length); - end record; - - type Text_Message_Type is new Message_Type with - record - Text : Text_Type; - end record; - - Null_Text : Text_Type (0); -- Null range for - -- Text_Field component. - -end CA110050_0.CA110050_1; -- Child package Messages.Text --- --- No package body needed for this specification. diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11006.a b/gcc/testsuite/ada/acats/tests/ca/ca11006.a deleted file mode 100644 index 5cd21fe1f15..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11006.a +++ /dev/null @@ -1,211 +0,0 @@ --- CA11006.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 the private part of a child library unit can utilize --- its parent unit's private definition. --- --- TEST DESCRIPTION: --- Declare a package and public child package, both with private --- parts. The child package will have a private extension of a type --- declared in the parent's private part. In addition, the private --- part of the child package specification will make use of some of --- the components declared in the private part of the parent. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - -package CA11006_0 is -- Package File_Package - - type File_Descriptor is private; - type File_Mode is (Read_Only, Write_Only, Read_Write); - type File_Type is tagged private; - - function Next_Available_File return File_Descriptor; - -private - - type File_Measure is range 0 .. 1000; - type File_Descriptor is new Integer; - - Null_File : constant File_Descriptor := 0; - Default_Mode : constant File_Mode := Read_Write; - - type File_Type is tagged - record - Descriptor : File_Descriptor := Null_File; - Mode : File_Mode := Default_Mode; - end record; - - System_File : File_Type; - -end CA11006_0; -- Package File_Package - - --=================================================================-- - -package body CA11006_0 is -- Package File_Package - - File_Count : Integer := 0; - - function Next_Available_File return File_Descriptor is - begin - File_Count := File_Count + 1; - return File_Descriptor (File_Count); - end Next_Available_File; - -end CA11006_0; -- Package File_Package - - --=================================================================-- - -package CA11006_0.CA11006_1 is -- Child package File_Package.Operations - - type File_Length_Type is private; - type Extended_File_Type is new File_Type with private; - - System_Extended_File : constant Extended_File_Type; - - procedure Create_File (Mode : in File_Mode; - File : out Extended_File_Type); - - procedure Compress_File (Original : in Extended_File_Type; - Compressed_File : out Extended_File_Type); - - function Validate (File : in Extended_File_Type) return Boolean; - - function Validate_Compression (File : in Extended_File_Type) - return Boolean; - -- These two validation functions provide - -- the capability to check the private - -- components defined in the parent and - -- child packages from within the client - -- program. -private - - type File_Length_Type is new File_Measure; -- Parent private type. - - Min_File_Size : File_Length_Type := File_Length_Type'First; - Max_File_Size : File_Length_Type := File_Length_Type'Last; - - type Extended_File_Type is new File_Type with -- Parent type. - record - Blocks : File_Length_Type := Min_File_Size; - end record; - - System_Extended_File : constant Extended_File_Type := - (Descriptor => System_File.Descriptor, -- Parent private object. - Mode => Read_Only, -- Parent enumeration literal. - Blocks => Min_File_Size); - - -end CA11006_0.CA11006_1; -- Child Package File_Package.Operations - - --=================================================================-- - - -- Child package body File_Package.Operations -package body CA11006_0.CA11006_1 is - - procedure Create_File - (Mode : in File_Mode; - File : out Extended_File_Type) is - begin - File.Descriptor := Next_Available_File; -- Parent subprogram. - File.Mode := Default_Mode; -- Parent private constant. - File.Blocks := Max_File_Size; - end Create_File; - ------------------------------------------------------------------------ - procedure Compress_File (Original : in Extended_File_Type; - Compressed_File : out Extended_File_Type) is - begin - Compressed_File.Descriptor := Next_Available_File; - Compressed_File.Mode := Read_Only; - Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file - end Compress_File; -- compression. - ------------------------------------------------------------------------ - function Validate (File : in Extended_File_Type) return Boolean is - begin - if ((File.Descriptor /= System_Extended_File.Descriptor) and - (File.Mode = Read_Write) and - (File.Blocks = Max_File_Size)) then - return True; - else - return False; - end if; - end Validate; - ------------------------------------------------------------------------ - function Validate_Compression (File : in Extended_File_Type) - return Boolean is - begin - if ((File.Descriptor /= System_File.Descriptor) and - (File.Mode = Read_Only) and - (File.Blocks = Max_File_Size/2)) then - return True; - else - return False; - end if; - end Validate_Compression; - -end CA11006_0.CA11006_1; -- Child package body File_Package.Operations - - --=================================================================-- - -with CA11006_0.CA11006_1; -- with Child package File_Package.Operations -with Report; - -procedure CA11006 is - - package File renames CA11006_0; - package File_Ops renames CA11006_0.CA11006_1; - - Validation_File_Mode : File.File_Mode := File.Read_Only; - Validation_File, - Storage_Copy : File_Ops.Extended_File_Type; - -begin - - Report.Test ("CA11006", "Check that the private part of a child " & - "library unit can utilize its parent " & - "unit's private definition"); - - File_Ops.Create_File (Validation_File_Mode, Validation_File); - - if not File_Ops.Validate (Validation_File) then - Report.Failed ("Incorrect initialization of file"); - end if; - - File_Ops.Compress_File (Validation_File, Storage_Copy); - - if not (File_Ops.Validate (Validation_File) and - File_Ops.Validate_Compression (Storage_Copy)) - then - Report.Failed ("Incorrect compression of file"); - end if; - - Report.Result; - -end CA11006; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11007.a b/gcc/testsuite/ada/acats/tests/ca/ca11007.a deleted file mode 100644 index c4a6789ab8e..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11007.a +++ /dev/null @@ -1,228 +0,0 @@ --- CA11007.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 the private part of a grandchild library unit can --- utilize its grandparent unit's private definition. --- --- TEST DESCRIPTION: --- Declare a package, child package, and grandchild package, all --- with private parts in their specifications. --- --- The private part of the grandchild package will make use of components --- that have been declared in the private part of the grandparent --- specification. --- --- The child package demonstrates the extension of a parent file type --- into an abstraction of an analog file structure. The grandchild package --- extends the grandparent file type into an abstraction of a digital --- file structure, and provides conversion capability to/from the parent --- analog file structure. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CA11007_0 is -- Package File_Package - - type File_Descriptor is private; - type File_Type is tagged private; - - function Next_Available_File return File_Descriptor; - -private - - type File_Measure_Type is range 0 .. 1000; - type File_Descriptor is new Integer; - - Null_Measure : constant File_Measure_Type := File_Measure_Type'First; - Null_File : constant File_Descriptor := 0; - - type File_Type is tagged - record - Descriptor : File_Descriptor := Null_File; - end record; - -end CA11007_0; -- Package File_Package - - --=================================================================-- - -package body CA11007_0 is -- Package body File_Package - - File_Count : Integer := 0; - - function Next_Available_File return File_Descriptor is - begin - File_Count := File_Count + 1; - return File_Descriptor (File_Count); - end Next_Available_File; - -end CA11007_0; -- Package body File_Package - - --=================================================================-- - -package CA11007_0.CA11007_1 is -- Child package Analog - - type Analog_File_Type is new File_Type with private; - -private - - type Wavelength_Type is new File_Measure_Type; - - Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First; - - type Analog_File_Type is new File_Type with -- Parent type. - record - Wavelength : Wavelength_Type := Min_Wavelength; - end record; - -end CA11007_0.CA11007_1; -- Child package Analog - - --=================================================================-- - -package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital - - type Digital_File_Type is new File_Type with private; - - procedure Recording (File : out Digital_File_Type); - - procedure Convert (From : in Analog_File_Type; - To : out Digital_File_Type); - - function Validate (File : in Digital_File_Type) return Boolean; - function Valid_Conversion (To : Digital_File_Type) return Boolean; - function Valid_Initial (From : Analog_File_Type) return Boolean; - -private - - type Track_Type is new File_Measure_Type; -- Grandparent type. - - Min_Tracks : constant Track_Type := - Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private - Max_Tracks : constant Track_Type := -- constant. - Track_Type (Null_Measure) + Track_Type'Last; - - type Digital_File_Type is new File_Type with -- Grandparent type. - record - Tracks : Track_Type := Min_Tracks; - end record; - -end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital - - --=================================================================-- - - -- Grandchild package body Digital -package body CA11007_0.CA11007_1.CA11007_2 is - - procedure Recording (File : out Digital_File_Type) is - begin - File.Descriptor := Next_Available_File; -- Assign new file descriptor. - File.Tracks := Max_Tracks; -- Change initial value. - end Recording; - -------------------------------------------------------------------------- - procedure Convert (From : in Analog_File_Type; - To : out Digital_File_Type) is - begin - To.Descriptor := From.Descriptor + 100; -- Dummy conversion. - To.Tracks := Track_Type (From.Wavelength) / 2; - end Convert; - -------------------------------------------------------------------------- - function Validate (File : in Digital_File_Type) return Boolean is - Result : Boolean := False; - begin - if not (File.Tracks /= Max_Tracks) then - Result := True; - end if; - return Result; - end Validate; - -------------------------------------------------------------------------- - function Valid_Conversion (To : Digital_File_Type) return Boolean is - begin - return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2)); - end Valid_Conversion; - -------------------------------------------------------------------------- - function Valid_Initial (From : Analog_File_Type) return Boolean is - begin - return (From.Wavelength = Min_Wavelength); -- Validate initial - end Valid_Initial; -- conditions. - -end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital - - --=================================================================-- - -with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital -with Report; - -procedure CA11007 is - - package Analog renames CA11007_0.CA11007_1; - package Digital renames CA11007_0.CA11007_1.CA11007_2; - - Original_Digital_File, - Converted_Digital_File : Digital.Digital_File_Type; - - Original_Analog_File : Analog.Analog_File_Type; - -begin - - -- This code demonstrates how private extensions could be utilized - -- in child packages to allow for recording on different media. - -- The processing contained in the procedures and functions is - -- "dummy" processing, not intended to perform actual recording, - -- conversion, or validation operations, but simply to demonstrate - -- this type of structural decomposition as a possible solution to - -- a user's design problem. - - Report.Test ("CA11007", "Check that the private part of a grandchild " & - "library unit can utilize its grandparent " & - "unit's private definition"); - - if not Digital.Valid_Initial (Original_Analog_File) - then - Report.Failed ("Incorrect initialization of Analog File"); - end if; - - --- - - Digital.Convert (From => Original_Analog_File, -- Convert file to - To => Converted_Digital_File); -- digital format. - - if not Digital.Valid_Conversion (To => Converted_Digital_File) then - Report.Failed ("Incorrect conversion of analog file"); - end if; - - --- - - Digital.Recording (Original_Digital_File); -- Create file in - -- digital format. - if not Digital.Validate (Original_Digital_File) then - Report.Failed ("Incorrect recording of digital file"); - end if; - - Report.Result; - -end CA11007; 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; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11009.a b/gcc/testsuite/ada/acats/tests/ca/ca11009.a deleted file mode 100644 index 84d7dc2b3a7..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11009.a +++ /dev/null @@ -1,246 +0,0 @@ --- CA11009.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 the parent unit of its parent unit. --- --- TEST DESCRIPTION: --- Declare a parent package containing types and objects used by the --- system. Declare a public child package that provides a visible --- interface to the system functionality. --- Declare a private grandchild package that uses the visible grandparent --- components to provide the actual functionality to the system. --- --- The public child (parent of the private grandchild) uses the --- functionality of its private child (grandchild package) to provide --- the visible interface to operations of the system. --- --- The test itself will utilize the visible interface provided in the --- public child package to demonstrate a possible structure for --- file management. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body. --- ---! - -package CA11009_0 is -- Package OS. - pragma Elaborate_Body (CA11009_0); - - 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 := 10; - An_Ada_File_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; - -end CA11009_0; -- Package OS. - - --=================================================================-- - -package body CA11009_0 is -- Package body OS. - - function Get_File_Name return File_Name_Type is - begin - return (An_Ada_File_Name); -- Processing would be replace by a user - -- prompt in a functioning system. - end Get_File_Name; - -end CA11009_0; -- Package body OS. - - --=================================================================-- - -package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager - - -- This package simulates a visible interface for the Operating System. - -- The actual processing performed by this routine is encapsulated - -- in the routines of private child package Internals, which is "withed" - -- by the body of this package. - - procedure Create_File (Mode : in File_Mode_Type; - File_Key : out File_Descriptor_Type); - -end CA11009_0.CA11009_1; -- Child Package OS.File_Manager - - --=================================================================-- - --- Subprogram that performs the actual file operation is contained in a --- private package so that it is not accessible to any client, and can be --- modified/extended without requiring recompilation of the clients of the --- parent (since this package is "withed" by the parent body only.) - - - -- Grandchild Package OS.File_Manager.Internals -private package CA11009_0.CA11009_1.CA11009_2 is - - Initial_Permission : constant Permission_Type := User; -- Grandparent - Initial_Status : constant File_Status_Type := Open; -- literals. - Initial_Filename : constant File_Name_Type := -- Grandparent type. - Get_File_Name; -- Grandparent function. - - function Create (Mode : File_Mode_Type) - return File_Descriptor_Type; -- Grandparent type. - -end CA11009_0.CA11009_1.CA11009_2; - -- Grandchild Package OS.File_Manager.Internals - - --=================================================================-- - - -- Grandchild Package body OS.File_Manager.Internals -package body CA11009_0.CA11009_1.CA11009_2 is - - function Next_Available_File return File_Descriptor_Type is - begin - File_Counter := File_Counter + 1; -- Grandparent object. - return (File_Descriptor_Type(File_Counter)); - end Next_Available_File; - ------------------------------------------------------------------------- - function Create (Mode : File_Mode_Type) -- Grandparent literal. - return File_Descriptor_Type is - Number : File_Descriptor_Type; -- Grandparent type. - begin - Number := Next_Available_File; - File_Table(Number).Descriptor := Number; -- Grandparent object. - File_Table(Number).Name := Initial_Filename; - File_Table(Number).Mode := Mode; -- Parameter. - File_Table(Number).Acct_Access := Initial_Permission; - File_Table(Number).Current_Status := Initial_Status; - return (Number); - end Create; - -end CA11009_0.CA11009_1.CA11009_2; - -- Grandchild Package body OS.File_Manager.Internals - - --=================================================================-- - - -- "With" of a child package - -- by the parent body. -with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals - -package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager - - package Internal renames CA11009_0.CA11009_1.CA11009_2; - - -- These subprograms utilize calls to subprograms contained in a private - -- sibling to perform the actual processing. - - procedure Create_File (Mode : in File_Mode_Type; - File_Key : out File_Descriptor_Type) is - begin - File_Key := Internal.Create (Mode); - end Create_File; - -end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager - - --=================================================================-- - -with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager -with Report; - -procedure CA11009 is - - package OS renames CA11009_0; - use OS; - package File_Manager renames CA11009_0.CA11009_1; - - Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor; - New_Mode : File_Mode_Type := Read_Write; - -begin - - -- This test indicates one approach to file management. - -- It is not intended to demonstrate full functionality, but rather - -- that the use of a private child package could provide a solution - -- to this type of situation. - - Report.Test ("CA11009", "Check that a private child package can use " & - "entities declared in the visible part of the " & - "parent unit 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 (not (Data_Base_File_Key = Default_Descriptor)) and then - (((not (File_Table(1).Name = Default_Filename)) or - (File_Table(1).Descriptor /= Default_Descriptor)) or else - ((File_Table(1).Acct_Access /= Default_Permission) or - (not (File_Table(1).Mode = Default_Mode)) or - (File_Table(1).Current_Status /= Default_Status))) - then - Report.Failed ("Initial condition failure"); - end if; - - -- Create/initialize file using the capability provided by the visible - -- interface to the operating system, OS.File_Manager. The actual - -- processing routine is contained in the private grandchild package - -- Internals, which utilize the components from the grandparent package. - - File_Manager.Create_File (New_Mode, Data_Base_File_Key); - - -- Verify that the initial conditions of the file table component have - -- been properly modified by the initialization function. - - if not ((File_Table(1).Descriptor = Data_Base_File_Key) 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 - Report.Failed ("File creation failure"); - end if; - - Report.Result; - -end CA11009; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11010.a b/gcc/testsuite/ada/acats/tests/ca/ca11010.a deleted file mode 100644 index b13efd79851..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11010.a +++ /dev/null @@ -1,254 +0,0 @@ --- 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; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11011.a b/gcc/testsuite/ada/acats/tests/ca/ca11011.a deleted file mode 100644 index a75261dd840..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11011.a +++ /dev/null @@ -1,271 +0,0 @@ --- CA11011.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 the parent unit of its parent unit. --- --- TEST DESCRIPTION: --- Declare a parent package containing private types and objects --- used by the system. Declare a public child package that --- provides a visible interface to the system functionality. --- Declare a private grandchild package that uses the visible grandparent --- components to provide the actual functionality to the system. --- --- The public child (parent of the private grandchild) uses the --- functionality of its private child (grandchild package) to provide --- the visible interface to operations of the system. --- --- The test itself will utilize the visible interface provided in the --- public child package to demonstrate a possible solution to file --- management. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CA11011_0 is -- Package OS. - - type File_Descriptor_Type is private; - - Default_Descriptor : constant File_Descriptor_Type; - First_File : constant File_Descriptor_Type; - - procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; - Status : out Boolean); - - function Final_Conditions_Valid (Key : File_Descriptor_Type) - 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; - First_File : constant File_Descriptor_Type := 1; - 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 := " "; - - Init_Permission : constant Permission_Type := User; - Init_Mode : constant File_Mode_Type := Read_Write; - Init_Status : constant File_Status_Type := Open; - An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; - - Max_Files : constant File_Descriptor_Type := 10; - - 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 CA11011_0; -- Package OS. - - --=================================================================-- - -package body CA11011_0 is -- Package body OS. - - function Get_File_Name return File_Name_Type is - begin - return (An_Ada_File_Name); - end Get_File_Name; - --------------------------------------------------------------------- - procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; - Status : out Boolean) is - begin - Status := False; - if (File_Table(Key).Descriptor = Default_Descriptor) and then - (File_Table(Key).Name = Default_Filename) and then - (File_Table(Key).Acct_Access = Default_Permission) and then - (File_Table(Key).Mode = Default_Mode) and then - (File_Table(Key).Current_Status = Default_Status) - then - Status := True; - end if; - end Verify_Initial_Conditions; - --------------------------------------------------------------------- - function Final_Conditions_Valid (Key : File_Descriptor_Type) - return Boolean is - begin - if ((File_Table(Key).Descriptor = First_File) and then - (File_Table(Key).Name = An_Ada_File_Name) and then - (File_Table(Key).Acct_Access = Init_Permission) and then - not ((File_Table(Key).Mode = Default_Mode) or else - (File_Table(Key).Current_Status = Default_Status))) - then - return (True); - else - return (False); - end if; - end Final_Conditions_Valid; - -end CA11011_0; -- Package body OS. - - --=================================================================-- - -package CA11011_0.CA11011_1 is -- Package OS.File_Manager - - procedure Create_File (File_Key : in File_Descriptor_Type); - -end CA11011_0.CA11011_1; -- Package OS.File_Manager - - --=================================================================-- - --- The Subprogram that performs the actual file operations is contained in a --- private package so that it is not accessible to any client. --- Default parameters are used in most cases in the subprogram calls, since --- the caller does not have visibility to these private types. - - -- Package OS.File_Manager.Internals -private package CA11011_0.CA11011_1.CA11011_2 is - - Private_File_Counter : Integer renames File_Counter; -- Grandparent - -- object. - procedure Create - (Key : in File_Descriptor_Type; - File_Name : in File_Name_Type := Get_File_Name; -- Grandparent - -- prvt type, - -- prvt functn. - File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent - -- prvt type, - -- prvt const. - File_Access : in Permission_Type := Init_Permission; -- Grandparent - -- prvt type, - -- prvt const. - File_Status : in File_Status_Type := Init_Status); -- Grandparent - -- prvt type, - -- prvt const. - -end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals - - --=================================================================-- - - -- Package Body OS.File_Manager.Internals -package body CA11011_0.CA11011_1.CA11011_2 is - - procedure Create - (Key : in File_Descriptor_Type; - File_Name : in File_Name_Type := Get_File_Name; - File_Mode : in File_Mode_Type := Init_Mode; - File_Access : in Permission_Type := Init_Permission; - File_Status : in File_Status_Type := Init_Status) is - begin - Private_File_Counter := Private_File_Counter + 1; - File_Table(Key).Descriptor := Key; -- Grandparent object. - File_Table(Key).Name := File_Name; - File_Table(Key).Mode := File_Mode; - File_Table(Key).Acct_Access := File_Access; - File_Table(Key).Current_Status := File_Status; - end Create; - -end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals - - --=================================================================-- - -with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals - -package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager - - package Internal renames CA11011_0.CA11011_1.CA11011_2; - - -- This subprogram utilizes a call to a subprogram contained in a private - -- child to perform the actual processing. - - procedure Create_File (File_Key : in File_Descriptor_Type) is - begin - Internal.Create (Key => File_Key); -- Other parameters are defaults, - -- since they are of private types - -- from the parent package. - -- File_Descriptor_Type is private, - -- but declared in visible part of - -- parent spec. - end Create_File; - -end CA11011_0.CA11011_1; -- Package body OS.File_Manager - - --=================================================================-- - -with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager -with Report; - -procedure CA11011 is - - package OS renames CA11011_0; - package File_Manager renames CA11011_0.CA11011_1; - - Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File; - TC_Status : Boolean := False; - -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 typical user situation. - - Report.Test ("CA11011", "Check that a private child package can use " & - "entities declared in the private part of the " & - "parent unit of its parent unit"); - - OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status); - - if not TC_Status then - Report.Failed ("Initial condition failure"); - end if; - - -- Perform file initializations. - - File_Manager.Create_File (File_Key => Data_Base_File_Key); - - TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key); - - if not TC_Status then - Report.Failed ("Bad status return from Create_File"); - end if; - - Report.Result; - -end CA11011; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11012.a b/gcc/testsuite/ada/acats/tests/ca/ca11012.a deleted file mode 100644 index 071b8f8134b..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11012.a +++ /dev/null @@ -1,259 +0,0 @@ --- CA11012.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 child package of a library level instantiation --- of a generic can be the instantiation of a child package of --- the generic. Check that the child instance can use its parent's --- declarations and operations, including a formal type of the parent. --- --- TEST DESCRIPTION: --- Declare a generic package which simulates an integer complex --- abstraction. Declare a generic child package of this package --- which defines additional complex operations. --- --- Instantiate the first generic package, then instantiate the child --- generic package as a child unit of the first instance. In the main --- program, check that the operations in both instances perform as --- expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Dec 94 SAIC Corrected visibility errors for literals --- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3 ---! - -generic -- Complex number abstraction. - type Int_Type is range <>; - -package CA11012_0 is - - -- Simulate a generic complex number support package. Complex numbers - -- are treated as coordinates in the Cartesian plane. - - type Complex_Type is private; - - Zero : constant Complex_Type; -- Real number (0,0). - - function Complex (Real, Imag : Int_Type) -- Create a complex - return Complex_Type; -- number. - - function "-" (Right : Complex_Type) -- Invert a complex - return Complex_Type; -- number. - - function "+" (Left, Right : Complex_Type) -- Add two complex - return Complex_Type; -- numbers. - -private - type Complex_Type is record - Real : Int_Type; - Imag : Int_Type; - end record; - - Zero : constant Complex_Type := (Real => 0, Imag => 0); - -end CA11012_0; - - --==================================================================-- - -package body CA11012_0 is - - function Complex (Real, Imag : Int_Type) return Complex_Type is - begin - return (Real, Imag); - end Complex; - --------------------------------------------------------------- - function "-" (Right : Complex_Type) return Complex_Type is - begin - return (-Right.Real, -Right.Imag); - end "-"; - --------------------------------------------------------------- - function "+" (Left, Right : Complex_Type) return Complex_Type is - begin - return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); - end "+"; - -end CA11012_0; - - --==================================================================-- - --- Generic child of complex number package. Child must be generic since --- parent is generic. - -generic -- Complex additional operations - -package CA11012_0.CA11012_1 is - - -- More operations on complex number. This child adds a layer of - -- functionality to the parent generic. - - function Real_Part (Complex_No : Complex_Type) - return Int_Type; - - function Imag_Part (Complex_No : Complex_Type) - return Int_Type; - - function "*" (Factor : Int_Type; - C : Complex_Type) return Complex_Type; - - function Vector_Magnitude (Complex_No : Complex_Type) - return Int_Type; - -end CA11012_0.CA11012_1; - - --==================================================================-- - -package body CA11012_0.CA11012_1 is - - function Real_Part (Complex_No : Complex_Type) return Int_Type is - begin - return (Complex_No.Real); - end Real_Part; - --------------------------------------------------------------- - function Imag_Part (Complex_No : Complex_Type) return Int_Type is - begin - return (Complex_No.Imag); - end Imag_Part; - --------------------------------------------------------------- - function "*" (Factor : Int_Type; - C : Complex_Type) return Complex_Type is - Result : Complex_Type := Zero; -- Zero is declared in parent, - -- Complex_Number - begin - for I in 1 .. abs (Factor) loop - Result := Result + C; -- Complex_Number "+" - end loop; - - if Factor < 0 then - Result := - Result; -- Complex_Number "-" - end if; - - return Result; - end "*"; - --------------------------------------------------------------- - function Vector_Magnitude (Complex_No : Complex_Type) - return Int_Type is -- Not a real vector magnitude. - begin - return (Complex_No.Real + Complex_No.Imag); - end Vector_Magnitude; - -end CA11012_0.CA11012_1; - - --==================================================================-- - -package CA11012_2 is - - subtype My_Integer is integer range -100 .. 100; - - -- ... Various other types used by the application. - -end CA11012_2; - --- No body for CA11012_2; - - --==================================================================-- - --- Declare instances of the generic complex packages for integer type. --- The instance of the child must itself be declared as a child of the --- instance of the parent. - -with CA11012_0; -- Complex number abstraction -with CA11012_2; -- Package containing integer type -pragma Elaborate (CA11012_0); -package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer); - -with CA11012_0.CA11012_1; -- Complex additional operations -with CA11012_3; -package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1; - - --==================================================================-- - -with CA11012_2; -- Package containing integer type -with CA11012_3.CA11012_4; -- Complex abstraction + additional operations -with Report; - -procedure CA11012 is - - package My_Complex_Pkg renames CA11012_3; - - package My_Complex_Operation renames CA11012_3.CA11012_4; - - use My_Complex_Pkg, -- All user-defined - My_Complex_Operation; -- operators directly - -- visible. - Complex_One, Complex_Two : Complex_Type; - -begin - - Report.Test ("CA11012", "Check that child instance can use its parent's " & - "declarations and operations, including a formal " & - "type of the parent"); - - Correct_Range_Test: - declare - My_Literal : CA11012_2.My_Integer := -3; - - begin - Complex_One := Complex (-4, 7); -- Operation from the generic - -- parent package. - - Complex_Two := My_Literal * Complex_One; -- Operation from the generic - -- child package. - - if Real_Part (Complex_Two) /= 12 -- Operation from the generic - or Imag_Part (Complex_Two) /= -21 -- child package. - then - Report.Failed ("Incorrect results from complex operation"); - end if; - - end Correct_Range_Test; - - --------------------------------------------------------------- - - Out_Of_Range_Test: - declare - My_Vector : CA11012_2.My_Integer; - - begin - Complex_One := Complex (70, 70); -- Operation from the generic - -- parent package. - My_Vector := Vector_Magnitude (Complex_One); - -- Operation from the generic child package. - - Report.Failed ("Exception not raised in child package"); - - exception - when Constraint_Error => - Report.Comment ("Exception is raised as expected"); - - when others => - Report.Failed ("Others exception is raised"); - - end Out_Of_Range_Test; - - Report.Result; - -end CA11012; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11013.a b/gcc/testsuite/ada/acats/tests/ca/ca11013.a deleted file mode 100644 index c7f442788c1..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11013.a +++ /dev/null @@ -1,201 +0,0 @@ --- CA11013.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 child function of a library level instantiation --- of a generic can be the instantiation of a child function of --- the generic. Check that the child instance can use its parent's --- declarations and operations, including a formal subprogram of the --- parent. --- --- TEST DESCRIPTION: --- Declare a generic package which simulates a real complex --- abstraction. Declare a generic child function of this package --- which builds a random complex number. Declare a second --- package which defines a random complex number generator. This --- package provides actual parameters for the generic parent package. --- --- Instantiate the first generic package, then instantiate the child --- generic function as a child unit of the first instance. In the main --- program, check that the operations in both instances perform as --- expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context --- clause of CA11013_3. --- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3 ---! - -generic -- Complex number abstraction. - type Real_Type is digits <>; - with function Random_Generator (Seed : Real_Type) return Real_Type; - -package CA11013_0 is - - -- Simulate a generic complex number support package. Complex numbers - -- are treated as coordinates in the Cartesian plane. - - type Complex_Type is - record - Real : Real_Type; - Imag : Real_Type; - end record; - - function Make (Real, Imag : Real_Type) -- Create a complex - return Complex_Type; -- number. - - procedure Components (Complex_No : in Complex_Type; - Real_Part, Imag_Part : out Real_Type); - -end CA11013_0; - - --==================================================================-- - -package body CA11013_0 is - - function Make (Real, Imag : Real_Type) return Complex_Type is - begin - return (Real, Imag); - end Make; - ------------------------------------------------------------- - procedure Components (Complex_No : in Complex_Type; - Real_Part, Imag_Part : out Real_Type) is - begin - Real_Part := Complex_No.Real; - Imag_Part := Complex_No.Imag; - end Components; - -end CA11013_0; - - --==================================================================-- - --- Generic child of complex number package. This child adds a layer of --- functionality to the parent generic. - -generic -- Random complex number operation. - -function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type; - - --==============================================-- - -function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is - - Random_Real_Part : Real_Type := Random_Generator (Seed); - -- parent's formal subprogram - Random_Imag_Part : Real_Type - := Random_Generator (Random_Generator (Seed)); - -- parent's formal subprogram - Random_Complex_No : Complex_Type; - -begin -- CA11013_0.CA11013_1 - - Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part); - -- operation from parent - return (Random_Complex_No); - -end CA11013_0.CA11013_1; - - --==================================================================-- - -package CA11013_2 is - - -- To be used as actual parameters for random number generator - -- in the parent package. - - type My_Float is digits 6 range -10.0 .. 100.0; - - function Random_Complex (Seed : My_float) return My_Float; - -end CA11013_2; - - --==================================================================-- - -package body CA11013_2 is - - -- Not a real random number generator. - function Random_Complex (Seed : My_float) return My_Float is - begin - return (Seed + 3.0); - end Random_Complex; - -end CA11013_2; - - --==================================================================-- - --- Declare instances of the generic complex packages for real type. --- The instance of the child must itself be declared as a child of the --- instance of the parent. - -with CA11013_0; -- Complex number. -with CA11013_2; -- Random number generator. -pragma Elaborate (CA11013_0); -package CA11013_3 is new - CA11013_0 (Random_Generator => CA11013_2.Random_Complex, - Real_Type => CA11013_2.My_Float); - -with CA11013_0.CA11013_1; -- Random complex number operation. -with CA11013_3; -pragma Elaborate (CA11013_3); -function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1; - - --==================================================================-- - -with Report; -with CA11013_2; -- Random number generator. -with CA11013_3.CA11013_4; -- Complex abstraction + Random complex - -- number operation. -procedure CA11013 is - - package My_Complex_Pkg renames CA11013_3; - use type CA11013_2.My_Float; - - My_Complex : My_Complex_Pkg.Complex_Type; - My_Literal : CA11013_2.My_Float := 3.0; - My_Real_Part, My_Imag_Part : CA11013_2.My_Float; - -begin - - Report.Test ("CA11013", "Check that child instance can use its parent's " & - "declarations and operations, including a formal " & - "subprogram of the parent"); - - My_Complex := CA11013_3.CA11013_4 (My_Literal); - -- Operation from the generic child function. - - My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part); - -- Operation from the generic parent package. - - if My_Real_Part /= 6.0 -- Operation from the generic - or My_Imag_Part /= 9.0 -- parent package. - then - Report.Failed ("Incorrect results from complex operation"); - end if; - - Report.Result; - -end CA11013; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11014.a b/gcc/testsuite/ada/acats/tests/ca/ca11014.a deleted file mode 100644 index 7847a5067c1..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11014.a +++ /dev/null @@ -1,302 +0,0 @@ --- CA11014.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 an instantiation of a child package of a generic package --- can use its parent's declarations and operations, including a formal --- package of the parent. --- --- TEST DESCRIPTION: --- Declare a list abstraction in a generic package which manages lists of --- elements of any discrete type. Declare a generic package which --- operates on lists of elements of integer types. Declare a generic --- child of this package which defines additional list operations. --- Use the formal discrete type as the generic formal actual part for the --- parent formal package. --- --- Declare an instance of parent, then declare an instance of the child --- which is itself a child the parent's instance. In the main program, --- check that the operations in both instances perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- 07 Sep 96 SAIC Change formal param E to be out only. --- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context --- clauses of CA11014_0, CA11014_1, and CA11014_5. --- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4 ---! - --- Actual package for the parent's formal. -generic - - type Element_Type is (<>); -- List elems may be of any discrete types. - -package CA11014_0 is - - type Node_Type; - type Node_Pointer is access Node_Type; - - type Node_Type is record - Item : Element_Type; - Next : Node_Pointer := null; - end record; - - type List_Type is record - First : Node_Pointer := null; - Current : Node_Pointer := null; - Last : Node_Pointer := null; - end record; - - -- Return true if current element is last in the list. - function End_Of_List (L : List_Type) return boolean; - - -- Set "current" pointer to first list element. - procedure Reset (L : in out List_Type); - -end CA11014_0; - - --==================================================================-- - -package body CA11014_0 is - - function End_Of_List (L : List_Type) return boolean is - begin - return (L.Current = null); - end End_Of_List; - ------------------------------------------------------- - procedure Reset (L : in out List_Type) is - begin - L.Current := L.First; -- Set "current" pointer to first - end Reset; -- list element. - -end CA11014_0; - - --==================================================================-- - -with CA11014_0; -- Generic list abstraction. -pragma Elaborate (CA11014_0); -generic - - -- Import the list abstraction defined in CA11014_0. - with package List_Mgr is new CA11014_0 (<>); - -package CA11014_1 is - - -- Write to current element and advance "current" pointer. - procedure Write_Element (L : in out List_Mgr.List_Type; - E : in List_Mgr.Element_Type); - - -- Read from current element and advance "current" pointer. - procedure Read_Element (L : in out List_Mgr.List_Type; - E : out List_Mgr.Element_Type); - - -- Add element to end of list. - procedure Add_Element (L : in out List_Mgr.List_Type; - E : in List_Mgr.Element_Type); - -end CA11014_1; - - --==================================================================-- - -package body CA11014_1 is - - procedure Write_Element (L : in out List_Mgr.List_Type; - E : in List_Mgr.Element_Type) is - begin - L.Current.Item := E; -- Write to current element. - L.Current := L.Current.Next; -- Advance "current" pointer. - end Write_Element; - ------------------------------------------------------- - procedure Read_Element (L : in out List_Mgr.List_Type; - E : out List_Mgr.Element_Type) is - begin - E := L.Current.Item; -- Retrieve current element. - L.Current := L.Current.Next; -- Advance "current" pointer. - end Read_Element; - ------------------------------------------------------- - procedure Add_Element (L : in out List_Mgr.List_Type; - E : in List_Mgr.Element_Type) is - New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null); - use type List_Mgr.Node_Pointer; - begin - if L.First = null then -- No elements in list, so add new - L.First := New_Node; -- element at beginning of list. - else - L.Last.Next := New_Node; -- Add new element at end of list. - end if; - L.Last := New_Node; -- Set last-in-list pointer. - end Add_Element; - -end CA11014_1; - - --==================================================================-- - --- Generic child of list operation. This child adds a layer of --- functionality to the parent generic. - -generic - -package CA11014_1.CA11014_2 is - - procedure Write_First_To_List (L : in out List_Mgr.List_Type); - - -- ... Various other operations used by the application. - -end CA11014_1.CA11014_2; - - --==================================================================-- - -package body CA11014_1.CA11014_2 is - - procedure Write_First_To_List (L : in out List_Mgr.List_Type) is - begin - List_Mgr.Reset (L); -- Parent's formal package. - - while not List_Mgr.End_Of_List (L) loop -- Parent's formal package. - Write_Element (L, List_Mgr.Element_Type'First); - -- Parent's operation, - end loop; -- parent's formal. - - end Write_First_To_List; - -end CA11014_1.CA11014_2; - - --==================================================================-- - -package CA11014_3 is - - type Points is range 0 .. 100; - - -- ... Various other types used by the application. - -end CA11014_3; - - --- No body for CA11014_3; - - --==================================================================-- - --- Declare instances of the generic list packages for the discrete type. --- The instance of the child must itself be declared as a child of the --- instance of the parent. - -with CA11014_0; -- Generic list abstraction. -with CA11014_3; -- Package containing discrete type declaration. -pragma Elaborate (CA11014_0); -package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list. - -with CA11014_4; -- Points list. -with CA11014_1; -- Generic list operation. -pragma Elaborate (CA11014_1); -package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list. - -with CA11014_1.CA11014_2; -- Additional generic list operation, -with CA11014_5; -pragma Elaborate (CA11014_5); -package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2; - -- Points list operation. - - --==================================================================-- - -with CA11014_1.CA11014_2; -- Additional generic list operation, - -- implicitly with list operation. -with CA11014_3; -- Package containing discrete type declaration. -with CA11014_4; -- Points list. -with CA11014_5.CA11014_6; -- Points list operation. -with Report; - -procedure CA11014 is - - package Lists_Of_Scores renames CA11014_4; - package Score_Ops renames CA11014_5; - package Point_Ops renames CA11014_5.CA11014_6; - - Scores : Lists_Of_Scores.List_Type; -- List of points. - - type TC_Score_Array is array (1 .. 3) of CA11014_3.Points; - - TC_Initial_Values : constant TC_Score_Array := (10, 21, 49); - TC_Final_Values : constant TC_Score_Array := (0, 0, 0); - - TC_Initial_Values_Are_Correct : boolean := false; - TC_Final_Values_Are_Correct : boolean := false; - - -------------------------------------------------- - - -- Initial list contains 3 scores with the values 10, 21, and 49. - procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is - begin - for I in TC_Score_Array'range loop - Score_Ops.Add_Element (L, TC_Initial_Values(I)); - -- Operation from generic parent. - end loop; - end TC_Initialize_List; - - -------------------------------------------------- - - -- Verify that all scores have been set to zero. - procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; - Expected : in TC_Score_Array; - OK : out boolean) is - Actual : TC_Score_Array; - begin - Lists_of_Scores.Reset (L); -- Operation from parent's formal. - for I in TC_Score_Array'range loop - Score_Ops.Read_Element (L, Actual(I)); - -- Operation from generic parent. - end loop; - OK := (Actual = Expected); - end TC_Verify_List; - - -------------------------------------------------- - -begin -- CA11014 - - Report.Test ("CA11014", "Check that an instantiation of a child package " & - "of a generic package can use its parent's " & - "declarations and operations, including a " & - "formal package of the parent"); - - TC_Initialize_List (Scores); - TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct); - - if not TC_Initial_Values_Are_Correct then - Report.Failed ("List contains incorrect initial values"); - end if; - - Point_Ops.Write_First_To_List (Scores); - -- Operation from generic child package. - - TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct); - - if not TC_Final_Values_Are_Correct then - Report.Failed ("List contains incorrect final values"); - end if; - - Report.Result; - -end CA11014; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11015.a b/gcc/testsuite/ada/acats/tests/ca/ca11015.a deleted file mode 100644 index 79b99ede82c..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11015.a +++ /dev/null @@ -1,312 +0,0 @@ --- CA11015.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 generic child of a non-generic package can use its --- parent's declarations and operations. Check that the instantiation --- of the generic child can correctly use the operations. --- --- TEST DESCRIPTION: --- Declare a map abstraction in a package which manages basic physical --- maps. Declare a generic child of this package which defines copies --- of maps of any discrete type, i.e., population, density, or weather. --- --- In the main program, declare an instance of the child. Check that --- the operations in the parent and instance of the child package --- perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Simulates map of physical features, i.e., desert, forest, water, --- or plains. - -package CA11015_0 is - type Map_Type is private; - subtype Latitude is integer range 1 .. 9; - subtype Longitude is integer range 1 .. 7; - - type Physical_Features is (Desert, Forest, Water, Plains, Unexplored); - type Page_Type is range 0 .. 80; - - Terra_Incognita : exception; - - -- Use geographic database to initialize the basic map. - - procedure Initialize_Basic_Map (Map : in out Map_Type); - - function Get_Physical_Feature (Lat : Latitude; - Long : Longitude; - Map : Map_Type) return Physical_Features; - - function Next_Page return Page_Type; - -private - type Map_Type is array (Latitude, Longitude) of Physical_Features; - Basic_Map : Map_Type; - Page : Page_Type := 0; -- Location for each copy of Map. - -end CA11015_0; - - --==================================================================-- - -package body CA11015_0 is - - procedure Initialize_Basic_Map (Map : in out Map_Type) is - -- Not a real initialization. Real application can use geographic - -- database to create the basic map. - begin - for I in Latitude'first .. Latitude'last loop - for J in 1 .. 2 loop - Map (I, J) := Unexplored; - end loop; - for J in 3 .. 4 loop - Map (I, J) := Desert; - end loop; - for J in 5 .. 7 loop - Map (I, J) := Plains; - end loop; - end loop; - - end Initialize_Basic_Map; - --------------------------------------------------- - function Get_Physical_Feature (Lat : Latitude; - Long : Longitude; - Map : Map_Type) - return Physical_Features is - begin - return (Map (Lat, Long)); - end Get_Physical_Feature; - --------------------------------------------------- - function Next_Page return Page_Type is - begin - Page := Page + 1; - return (Page); - end Next_Page; - - --------------------------------------------------- - begin -- CA11015_0 - -- Initialize a basic map. - Initialize_Basic_Map (Basic_Map); - -end CA11015_0; - - --==================================================================-- - --- Generic child package of physical map. Instantiate this package to --- create map copy with a new geographic feature, i.e., population, density, --- or weather. - -generic - - type Generic_Feature is (<>); -- Any geographic feature, i.e., population, - -- density, or weather that can be - -- characterized by a scalar value. - -package CA11015_0.CA11015_1 is - - type Feature_Map is private; - - function Get_Feature_Val (Lat : Latitude; - Long : Longitude; - Map : Feature_Map) return Generic_Feature; - - procedure Set_Feature_Val (Lat : in Latitude; - Long : in Longitude; - Fea : in Generic_Feature; - Map : in out Feature_Map); - - function Check_Page (Map : Feature_Map; - Page_No : Page_Type) return boolean; - -private - type Feature_Type is array (Latitude, Longitude) of Generic_Feature; - - type Feature_Map is - record - Feature : Feature_Type; - Page : Page_Type := Next_Page; -- Operation from parent. - end record; - -end CA11015_0.CA11015_1; - - --==================================================================-- - -package body CA11015_0.CA11015_1 is - - function Get_Feature_Val (Lat : Latitude; - Long : Longitude; - Map : Feature_Map) return Generic_Feature is - begin - return (Map.Feature (Lat, Long)); - end Get_Feature_Val; - --------------------------------------------------- - procedure Set_Feature_Val (Lat : in Latitude; - Long : in Longitude; - Fea : in Generic_Feature; - Map : in out Feature_Map) is - begin - if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored - -- Parent's operation, - -- Parent's private object. - then - raise Terra_Incognita; -- Exception from parent. - else - Map.Feature (Lat, Long) := Fea; - end if; - end Set_Feature_Val; - --------------------------------------------------- - function Check_Page (Map : Feature_Map; - Page_No : Page_Type) return boolean is - begin - return (Map.Page = Page_No); - end Check_Page; - -end CA11015_0.CA11015_1; - - --==================================================================-- - -with CA11015_0.CA11015_1; -- Generic map operation, - -- implicitly withs parent, basic map - -- application. -with Report; - -procedure CA11015 is - -begin - - Report.Test ("CA11015", "Check that an instantiation of a child package " & - "of a non-generic package can use its parent's " & - "declarations and operations"); - --- An application creates a population map using an integer type. - - Population_Map_Subtest: - declare - type Population_Type is range 0 .. 10_000; - - -- Declare instance of the child generic map package for one - -- particular integer type. - - package Population is new CA11015_0.CA11015_1 (Population_Type); - - Population_Map_Latitude : CA11015_0.Latitude := 1; - -- parent's type - Population_Map_Longitude : CA11015_0.Longitude := 5; - -- parent's type - Pop_Map : Population.Feature_Map; - Pop : Population_Type := 1000; - - begin - Population.Set_Feature_Val (Population_Map_Latitude, - Population_Map_Longitude, - Pop, - Pop_Map); - - If not ( (Population.Get_Feature_Val (Population_Map_Latitude, - Population_Map_Longitude, Pop_Map) = Pop) or - (Population.Check_Page (Pop_Map, 1)) ) then - Report.Failed ("Population map contains incorrect values"); - end if; - - end Population_Map_Subtest; - --- An application creates a weather map using an enumeration type. - - Weather_Map_Subtest: - declare - type Weather_Type is (Hot, Cold, Mild); - - -- Declare instance of the child generic map package for one - -- particular enumeration type. - - package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type); - - Weather_Map_Latitude : CA11015_0.Latitude := 2; - -- parent's type - Weather_Map_Longitude : CA11015_0.Longitude := 6; - -- parent's type - Weather_Map : Weather_Pkg.Feature_Map; - Weather : Weather_Type := Mild; - - begin - Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude, - Weather_Map_Longitude, - Weather, - Weather_Map); - - if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude, - Weather_Map_Longitude, Weather_Map) /= Weather) or - not (Weather_Pkg.Check_Page (Weather_Map, 2)) ) - then - Report.Failed ("Weather map contains incorrect values"); - end if; - - end Weather_Map_Subtest; - --- During processing, the application may erroneously attempts to create --- a density map on an unexplored area. This would result in the raising --- of an exception. - - Density_Map_Subtest: - declare - type Density_Type is (High, Medium, Low); - - -- Declare instance of the child generic map package for one - -- particular enumeration type. - - package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type); - - Density_Map_Latitude : CA11015_0.Latitude := 7; - -- parent's type - Density_Map_Longitude : CA11015_0.Longitude := 2; - -- parent's type - Density : Density_Type := Low; - Density_Map : Density_Pkg.Feature_Map; - - begin - Density_Pkg.Set_Feature_Val (Density_Map_Latitude, - Density_Map_Longitude, - Density, - Density_Map); - - Report.Failed ("Exception not raised in child generic package"); - - exception - - when CA11015_0.Terra_Incognita => -- parent's exception, - null; -- raised in child. - - when others => - Report.Failed ("Others exception is raised"); - - end Density_Map_Subtest; - - Report.Result; - -end CA11015; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11016.a b/gcc/testsuite/ada/acats/tests/ca/ca11016.a deleted file mode 100644 index d6d4089a959..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11016.a +++ /dev/null @@ -1,321 +0,0 @@ --- CA11016.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 child of a non-generic package can be a private generic --- package. Check that the private child instance can use its parent's --- declarations and operations. Check that the body of a public child --- package can instantiate its sibling private generic package. --- --- TEST DESCRIPTION: --- Declare a map abstraction in a package which manages basic physical --- map[s]. Declare a private generic child of this package which can be --- instantiated for any display device which has display locations of --- the physical map that can be characterized by any integer type, i.e., --- the intensity of the display point. --- --- Declare a public child of the physical map which specifies the --- display device. In the body of this child, declare an instance of --- its generic sibling to display the geographic locations. --- --- In the main program, check that the operations in the parent, public --- child and instance of the private child package perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate. --- ---! - --- Simulates map of physical features, i.e., desert, forest, or water. - -package CA11016_0 is - type Map_Type is private; - subtype Latitude is integer range 1 .. 9; - subtype Longitude is integer range 1 .. 7; - - type Physical_Features is (Desert, Forest, Water); - - -- Use geographic database to initialize the basic map. - - procedure Initialize_Basic_Map (Map : in out Map_Type); - - function Get_Physical_Feature (Lat : Latitude; - Long : Longitude; - Map : Map_Type) return Physical_Features; - -private - type Map_Type is array (Latitude, Longitude) of Physical_Features; - Basic_Map : Map_Type; - -end CA11016_0; - - --==================================================================-- - -package body CA11016_0 is - - procedure Initialize_Basic_Map (Map : in out Map_Type) is - -- Not a real initialization. Real application can use geographic - -- database to create the basic map. - - begin - for I in Latitude'first .. Latitude'last loop - for J in 1 .. 2 loop - Map (I, J) := Desert; - end loop; - for J in 3 .. 4 loop - Map (I, J) := Forest; - end loop; - for J in 5 .. 7 loop - Map (I, J) := Water; - end loop; - end loop; - - end Initialize_Basic_Map; - -------------------------------------------------------- - function Get_Physical_Feature (Lat : Latitude; - Long : Longitude; - Map : Map_Type) - return Physical_Features is - begin - return (Map (Lat, Long)); - end Get_Physical_Feature; - -------------------------------------------------------- - - begin - -- Initialize a basic map. - Initialize_Basic_Map (Basic_Map); - -end CA11016_0; - - --==================================================================-- - --- Private generic child package of physical map. This generic package may --- be instantiated for any display device which has display locations --- (latitude, longitude) that can be characterized by an integer value. --- For example, the intensity of the display point might be so characterized. --- It can be instantiated for any desired range of values (which would --- correspond to the range accepted by the display device). - - -private - -generic - - type Display_Value is range <>; -- Any display feature that is - -- represented by an integer. - -package CA11016_0.CA11016_1 is - - function Get_Display_Value (Lat : Latitude; - Long : Longitude; - Map : Map_Type) return Display_Value; - -end CA11016_0.CA11016_1; - - - --==================================================================-- - - -package body CA11016_0.CA11016_1 is - - function Get_Display_Value (Lat : Latitude; - Long : Longitude; - Map : Map_Type) - return Display_Value is - begin - case Get_Physical_Feature (Lat, Long, Map) is - -- Parent's operation, - when Forest => return (Display_Value'first); - -- Parent's type. - when Desert => return (Display_Value'last); - -- Parent's type. - when others => return - ( (Display_Value'last - Display_Value'first) / 2 ); - -- NOTE: Results are truncated. - end case; - - end Get_Display_Value; - -end CA11016_0.CA11016_1; - - - --==================================================================-- - --- Map display operation, public child of physical map. - -package CA11016_0.CA11016_2 is - - -- Super-duper Ultra Geographic Display Device (SDUGD) can display - -- geographic locations with light intensity values ranging from 1 to 7. - - type Display_Val is range 1 .. 7; - - type Device_Color is (Brown, Blue, Green); - - type IO_Packet is - record - Lat : Latitude; -- Parent's type. - Long : Longitude; -- Parent's type. - Color : Device_Color; - Intensity : Display_Val; - end record; - - procedure Data_For_SDUGD (Lat : in Latitude; - Long : in Longitude; - Output_Packet : in out IO_Packet); - -end CA11016_0.CA11016_2; - - --==================================================================-- - - -with CA11016_0.CA11016_1; -- Private generic sibling. -pragma Elaborate (CA11016_0.CA11016_1); - -package body CA11016_0.CA11016_2 is - - -- Declare instance of the private generic sibling for - -- an integer type that represents color intensity. - - package SDUGD is new CA11016_0.CA11016_1 (Display_Val); - - procedure Data_For_SDUGD (Lat : in Latitude; - Long : in Longitude; - Output_Packet : in out IO_Packet) is - - -- Simulates sending control information to a display device. - -- Control information consists of latitude, longitude, a - -- color, and an intensity. - - begin - case Get_Physical_Feature (Lat, Long, Basic_Map) is - -- Parent's operation. - when Water => Output_Packet.Color := Blue; - Output_Packet.Intensity := SDUGD.Get_Display_Value - (Lat, Long, Basic_Map); - -- Sibling's operation. - when Forest => Output_Packet.Color := Green; - Output_Packet.Intensity := SDUGD.Get_Display_Value - (Lat, Long, Basic_Map); - -- Sibling's operation. - when others => Output_Packet.Color := Brown; - Output_Packet.Intensity := SDUGD.Get_Display_Value - (Lat, Long, Basic_Map); - -- Sibling's operation. - end case; - - end Data_For_SDUGD; - -end CA11016_0.CA11016_2; - - --==================================================================-- - -with CA11016_0.CA11016_2; -- Map display device operation, - -- implicitly withs parent, physical map - -- application. - -use CA11016_0.CA11016_2; -- Allows direct visibility to the simple - -- name of CA11016_0.CA11016_2. - -with Report; - -procedure CA11016 is - - TC_Packet : IO_Packet; - -begin - - Report.Test ("CA11016", "Check that body of a public child package can " & - "use its sibling private generic package " & - "declarations and operations"); - --- Simulate control information at coordinates 3 and 7 of the --- basic map for the SDUGD. - - Water_Display_Subtest: - begin - TC_Packet.Lat := 3; - TC_Packet.Long := 7; - - -- Build color and light intensity of the basic map at - -- latitude 3 and longitude 7. - - Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); - - if ( (TC_Packet.Color /= Blue) or - (TC_Packet.Intensity /= 3) ) then - Report.Failed ("Map display device contains " & - "incorrect values for water subtest"); - end if; - - end Water_Display_Subtest; - --- Simulate control information at coordinates 2 and 1 of the --- basic map for the SDUGD. - - Desert_Display_Subtest: - begin - TC_Packet.Lat := 9; - TC_Packet.Long := 2; - - -- Build color and light intensity of the basic map at - -- latitude 9 and longitude 2. - - Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); - - if ( (TC_Packet.Color /= Brown) or - (TC_Packet.Intensity /= 7) ) then - Report.Failed ("Map display device contains " & - "incorrect values for desert subtest"); - end if; - - end Desert_Display_Subtest; - --- Simulate control information at coordinates 8 and 4 of the --- basic map for the SDUGD. - - Forest_Display_Subtest: - begin - TC_Packet.Lat := 8; - TC_Packet.Long := 4; - - -- Build color and light intensity of the basic map at - -- latitude 8 and longitude 4. - - Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); - - if ( (TC_Packet.Color /= Green) or - (TC_Packet.Intensity /= 1) ) then - Report.Failed ("Map display device contains " & - "incorrect values for forest subtest"); - end if; - - end Forest_Display_Subtest; - - Report.Result; - -end CA11016; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11017.a b/gcc/testsuite/ada/acats/tests/ca/ca11017.a deleted file mode 100644 index cbcce701d37..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11017.a +++ /dev/null @@ -1,246 +0,0 @@ --- CA11017.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 body of the parent package may depend on one of its own --- public children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- public child during code maintenance without distubing a large --- subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a string abstraction in a package which manipulates string --- replacement. Define a parent package which provides operations for --- a record type with discriminant. Declare a public child of this --- package which adds functionality to the original subsystem. In the --- parent body, call operations from the public child. --- --- In the main program, check that operations in the parent and public --- child perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Simulates application which manipulates strings. - -package CA11017_0 is - - type String_Rec (The_Size : positive) is private; - - type Substring is new string; - - -- ... Various other types used by the application. - - procedure Replace (In_The_String : in out String_Rec; - At_The_Position : in positive; - With_The_String : in String_Rec); - - -- ... Various other operations used by the application. - -private - -- Different size for each individual record. - - type String_Rec (The_Size : positive) is - record - The_Length : natural := 0; - The_Content : Substring (1 .. The_Size); - end record; - -end CA11017_0; - - --=================================================================-- - --- Public child added during code maintenance without disturbing a --- large system. This public child would add functionality to the --- original system. - -package CA11017_0.CA11017_1 is - - Position_Error : exception; - - function Equal_Length (Left : in String_Rec; - Right : in String_Rec) return boolean; - - function Same_Content (Left : in String_Rec; - Right : in String_Rec) return boolean; - - procedure Copy (From_The_Substring : in Substring; - To_The_String : in out String_Rec); - - -- ... Various other operations used by the application. - -end CA11017_0.CA11017_1; - - --=================================================================-- - -package body CA11017_0.CA11017_1 is - - function Equal_Length (Left : in String_Rec; - Right : in String_Rec) return boolean is - -- Quick comparison between the lengths of the input strings. - - begin - return (Left.The_Length = Right.The_Length); -- Parent's private - -- type. - end Equal_Length; - -------------------------------------------------------------------- - function Same_Content (Left : in String_Rec; - Right : in String_Rec) return boolean is - - begin - for I in 1 .. Left.The_Length loop - if Left.The_Content (I) = Right.The_Content (I) then - return true; - else - return false; - end if; - end loop; - - end Same_Content; - -------------------------------------------------------------------- - procedure Copy (From_The_Substring : in Substring; - To_The_String : in out String_Rec) is - begin - To_The_String.The_Content -- Parent's private type. - (1 .. From_The_Substring'length) := From_The_Substring; - - To_The_String.The_Length -- Parent's private type. - := From_The_Substring'length; - end Copy; - -end CA11017_0.CA11017_1; - - --=================================================================-- - --- After child is added to the subsystem, a maintainer decides --- to take advantage of the new functionality and rewrites the --- parent's body. - -with CA11017_0.CA11017_1; - -package body CA11017_0 is - - -- Calls functions from public child for a quick comparison of the - -- input strings. If their lengths are the same, do the replacement. - - procedure Replace (In_The_String : in out String_Rec; - At_The_Position : in positive; - With_The_String : in String_Rec) is - End_Position : natural := At_The_Position + - With_The_String.The_Length - 1; - - begin - if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation. - (With_The_String, In_The_String) then - raise CA11017_0.CA11017_1.Position_Error; - -- Public child's exception. - else - In_The_String.The_Content (At_The_Position .. End_Position) := - With_The_String.The_Content (1 .. With_The_String.The_Length); - end if; - - end Replace; - -end CA11017_0; - - --=================================================================-- - -with Report; - -with CA11017_0.CA11017_1; -- Explicit with public child package, - -- implicit with parent package (CA11017_0). - -procedure CA11017 is - - package String_Pkg renames CA11017_0; - use String_Pkg; - -begin - - Report.Test ("CA11017", "Check that body of the parent package can " & - "depend on one of its own public children"); - --- Both input strings have the same size. Replace the first string by the --- second string. - - Replace_Subtest: - declare - The_First_String, The_Second_String : String_Rec (16); - -- Parent's private type. - The_Position : positive := 1; - begin - CA11017_1.Copy ("This is the time", - To_The_String => The_First_String); - - CA11017_1.Copy ("For all good men", The_Second_String); - - Replace (The_First_String, The_Position, The_Second_String); - - -- Compare results using function from public child since - -- the type is private. - - if not CA11017_1.Same_Content - (The_First_String, The_Second_String) then - Report.Failed ("Incorrect results"); - end if; - - end Replace_Subtest; - --- During processing, the application may erroneously attempt to replace --- strings of different size. This would result in the raising of an --- exception. - - Exception_Subtest: - declare - The_First_String : String_Rec (17); - -- Parent's private type. - The_Second_String : String_Rec (13); - -- Parent's private type. - The_Position : positive := 2; - begin - CA11017_1.Copy (" ACVC Version 2.0", The_First_String); - - CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic", - To_The_String => The_Second_String); - - Replace (The_First_String, The_Position, The_Second_String); - - Report.Failed ("Exception was not raised"); - - exception - when CA11017_1.Position_Error => - Report.Comment ("Exception is raised as expected"); - - end Exception_Subtest; - - Report.Result; - -end CA11017; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a deleted file mode 100644 index a01ebfc32a4..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11018.a +++ /dev/null @@ -1,366 +0,0 @@ --- CA11018.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 body of the parent package may depend on one of its own --- public generic children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- public generic child during code maintenance without distubing a large --- subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a message application in a package which highlights some --- key words. Declare a public generic child of this package which adds --- functionality to the original subsystem. In the parent body, --- instantiate the child. --- --- In the main program, check that the operations in the parent, --- and instances of the public child package perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst. --- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - --- Simulates application which displays messages. - -package CA11018_0 is - - type Designated_Num is new Integer range 0 .. 100; - - type Particularly_Designated_Num is new Integer range 0 .. 100; - - type Message is new String; - - type Message_Rec is tagged private; - - type Designated_Msg is new Message_Rec with private; - - type Particularly_Designated_Msg is new Message_Rec with private; - - -- Analyzes message for presence of word in the secret message. If found, - -- word is highlighted. - - procedure Highlight_Designated (The_Word : in Message; - In_The_Message : in out Designated_Msg); - - - -- Analyzes message for presence of word in the secret message. If found, - -- word is highlighted and do other actions. - - procedure Highlight_Particularly_Designated - (The_Word : in Message; - In_The_Message : in out Particularly_Designated_Msg); - - - -- Begin test code declarations: ----------------------- - - TC_Designated_Not_Zero : Boolean := false; - - TC_Particularly_Designated_Not_Zero : Boolean := false; - - -- The following two functions are used to check for function - -- calls from the public generic child. - - function TC_Designated_Success return Boolean; - - function TC_Particularly_Designated_Success return Boolean; - - -- End test code declarations. ------------------------- - -private - type Message_Rec is tagged - record - The_Length : natural := 0; - The_Content : Message (1 .. 60); - end record; - - type Designated_Msg is new Message_Rec with null record; - -- ... More components in real application. - - type Particularly_Designated_Msg is new Message_Rec with null record; - -- ... More components in real application. - -end CA11018_0; - - --=================================================================-- - - --- Public generic child package of message display application. Imagine that --- messages of one security level are associated with a type derived from --- integer. For overall system security, messages of a different security --- level are associated with a different type derived from integer. By --- instantiating this package for each security level, the results of Count --- applied to one kind of message cannot inadvertently be compared with the --- results applied to a different kind. - -generic - type Msg_Type is new Message_Rec with private; - -- Derived from parent's type. - type Count is range <>; - -package CA11018_0.CA11018_1 is - - TC_Function_Called : Boolean := false; - - function Find_Word (Wrd : in Message; - Msg : in Msg_Type) return Count; - -end CA11018_0.CA11018_1; - - --=================================================================-- - -package body CA11018_0.CA11018_1 is - - function Find_Word (Wrd : in Message; - Msg : in Msg_Type) return Count is - - Num : Count := Count'first; - - -- Count how many time the word appears within the given message. - - begin - -- ... Error-checking code omitted for brevity. - - for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop - -- Parent's private type - if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd - -- Parent's private type - then - Num := Num + 1; - end if; - - end loop; - - TC_Function_Called := true; - - return (Num); - - end Find_Word; - -end CA11018_0.CA11018_1; - - --=================================================================-- - -with CA11018_0.CA11018_1; -- Public generic child. - -pragma Elaborate (CA11018_0.CA11018_1); -package body CA11018_0 is - - ---------------------------------------------------- - -- Parent's body depends on public generic child. -- - ---------------------------------------------------- - - -- Instantiate the public child for the secret message. - - package Designated_Pkg is new CA11018_0.CA11018_1 - (Msg_Type => Designated_Msg, Count => Designated_Num); - - -- Instantiate the public child for the top secret message. - - package Particularly_Designated_Pkg is new CA11018_0.CA11018_1 - (Particularly_Designated_Msg, Particularly_Designated_Num); - - -- End instantiations. ----------------------------- - - - function TC_Designated_Success return Boolean is - -- Check to see if the function in the public generic child is called. - - begin - return Designated_Pkg.TC_Function_Called; - end TC_Designated_Success; - -------------------------------------------------------------- - function TC_Particularly_Designated_Success return Boolean is - -- Check to see if the function in the public generic child is called. - - begin - return Particularly_Designated_Pkg.TC_Function_Called; - end TC_Particularly_Designated_Success; - -------------------------------------------------------------- - -- Calls functions from public child to search for a key word. - -- If the word appears more than once in each message, - -- highlight all of them. - - procedure Highlight_Designated (The_Word : in Message; - In_The_Message : in out Designated_Msg) is - - -- Not a real highlight procedure. Real application can use graphic - -- device to highlight all occurrences of words. - - begin - -------------------------------------------------------------- - -- Parent's body uses function from instantiation of public -- - -- generic child. -- - -------------------------------------------------------------- - - if Designated_Pkg.Find_Word -- Child's operation. - (The_Word, In_The_Message) > 0 then - - -- Highlight all occurrences in lavender. - - TC_Designated_Not_Zero := true; - end if; - - end Highlight_Designated; - -------------------------------------------------------------- - procedure Highlight_Particularly_Designated - (The_Word : in Message; - In_The_Message : in out Particularly_Designated_Msg) is - - -- Not a real highlight procedure. Real application can use graphic - -- device to highlight all occurrences of words. - - begin - -------------------------------------------------------------- - -- Parent's body uses function from instantiation of public -- - -- generic child. -- - -------------------------------------------------------------- - - if Particularly_Designated_Pkg.Find_Word -- Child's operation. - (The_Word, In_The_Message) > 0 then - - -- Highlight all occurrences in chartreuse. - -- Do other more secret stuff. - - TC_Particularly_Designated_Not_Zero := true; - end if; - - end Highlight_Particularly_Designated; - -end CA11018_0; - - --=================================================================-- - --- Public generic child to copy words to the messages. - -generic - type Message_Type is new Message_Rec with private; - -- Derived from parent's type. - -package CA11018_0.CA11018_2 is - - procedure Copy (From_The_Word : in Message; - To_The_Message : in out Message_Type); - -end CA11018_0.CA11018_2; - - --=================================================================-- - -package body CA11018_0.CA11018_2 is - - procedure Copy (From_The_Word : in Message; - To_The_Message : in out Message_Type) is - - -- Copy words to the appropriate messages. - - begin - To_The_Message.The_Content -- Parent's private type. - (1 .. From_The_Word'length) := From_The_Word; - - To_The_Message.The_Length -- Parent's private type. - := From_The_Word'length; - end Copy; - -end CA11018_0.CA11018_2; - - --=================================================================-- - -with Report; - -with CA11018_0.CA11018_2; -- Public generic child package, copy words - -- to the message. - -- Implicit with parent package (CA11018_0). - -procedure CA11018 is - - package Message_Pkg renames CA11018_0; - -begin - - Report.Test ("CA11018", "Check that body of the parent package can " & - "depend on one of its own public generic children"); - --- Highlight the word "Alert" from the secret message. - - Designated_Subtest: - declare - The_Message : Message_Pkg.Designated_Msg; -- Parent's private type. - - -- Instantiate the public child to copy words to the secret message. - - package Copy_Designated_Pkg is new CA11018_0.CA11018_2 - (Message_Pkg.Designated_Msg); - - begin - Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard", - To_The_Message => The_Message); - - Message_Pkg.Highlight_Designated ("Alert", The_Message); - - if not Message_Pkg.TC_Designated_Not_Zero and - Message_Pkg.TC_Designated_Success then - Report.Failed ("Alert should have been highlighted"); - end if; - - end Designated_Subtest; - --- Highlight the word "Push The Alarm" from the top secret message. - - Particularly_Designated_Subtest: - declare - The_Message : Message_Pkg.Particularly_Designated_Msg ; - -- Parent's private type. - - -- Instantiate the public child to copy words to the top secret - -- message. - - package Copy_Particularly_Designated_Pkg is new - CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg); - - begin - Copy_Particularly_Designated_Pkg.Copy - ("Alert Level 10 : Alert The Guard and Push The Alarm", - The_Message); - - Message_Pkg.Highlight_Particularly_Designated - ("Push The Alarm", The_Message); - - if not Message_Pkg.TC_Particularly_Designated_Not_Zero and - Message_Pkg.TC_Particularly_Designated_Success then - Report.Failed ("Key words should have been highlighted"); - end if; - - end Particularly_Designated_Subtest; - - Report.Result; - -end CA11018; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11019.a b/gcc/testsuite/ada/acats/tests/ca/ca11019.a deleted file mode 100644 index 92b3ba5358b..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11019.a +++ /dev/null @@ -1,306 +0,0 @@ --- CA11019.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 body of the parent package may depend on one of its own --- private generic children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- generic private child during code maintenance without distubing a --- large subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a data collection abstraction in a package. Declare a private --- generic child of this package which provides parameterized code that --- have been written once and will be used three times to implement the --- services of the parent package. In the parent body, instantiate the --- private child. --- --- In the main program, check that the operations in the parent, --- and instance of the private child package perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - -package CA11019_0 is - -- parent - - type Data_Record is tagged private; - type Data_Collection is private; - --- - --- - subtype Data_1 is integer range 0 .. 100; - procedure Add_1 (Data : Data_1; To : in out Data_Collection); - function Statistical_Op_1 (Data : Data_Collection) return Data_1; - --- - subtype Data_2 is integer range -100 .. 1000; - procedure Add_2 (Data : Data_2; To : in out Data_Collection); - function Statistical_Op_2 (Data : Data_Collection) return Data_2; - --- - subtype Data_3 is integer range -10_000 .. 10_000; - procedure Add_3 (Data : Data_3; To : in out Data_Collection); - function Statistical_Op_3 (Data : Data_Collection) return Data_3; - --- - -private - - type Data_Ptr is access Data_Record'class; - subtype Sequence_Number is positive range 1 .. 512; - - type Data_Record is tagged - record - Next : Data_Ptr := null; - Seq : Sequence_Number; - end record; - --- - type Data_Collection is - record - First : Data_Ptr := null; - Last : Data_Ptr := null; - end record; - -end CA11019_0; - -- parent - - --=================================================================-- - --- This generic package provides parameterized code that has been --- written once and will be used three times to implement the services --- of the parent package. - -private -generic - type Data_Type is range <>; - -package CA11019_0.CA11019_1 is - -- parent.child - - type Data_Elem is new Data_Record with - record - Value : Data_Type; - end record; - - Next_Avail_Seq_No : Sequence_Number := 1; - - procedure Sequence (Ptr : Data_Ptr); - -- the child must be private for this procedure to know details of - -- the implementation of data collections - - procedure Add (Datum : Data_Type; To : in out Data_Collection); - - function Op (Data : Data_Collection) return Data_Type; - -- op models a complicated operation that whose code can be - -- used for various data types - - -end CA11019_0.CA11019_1; - -- parent.child - - --=================================================================-- - - -package body CA11019_0.CA11019_1 is - -- parent.child - - procedure Sequence (Ptr : Data_Ptr) is - begin - Ptr.Seq := Next_Avail_Seq_No; - Next_Avail_Seq_No := Next_Avail_Seq_No + 1; - end Sequence; - - --------------------------------------------------------- - - procedure Add (Datum : Data_Type; To : in out Data_Collection) is - Ptr : Data_Ptr; - begin - if To.First = null then - -- assign new record with data value to - -- to.next <- null; - To.First := new Data_Elem'(Next => null, - Value => Datum, - Seq => 1); - Sequence (To.First); - To.Last := To.First; - else - -- chase to end of list - Ptr := To.First; - while Ptr.Next /= null loop - Ptr := Ptr.Next; - end loop; - -- and add element there - Ptr.Next := new Data_Elem'(Next => null, - Value => Datum, - Seq => 1); - Sequence (Ptr.Next); - To.Last := Ptr.Next; - end if; - - end Add; - - --------------------------------------------------------- - - function Op (Data : Data_Collection) return Data_Type is - -- for simplicity, just return the maximum of the data set - Max : Data_Type := Data_Elem( Data.First.all ).Value; - -- assuming non-empty collection - Ptr : Data_Ptr := Data.First; - - begin - -- no error checking - while Ptr.Next /= null loop - if Data_Elem( Ptr.Next.all ).Value > Max then - Max := Data_Elem( Ptr.Next.all ).Value; - end if; - Ptr := Ptr.Next; - end loop; - return Max; - end Op; - -end CA11019_0.CA11019_1; - -- parent.child - - --=================================================================-- - --- parent body depends on private generic child -with CA11019_0.CA11019_1; -- Private generic child. - -pragma Elaborate (CA11019_0.CA11019_1); -package body CA11019_0 is - - -- instantiate the generic child with data types needed by the - -- package interface services - package Data_1_Ops is new CA11019_1 - (Data_Type => Data_1); - - package Data_2_Ops is new CA11019_1 - (Data_Type => Data_2); - - package Data_3_Ops is new CA11019_1 - (Data_Type => Data_3); - - --------------------------------------------------------- - - procedure Add_1 (Data : Data_1; To : in out Data_Collection) is - begin - -- maybe do other stuff here - Data_1_Ops.Add (Data, To); - -- and here - end; - - --------------------------------------------------------- - - function Statistical_Op_1 (Data : Data_Collection) return Data_1 is - begin - -- maybe use generic operation(s) in some complicated ways - -- (but simplified out, for the sake of testing) - return Data_1_Ops.Op (Data); - end; - - --------------------------------------------------------- - - procedure Add_2 (Data : Data_2; To : in out Data_Collection) is - begin - Data_2_Ops.Add (Data, To); - end; - - --------------------------------------------------------- - - function Statistical_Op_2 (Data : Data_Collection) return Data_2 is - begin - return Data_2_Ops.Op (Data); - end; - - --------------------------------------------------------- - - procedure Add_3 (Data : Data_3; To : in out Data_Collection) is - begin - Data_3_Ops.Add (Data, To); - end; - - --------------------------------------------------------- - - function Statistical_Op_3 (Data : Data_Collection) return Data_3 is - begin - return Data_3_Ops.Op (Data); - end; - -end CA11019_0; - - - --=================================================-- - -with CA11019_0, - -- Main, - -- Main.Child is private - Report; - -procedure CA11019 is - - package Main renames CA11019_0; - - Col_1, - Col_2, - Col_3 : Main.Data_Collection; - -begin - - Report.Test ("CA11019", "Check that body of a (non-generic) package " & - "may depend on its private generic child"); - - -- build a data collection - - for I in 1 .. 10 loop - Main.Add_1 ( Main.Data_1(I), Col_1); - end loop; - - if Main.Statistical_Op_1 (Col_1) /= 10 then - Report.Failed ("Wrong data_1 value returned"); - end if; - - for I in reverse 10 .. 20 loop - Main.Add_2 ( Main.Data_2(I * 10), Col_2); - end loop; - - if Main.Statistical_Op_2 (Col_2) /= 200 then - Report.Failed ("Wrong data_2 value returned"); - end if; - - for I in 0 .. 10 loop - Main.Add_3 ( Main.Data_3(I + 5), Col_3); - end loop; - - if Main.Statistical_Op_3 (Col_3) /= 15 then - Report.Failed ("Wrong data_3 value returned"); - end if; - - Report.Result; - -end CA11019; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11020.a b/gcc/testsuite/ada/acats/tests/ca/ca11020.a deleted file mode 100644 index 4949ce9feee..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11020.a +++ /dev/null @@ -1,238 +0,0 @@ --- CA11020.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 body of the generic parent package can depend on one of --- its own public generic children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- public generic child during code maintenance without distubing a large --- subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a bag abstraction in a generic package. Declare a public --- generic child of this package which adds a generic procedure to the --- original subsystem. In the parent body, instantiate the public --- child. Then instantiate the procedure as a child instance of the --- public child instance. --- --- In the main program, declare an instance of parent. Check that the --- operations in both parent and child packages perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Simulates bag application. - -generic - type Element is private; - with function Image (E : Element) return String; - -package CA11020_0 is - - type Bag is limited private; - - procedure Add (E : in Element; To_The_Bag : in out Bag); - - function Bag_Image (B : Bag) return string; - -private - type Node_Type; - type Bag is access Node_Type; - - type Node_Type is - record - The_Element : Element; - - -- Other components in real application, i.e., - -- The_Count : positive; - - Next : Bag; - end record; - -end CA11020_0; - - --==================================================================-- - --- More operations on Bag. - -generic - --- Parameters go here. - -package CA11020_0.CA11020_1 is - - -- ... Other declarations. - - generic -- Generic iterator procedure. - with procedure Use_Element (E : in Element); - - procedure Iterate (B : in Bag); -- Called once per element in the bag. - - -- ... Various other operations. - -end CA11020_0.CA11020_1; - - --==================================================================-- - -package body CA11020_0.CA11020_1 is - - procedure Iterate (B : in Bag) is - - -- Traverse each element in the bag. - - Elem : Bag := B; - - begin - while Elem /= null loop - Use_Element (Elem.The_Element); - Elem := Elem.Next; - end loop; - - end Iterate; - -end CA11020_0.CA11020_1; - - --==================================================================-- - -with CA11020_0.CA11020_1; -- Public generic child package. - -package body CA11020_0 is - - ---------------------------------------------------- - -- Parent's body depends on public generic child. -- - ---------------------------------------------------- - - -- Instantiate the public child. - - package MS is new CA11020_1; - - function Bag_Image (B : Bag) return string is - - Buffer : String (1 .. 10_000); - Last : Integer := 0; - - ----------------------------------------------------- - - -- Will be called by the iterator. - - procedure Append_Image (E : in Element) is - Im : constant String := Image (E); - - begin -- Append_Image - if Last /= 0 then -- Insert a comma. - Last := Last + 1; - Buffer (Last) := ','; - end if; - - Buffer (Last + 1 .. Last + Im'Length) := Im; - Last := Last + Im'Length; - - end Append_Image; - - ----------------------------------------------------- - - -- Instantiate procedure Iterate as a child of instance MS. - - procedure Append_All is new MS.Iterate (Use_Element => Append_Image); - - begin -- Bag_Image - - Append_All (B); - - return Buffer (1 .. Last); - - end Bag_Image; - - ----------------------------------------------------- - - procedure Add (E : in Element; To_The_Bag : in out Bag) is - - -- Not a real bag addition. - - Index : Bag := To_The_Bag; - - begin - -- ... Error-checking code omitted for brevity. - - if Index = null then - To_The_Bag := new Node_Type' (The_Element => E, - Next => null); - else - -- Goto the end of the list. - - while Index.Next /= null loop - Index := Index.Next; - end loop; - - -- Add element to the end of the list. - - Index.Next := new Node_Type' (The_Element => E, - Next => null); - end if; - - end Add; - -end CA11020_0; - - --==================================================================-- - -with CA11020_0; -- Bag application. - -with Report; - -procedure CA11020 is - - -- Instantiate the bag application for integer type and attribute - -- Image. - - package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image); - - My_Bag : Bag_Of_Integers.Bag; - -begin - - Report.Test ("CA11020", "Check that body of the generic parent package " & - "can depend on one of its own public generic children"); - - -- Add 10 consecutive integers to the bag. - - for I in 1 .. 10 loop - Bag_Of_Integers.Add (I, My_Bag); - end loop; - - if Bag_Of_Integers.Bag_Image (My_Bag) - /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then - Report.Failed ("Incorrect results"); - end if; - - Report.Result; - -end CA11020; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11021.a b/gcc/testsuite/ada/acats/tests/ca/ca11021.a deleted file mode 100644 index f4da2f91334..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11021.a +++ /dev/null @@ -1,245 +0,0 @@ --- CA11021.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 body of the generic parent package can depend on one of --- its own private generic children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- public generic child during code maintenance without distubing a large --- subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a generic package which declares high level operations for a --- complex number abstraction. Declare a private generic child package --- of this package which defines low level complex operations. In the --- parent body, instantiate the private child. Use the low level --- operation to complete the high level operation. --- --- In the main program, instantiate the parent generic package. --- Check that the operations in both packages perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -generic -- Complex number abstraction. - type Int_Type is range <>; - -package CA11021_0 is - - -- Simulate a generic complex number support package. Complex numbers - -- are treated as coordinates in the Cartesian plane. - - type Complex_Type is private; - - Zero : constant Complex_Type; -- Real number (0,0). - - function Real_Part (Complex_No : Complex_Type) - return Int_Type; - - function Imag_Part (Complex_No : Complex_Type) - return Int_Type; - - function Complex (Real, Imag : Int_Type) - return Complex_Type; - - -- High level operation for complex number. - function "*" (Factor : Int_Type; - C : Complex_Type) return Complex_Type; - - -- ... and other complicated ones. - -private - type Complex_Type is record - Real : Int_Type; - Imag : Int_Type; - end record; - - Zero : constant Complex_Type := (Real => 0, Imag => 0); - -end CA11021_0; - - --==================================================================-- - --- Private generic child of Complex_Number. - -private - -generic - --- No parameter. - -package CA11021_0.CA11021_1 is - - -- ... Other declarations. - - -- Low level operation on complex number. - function "+" (Left, Right : Complex_Type) - return Complex_Type; - - function "-" (Right : Complex_Type) - return Complex_Type; - - -- ... Various other operations in real application. - -end CA11021_0.CA11021_1; - - --==================================================================-- - -package body CA11021_0.CA11021_1 is - - function "+" (Left, Right : Complex_Type) - return Complex_Type is - - begin - return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); - end "+"; - - -------------------------------------------------- - - function "-" (Right : Complex_Type) return Complex_Type is - begin - return (-Right.Real, -Right.Imag); - end "-"; - -end CA11021_0.CA11021_1; - - --==================================================================-- - -with CA11021_0.CA11021_1; -- Private generic child package. - -package body CA11021_0 is - - ----------------------------------------------------- - -- Parent's body depends on private generic child. -- - ----------------------------------------------------- - - -- Instantiate the private child. - - package Complex_Ops is new CA11021_1; - use Complex_Ops; -- All user-defined operators - -- directly visible. - - -------------------------------------------------- - - function "*" (Factor : Int_Type; - C : Complex_Type) return Complex_Type is - Result : Complex_Type := Zero; - - begin - for I in 1 .. abs (Factor) loop - Result := Result + C; -- Private generic child "+". - end loop; - - if Factor < 0 then - Result := - Result; -- Private generic child "-". - end if; - - return Result; - end "*"; - - -------------------------------------------------- - - function Real_Part (Complex_No : Complex_Type) return Int_Type is - begin - return (Complex_No.Real); - end Real_Part; - - -------------------------------------------------- - - function Imag_Part (Complex_No : Complex_Type) return Int_Type is - begin - return (Complex_No.Imag); - end Imag_Part; - - -------------------------------------------------- - - function Complex (Real, Imag : Int_Type) return Complex_Type is - begin - return (Real, Imag); - end Complex; - -end CA11021_0; - - --==================================================================-- - -with CA11021_0; -- Complex number abstraction. - -with Report; - -procedure CA11021 is - - type My_Integer is range -100 .. 100; - - -------------------------------------------------- - --- Declare instance of the generic complex package for one particular --- integer type. - - package My_Complex_Pkg is new - CA11021_0 (Int_Type => My_Integer); - - use My_Complex_Pkg; -- All user-defined operators - -- directly visible. - - -------------------------------------------------- - - Complex_One, Complex_Two : Complex_Type; - - My_Literal : My_Integer := -3; - -begin - - Report.Test ("CA11021", "Check that body of the generic parent package " & - "can depend on its private generic child"); - - Complex_One := Complex (11, 6); - - Complex_Two := 5 * Complex_One; - - if Real_Part (Complex_Two) /= 55 - and Imag_Part (Complex_Two) /= 30 - then - Report.Failed ("Incorrect results from complex operation"); - end if; - - Complex_One := Complex (-4, 7); - - Complex_Two := My_Literal * Complex_One; - - if Real_Part (Complex_Two) /= 12 - and Imag_Part (Complex_Two) /= -21 - then - Report.Failed ("Incorrect results from complex operation"); - end if; - - Report.Result; - -end CA11021; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11022.a b/gcc/testsuite/ada/acats/tests/ca/ca11022.a deleted file mode 100644 index 60cbc08ce0a..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11022.a +++ /dev/null @@ -1,242 +0,0 @@ --- CA11022.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 body of a child unit can instantiate its generic sibling. --- --- TEST DESCRIPTION: --- Declare a package that provides some types for the graphic --- application. Add a generic child package with a subprogram parameter --- to provide algorithms that can be used by different terminal types --- but that have to be customized to the specific terminal. Add child --- packages to take advantage of the parent types and to provide a --- customized operation for each of the different terminals. The --- customized operation will be passed as a generic subprogram parameter --- to the child package's sibling. --- --- The main program "with"s the child packages. Check that the --- operations in child units perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CA11022_0 is -- Graphic Manager - - type Row is range 1 .. 66; - type Column is range 1 .. 80; - type Radius is range 1 .. 3; - type Length is range 5 .. 10; - - -- Testing artifice. - TC_Screen : array (Row, Column) of boolean := (others => (others => false)); - TC_Draw_Circle : boolean := false; - TC_Draw_Square : boolean := false; - - -- ... and other complicated ones. - -end CA11022_0; - --- No bodies required for CA11022_0. - - --==================================================================-- - --- Child package to provide general graphic functionalities. - -generic - - with procedure Put_Dot (X : in Column; - Y : in Row); - -package CA11022_0.CA11022_1 is - - procedure Draw_Square (At_Col : in Column; - At_Row : in Row; - Len : in Length); - - procedure Draw_Circle (At_Col : in Column; - At_Row : in Row; - Rad : in Radius); - - -- procedure Draw_Ellipse ... - -- and other drawings ... - -end CA11022_0.CA11022_1; - - --==================================================================-- - -package body CA11022_0.CA11022_1 is - - procedure Draw_Square (At_Col : in Column; - At_Row : in Row; - Len : in Length) is - begin - -- use square drawing algorithm - -- call - Put_Dot (At_Col + Column (Len), At_Row + Row(Len)); - -- as needed in the algorithm. - TC_Draw_Square := true; - end Draw_Square; - - ------------------------------------------------------- - procedure Draw_Circle (At_Col : in Column; - At_Row : in Row; - Rad : in Radius) is - begin - -- use circle drawing algorithm - -- call - for I in 1 .. Rad loop - Put_Dot (At_Col + Column(I), At_Row + Row(I)); - end loop; - -- as needed in the algorithm. - TC_Draw_Circle := true; - end Draw_Circle; - -end CA11022_0.CA11022_1; - - --==================================================================-- - -with CA11022_0.CA11022_1; -- Generic sibling. - --- Child package to provide customized graphic functions for the --- VT100. -package CA11022_0.CA11022_2 is -- VT100 Graphic. - - X : Column := 8; - Y : Row := 3; - R : Radius := 2; - L : Length := 6; - - procedure VT100_Graphic; - -end CA11022_0.CA11022_2; - - --==================================================================-- - -package body CA11022_0.CA11022_2 is - - procedure VT100_Graphic is - procedure VT100_Putdot (X : in Column; - Y : in Row) is - begin - -- Light a pixel at location (X, Y); - TC_Screen (Y, X) := true; - end VT100_Putdot; - - ------------------------------------ - - -- Declare instance of the generic sibling package to draw a circle, - -- a square, or an ellipse customized for the VT100. - package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot); - - begin - VT100_Graphic.Draw_Circle (X, Y, R); - VT100_Graphic.Draw_Square (X, Y, L); - end VT100_Graphic; - -end CA11022_0.CA11022_2; - - --==================================================================-- - -with CA11022_0.CA11022_1; -- Generic sibling. - --- Child package to provide customized graphic functions for the --- IBM3270. -package CA11022_0.CA11022_3 is -- IBM3270 Graphic. - - X : Column := 39; - Y : Row := 11; - R : Radius := 3; - L : Length := 7; - - procedure IBM3270_Graphic; - -end CA11022_0.CA11022_3; - - --==================================================================-- - -package body CA11022_0.CA11022_3 is - - procedure IBM3270_Graphic is - procedure IBM3270_Putdot (X : in Column; - Y : in Row) is - begin - -- Light a pixel at location (X + 2, Y); - TC_Screen (Y, X + Column(2)) := true; - end IBM3270_Putdot; - - ------------------------------------ - - -- Declare instance of the generic sibling package to draw a circle, - -- a square, or an ellipse customized for the IBM3270. - package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot); - - begin - IBM3270_Graphic.Draw_Circle (X, Y, R); - IBM3270_Graphic.Draw_Square (X, Y, L); - end IBM3270_Graphic; - -end CA11022_0.CA11022_3; - - --==================================================================-- - -with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with - -- CA11022_0, Graphic Manager. -with CA11022_0.CA11022_3; -- IBM3270 Graphic. -with Report; - -procedure CA11022 is - -begin - - Report.Test ("CA11022", "Check that body of a child unit can depend on " & - "its generic sibling"); - - -- Customized graphic functions for the VT100 terminal. - CA11022_0.CA11022_2.VT100_Graphic; - - if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10) - and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle - and not CA11022_0.TC_Draw_Square then - Report.Failed ("Wrong results for the VT100"); - end if; - - CA11022_0.TC_Draw_Circle := false; - CA11022_0.TC_Draw_Square := false; - - -- Customized graphic functions for the IBM3270 terminal. - CA11022_0.CA11022_3.IBM3270_Graphic; - - if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43) - and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18) - and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then - Report.Failed ("Wrong results for the IBM3270"); - end if; - - Report.Result; - -end CA11022; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a deleted file mode 100644 index a84c6b84f44..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a +++ /dev/null @@ -1,228 +0,0 @@ --- CA11A01.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 type extended in a public child inherits primitive --- operations from its ancestor. --- --- TEST DESCRIPTION: --- Declare a root tagged type in a package specification. Declare two --- primitive subprograms for the type (foundation code). --- --- Add a public child to the above package. Extend the root type with --- a record extension in the specification. Declare a new primitive --- subprogram to write to the child extension. --- --- Add a public grandchild to the above package. Extend the extension of --- the parent type with a record extension in the private part of the --- specification. Declare a new primitive subprogram for this grandchild --- extension. --- --- In the main program, "with" the grandchild. Access the primitive --- operations from grandparent and parent package. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package FA11A00.CA11A01_0 is -- Color_Widget_Pkg --- This public child declares an extension from its parent. It --- represents processing of widgets in a window system. - - type Widget_Color_Enum is (Black, Green, White); - - type Color_Widget is new Widget with -- Record extension of - record -- parent tagged type. - Color : Widget_Color_Enum; - end record; - - -- Inherits procedure Set_Width from Widget. - -- Inherits procedure Set_Height from Widget. - - -- To be inherited by its derivatives. - procedure Set_Color (The_Widget : in out Color_Widget; - C : in Widget_Color_Enum); - - procedure Set_Color_Widget (The_Widget : in out Color_Widget; - The_Width : in Widget_Length; - The_Height : in Widget_Length; - The_Color : in Widget_Color_Enum); - -end FA11A00.CA11A01_0; -- Color_Widget_Pkg - ---=======================================================================-- - -package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg - - procedure Set_Color (The_Widget : in out Color_Widget; - C : in Widget_Color_Enum) is - begin - The_Widget.Color := C; - end Set_Color; - --------------------------------------------------------------- - procedure Set_Color_Widget (The_Widget : in out Color_Widget; - The_Width : in Widget_Length; - The_Height : in Widget_Length; - The_Color : in Widget_Color_Enum) is - begin - Set_Width (The_Widget, The_Width); -- Inherited from parent. - Set_Height (The_Widget, The_Height); -- Inherited from parent. - Set_Color (The_Widget, The_Color); - end Set_Color_Widget; - -end FA11A00.CA11A01_0; -- Color_Widget_Pkg - ---=======================================================================-- - -package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg --- This public grandchild extends the extension from its parent. It --- represents processing of widgets in a window system. - - -- Declaration used by private extension component. - subtype Widget_Label_Str is string (1 .. 10); - - type Label_Widget is new Color_Widget with private; - -- Record extension of parent tagged type. - - -- Inherits (inherited) procedure Set_Width from Color_Widget. - -- Inherits (inherited) procedure Set_Height from Color_Widget. - -- Inherits procedure Set_Color from Color_Widget. - -- Inherits procedure Set_Color_Widget from Color_Widget. - - procedure Set_Label_Widget (The_Widget : in out Label_Widget; - The_Width : in Widget_Length; - The_Height : in Widget_Length; - The_Color : in Widget_Color_Enum; - The_Label : in Widget_Label_Str); - - -- The following function is needed to verify the value of the - -- extension's private component. - - function Verify_Label (The_Widget : in Label_Widget; - The_Label : in Widget_Label_Str) return Boolean; - -private - type Label_Widget is new Color_Widget with - record - Label : Widget_Label_Str; - end record; - -end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg - ---=======================================================================-- - -package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg - - procedure Set_Label (The_Widget : in out Label_Widget; - L : in Widget_Label_Str) is - begin - The_Widget.Label := L; - end Set_Label; - -------------------------------------------------------------- - procedure Set_Label_Widget (The_Widget : in out Label_Widget; - The_Width : in Widget_Length; - The_Height : in Widget_Length; - The_Color : in Widget_Color_Enum; - The_Label : in Widget_Label_Str) is - begin - Set_Width (The_Widget, The_Width); -- Twice inherited. - Set_Height (The_Widget, The_Height); -- Twice inherited. - Set_Color (The_Widget, The_Color); -- Inherited from parent. - Set_Label (The_Widget, The_Label); - end Set_Label_Widget; - -------------------------------------------------------------- - function Verify_Label (The_Widget : in Label_Widget; - The_Label : in Widget_Label_Str) return Boolean is - begin - return (The_Widget.Label = The_Label); - end Verify_Label; - -end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg - ---=======================================================================-- - -with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg, - -- implicitly with Widget_Pkg, - -- implicitly with Color_Widget_Pkg -with Report; - -procedure CA11A01 is - - package Widget_Pkg renames FA11A00; - package Color_Widget_Pkg renames FA11A00.CA11A01_0; - package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1; - - use Widget_Pkg; -- All user-defined operators directly visible. - - Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail"; - - Default_Widget : Widget; - Black_Widget : Color_Widget_Pkg.Color_Widget; - Mail_Widget : Label_Widget_Pkg.Label_Widget; - -begin - - Report.Test ("CA11A01", "Check that type extended in a public " & - "child inherits primitive operations from its " & - "ancestor"); - - Set_Width (Default_Widget, 9); -- Call from parent. - Set_Height (Default_Widget, 10); -- Call from parent. - - If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or - Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then - Report.Failed ("Incorrect result for Default_Widget"); - end if; - - Color_Widget_Pkg.Set_Color_Widget - (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared. - - If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or - Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or - Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then - Report.Failed ("Incorrect result for Black_Widget"); - end if; - - Label_Widget_Pkg.Set_Label_Widget - (Mail_Widget, 15, 21, Color_Widget_Pkg.White, - "Quick_Mail"); -- Explicitly declared. - - If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or - Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or - Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or - not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then - Report.Failed ("Incorrect result for Mail_Widget"); - end if; - - Report.Result; - -end CA11A01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a deleted file mode 100644 index e7c161423fb..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a +++ /dev/null @@ -1,156 +0,0 @@ --- CA11A02.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 type extended in a client of a public child inherits --- primitive operations from parent. --- --- TEST DESCRIPTION: --- Declare a root tagged type in a package specification. Declare two --- primitive subprograms for the type (foundation code). --- --- Add a public child to the above package. Extend the root type with --- a record extension in the specification. Declare a new primitive --- subprogram to write to the child extension. --- --- In the main program, "with" the child. Declare an extension of --- the child extension. Access the primitive operations from both --- parent and child packages. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level --- ---! - -package FA11A00.CA11A02_0 is -- Color_Widget_Pkg --- This public child declares an extension from its parent. It --- represents processing of widgets in a window system. - - type Widget_Color_Enum is (Black, Green, White); - - type Color_Widget is new Widget with -- Record extension of - record -- parent tagged type. - Color : Widget_Color_Enum; - end record; - - -- Inherits procedure Set_Width from parent. - -- Inherits procedure Set_Height from parent. - - -- To be inherited by its derivatives. - procedure Set_Color (The_Widget : in out Color_Widget; - C : in Widget_Color_Enum); - -end FA11A00.CA11A02_0; -- Color_Widget_Pkg - ---=======================================================================-- - -package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg - - procedure Set_Color (The_Widget : in out Color_Widget; - C : in Widget_Color_Enum) is - begin - The_Widget.Color := C; - end Set_Color; - -end FA11A00.CA11A02_0; -- Color_Widget_Pkg - ---=======================================================================-- - -with FA11A00.CA11A02_0; -- Color_Widget_Pkg. - -package CA11A02_1 is - - type Label_Widget (Str_Disc : Integer) is new - FA11A00.CA11A02_0.Color_Widget with - record - Label : String (1 .. Str_Disc); - end record; - - -- Inherits (inherited) procedure Set_Width from Color_Widget. - -- Inherits (inherited) procedure Set_Height from Color_Widget. - -- Inherits procedure Set_Color from Color_Widget. - -end CA11A02_1; - ---=======================================================================-- - -with FA11A00.CA11A02_0; -- Color_Widget_Pkg, - -- implicitly with Widget_Pkg -with CA11A02_1; - -with Report; - -procedure CA11A02 is - - package Widget_Pkg renames FA11A00; - package Color_Widget_Pkg renames FA11A00.CA11A02_0; - - use Widget_Pkg; -- All user-defined operators directly visible. - - procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget; - L : in String) is - begin - The_Widget.Label := L; - end Set_Label; - --------------------------------------------------------- - procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget; - The_Width : in Widget_Length; - The_Height : in Widget_Length; - The_Color : in - Color_Widget_Pkg.Widget_Color_Enum; - The_Label : in String) is - begin - CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited. - CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited. - CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited. - Set_Label (The_Widget, The_Label); -- Explicitly declared. - end Set_Widget; - - White_Widget : CA11A02_1.Label_Widget (11); - -begin - - Report.Test ("CA11A02", "Check that a type extended in a client of " & - "a public child inherits primitive operations from parent"); - - Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock"); - - If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or - White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or - Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or - White_Widget.Label /= "Alarm_Clock" then - Report.Failed ("Incorrect result for White_Widget"); - end if; - - Report.Result; - -end CA11A02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a deleted file mode 100644 index 8d6de02f1b6..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a +++ /dev/null @@ -1,208 +0,0 @@ --- CA11B01.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 type derived in a public child inherits primitive --- operations from parent. --- --- TEST DESCRIPTION: --- Declare a root record type with discriminant in a package --- specification. Declare a primitive subprogram for the type --- (foundation code). --- --- Add a public child to the above package. Derive a new type --- with constraint to the discriminant record type from the parent --- package. Declare a new primitive subprogram to write to the child --- derived type. --- --- Add a new public child to the above package. This grandchild package --- derives a new type using the record type from the above package. --- Declare a new primitive subprogram to write to the grandchild derived --- type. --- --- In the main program, "with" the grandchild. Access the inherited --- operations from grandparent, parent, and grandchild packages. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11B00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Child package of FA11B00. -package FA11B00.CA11B01_0 is -- Application_Two_Widget --- This public child declares a derived type from its parent. It --- represents processing of widgets in a window system. - - type App2_Widget is new App1_Widget (Maximum_Size => 5000); - -- Inherits procedure Create_Widget from parent. - - -- Primitive operation of type App2_Widget. - -- To be inherited by its children derivatives. - procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget; - Loc : in Widget_Location); - -end FA11B00.CA11B01_0; -- Application_Two_Widget - ---=======================================================================-- - -package body FA11B00.CA11B01_0 is -- Application_Two_Widget - - procedure App2_Widget_Specific_Oper - (The_Widget : in out App2_Widget; - Loc : in Widget_Location) is - begin - The_Widget.Location := Loc; - end App2_Widget_Specific_Oper; - -end FA11B00.CA11B01_0; -- Application_Two_Widget - ---=======================================================================-- - --- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0. -package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget --- This public grandchild declares a derived type from its parent. It --- represents processing of widgets in a window system. - - type App3_Widget is new App2_Widget; -- Derived record of App2_Widget. - - -- Inherits (inherited) procedure Create_Widget from Application_One_Widget. - -- Inherits procedure App2_Widget_Specific_Oper from App2_Widget. - - -- Primitive operation of type App3_Widget. - procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget; - S : in Widget_Size); - -end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget - ---=======================================================================-- - -package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget - - procedure App3_Widget_Specific_Oper - (The_Widget : in out App3_Widget; - S : in Widget_Size) is - begin - The_Widget.Size := S; - end App3_Widget_Specific_Oper; - -end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget - ---=======================================================================-- - -with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget, - -- implicitly with Application_Two_Widget, - -- implicitly with Application_Three_Widget. -with Report; - -procedure CA11B01 is - - package Application_One_Widget renames FA11B00; - package Application_Two_Widget renames FA11B00.CA11B01_0; - package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1; - - use Application_One_Widget; - use Application_Two_Widget; - use Application_Three_Widget; - -begin - - Report.Test ("CA11B01", "Check that a type derived in a public " & - "child inherits primitive operations from parent"); - - Application_One_Subtest: - declare - White_Widget : App1_Widget; - - begin - -- perform an App1_Widget specific operation. - App1_Widget_Specific_Oper (C => White, L => "Line Editor ", - The_Widget => White_Widget, I => 10); - - If White_Widget.Color /= White or - White_Widget.Id /= Widget_ID - (Report.Ident_Int (10)) or - White_Widget.Label /= "Line Editor " then - Report.Failed ("Incorrect result for White_Widget"); - end if; - - end Application_One_Subtest; - --------------------------------------------------------------- - Application_Two_Subtest: - declare - Amber_Widget : App2_Widget; - - begin - App1_Widget_Specific_Oper (Amber_Widget, I => 11, - C => Amber, L => "Alarm_Clock "); - -- Inherited from Application_One_Widget. - - -- perform an App2_Widget specific operation. - App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512)); - - If Amber_Widget.Color /= Amber or - Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or - Amber_Widget.Label /= "Alarm_Clock " or - Amber_Widget.Location /= (380,512) then - Report.Failed ("Incorrect result for Amber_Widget"); - end if; - - end Application_Two_Subtest; - --------------------------------------------------------------- - Application_Three_Subtest: - declare - Green_Widget : App3_Widget; - - begin - App1_Widget_Specific_Oper (Green_Widget, 100, Green, - "Screen Editor "); - -- Inherited (inherited) from Basic_Widget. - - -- perform an App2_Widget specific operation. - App2_Widget_Specific_Oper (Loc => (1024,760), - The_Widget => Green_Widget); - -- Inherited from App_1_Widget. - - -- perform an App3_Widget specific operation. - App3_Widget_Specific_Oper (Green_Widget, S => (100,100)); - - If Green_Widget.Color /= Green or - Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or - Green_Widget.Label /= "Screen Editor " or - Green_Widget.Location /= (1024,760) or - Green_Widget.Size /= (100,100) then - Report.Failed ("Incorrect result for Green_Widget"); - end if; - - end Application_Three_Subtest; - - Report.Result; - -end CA11B01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a deleted file mode 100644 index 0743f73336b..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a +++ /dev/null @@ -1,169 +0,0 @@ --- CA11B02.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 type derived in a client of a public child inherits --- primitive operations from parent. --- --- TEST DESCRIPTION: --- Declare a root record type with discriminant in a package --- specification. Declare a primitive subprogram for the type --- (foundation code). --- --- Add a public child to the above package. Derive a new type --- with constraint to the discriminant record type from the parent --- package. Declare a new primitive subprogram to write to the child --- derived type. --- --- In the main program, "with" the child. Derive a new type using the --- record type from the child package. Access the inherited operations --- from both parent and child packages. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11B00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Child package of FA11B00. -package FA11B00.CA11B02_0 is -- Application_Two_Widget --- This public child declares a derived type from its parent. It --- represents processing of widgets in a window system. - - -- Dimension of app2_widget is limited to 5000 pixels. - - type App2_Widget is new App1_Widget (Maximum_Size => 5000); - -- Derived record of parent type. - - -- Inherits procedure App1_Widget_Specific_Oper from parent. - - - -- Primitive operation of type App2_Widget. - - procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; - S : in Widget_Size); - - -- Primitive operation of type App2_Widget. - - procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; - Loc : in Widget_Location); - -end FA11B00.CA11B02_0; -- Application_Two_Widget - - ---=======================================================================-- - - -package body FA11B00.CA11B02_0 is -- Application_Two_Widget - - procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; - S : in Widget_Size) is - begin - The_Widget.Size := S; - end App2_Widget_Specific_Op1; - - --==============================================-- - - procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; - Loc : in Widget_Location) is - begin - The_Widget.Location := Loc; - end App2_Widget_Specific_Op2; - -end FA11B00.CA11B02_0; -- Application_Two_Widget - - ---=======================================================================-- - -with FA11B00.CA11B02_0; -- Application_Two_Widget - -- implicitly with Application_One_Widget. -with Report; - -procedure CA11B02 is - - package Application_One_Widget renames FA11B00; - - package Application_Two_Widget renames FA11B00.CA11B02_0; - - use Application_One_Widget ; - use Application_Two_Widget ; - - type Emulator_Widget is new App2_Widget; -- Derived record of - -- parent type. - - White_Widget, Amber_Widget : Emulator_Widget; - - -begin - - Report.Test ("CA11B02", "Check that a type derived in client of a " & - "public child inherits primitive operations from parent"); - - App1_Widget_Specific_Oper (C => White, L => "Line Editor ", - The_Widget => White_Widget, I => 10); - -- Inherited from Application_One_Widget. - If White_Widget.Color /= White or - White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or - White_Widget.Label /= "Line Editor " - then - Report.Failed ("Incorrect result for White_Widget"); - end if; - - -- perform an App2_Widget specific operation. - - App2_Widget_Specific_Op1 (White_Widget, S => (100, 200)); - - If White_Widget.Size.X_Length /= 100 or - White_Widget.Size.Y_Length /= 200 - then - Report.Failed ("Incorrect size for White_Widget"); - end if; - - App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor "); - -- Inherited from Application_One_Widget. - - -- perform an App2_Widget specific operations. - - App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget); - App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760)); - - If Amber_Widget.Color /= Amber or - Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or - Amber_Widget.Label /= "Screen Editor " or - Amber_Widget.Size /= (1024,100) or - Amber_Widget.Location.X_Location /= 1024 or - Amber_Widget.Location.Y_Location /= 760 - then - Report.Failed ("Incorrect result for Amber_Widget"); - end if; - - Report.Result; - -end CA11B02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a deleted file mode 100644 index 195ec2d40e8..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a +++ /dev/null @@ -1,170 +0,0 @@ --- CA11C01.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 when primitive operations declared in a child package --- override operations declared in ancestor packages, a client of the --- child package inherits the operations correctly. --- --- TEST DESCRIPTION: --- --- This test builds on the foundation code file (FA11C00) that contains --- a parent package, child package, and grandchild package. The parent --- package declares a tagged type and primitive operation. The child --- package extends the type, and overrides the primitive operation. The --- grandchild package does the same. --- --- The test procedure "withs" the grandchild package, and receives --- visibility to all of its ancestor packages, types and operations. --- Three procedures, each with a formal parameter of a specific type are --- defined. Each of these invokes a particular version of the overridden --- primitive operation Image. Calls to these local procedures are made, --- with objects of each of the tagged types as parameters, and the global --- variable is finally examined to ensure that the correct version of --- primitive operation was inherited by the client and invoked by the --- call. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11C00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate -with Report; - -procedure CA11C01 is - - package Animal_Package renames FA11C00_0; - package Mammal_Package renames FA11C00_0.FA11C00_1; - package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; - - Max_Animals : constant := 3; - - subtype Data_String is String (1 .. 37); - type Data_Base_Type is array (1 .. Max_Animals) of Data_String; - - Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); - -- Global variable. - - Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ", - Weight => 10); - - Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ", - Weight => 13, - Hair_Color => Mammal_Package.Brown); - - Orangutan : Primate_Package.Primate := - (Common_Name => "Sumatran Orangutan ", - Weight => 220, - Hair_Color => Mammal_Package.Red, - Habitat => Primate_Package.Arboreal); -begin - - Report.Test ("CA11C01", "Check that when primitive operations declared " & - "in a child package override operations declared " & - "in ancestor packages, a client of the child " & - "package inherits the operations correctly"); - - declare - - use Animal_Package, Mammal_Package, Primate_Package; - - -- The function Image has been overridden in the child and grandchild - -- packages, but the client has inherited all versions of the function, - -- and can successfully use them to enter data into the database. - -- Each of the following procedures updates the global variable - -- Zoo_Data_Base. - - procedure Enter_Animal_Data (A : Animal; I : Integer) is - begin - Zoo_Data_Base (I) := Image (A); - end Enter_Animal_Data; - - procedure Enter_Mammal_Data (M : Mammal; I : Integer) is - begin - Zoo_Data_Base (I) := Image (M); - end Enter_Mammal_Data; - - procedure Enter_Primate_Data (P : Primate; I : Integer) is - begin - Zoo_Data_Base (I) := Image (P); - end Enter_Primate_Data; - - begin - - -- Verify initial test conditions. - - if not (Zoo_Data_Base(1)(1..6) = " ") - or else - (Zoo_Data_Base(2)(1..6) /= " ") - or else - (Zoo_Data_Base(3)(1..6) /= " ") - then - Report.Failed ("Initial condition failure"); - end if; - - - -- Enter data from all three animals into the zoo database. - - Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database. - Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry. - Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry. - - -- Verify the correct version of the overridden function Image was used - -- for entering the specific data. - - if Zoo_Data_Base(1)(1 .. 6) /= "Animal" - or else - Zoo_Data_Base(1)(26 .. 31) /= "Salmon" - then - Report.Failed ("Incorrect version of Image for parent type"); - end if; - - if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal") - or - (Zoo_Data_Base(2)(28 .. 35) /= "Platypus") - then - Report.Failed ("Incorrect version of Image for child type"); - end if; - - if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate") - or - (Zoo_Data_Base(3)(27 .. 35) /= "Orangutan")) - then - Report.Failed ("Incorrect version of Image for grandchild type"); - end if; - - end; - - - Report.Result; - -end CA11C01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a deleted file mode 100644 index 7d8749328c0..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a +++ /dev/null @@ -1,158 +0,0 @@ --- CA11C02.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 primitive operations declared in a child package --- override operations declared in ancestor packages, and that --- operations on class-wide types defined in the ancestor packages --- dispatch as appropriate to these overriding implementations. --- --- TEST DESCRIPTION: --- --- This test builds on the foundation code file (FA11C00) that contains --- a parent package, child package, and grandchild package. The parent --- package declares a tagged type and primitive operation. The child --- package extends the type, and overrides the primitive operation. The --- grandchild package does the same. --- --- The test procedure "withs" the grandchild package, and receives --- visibility to all of its ancestor packages, types and operations. --- A procedure with a formal class-wide parameter is defined that will --- allow for dispatching calls to the overridden primitive operations, --- based on the specific type of the actual parameter. The primitive --- operations provide a string value to update a global string array --- variable. Calls to the local procedure are made, with objects of each --- of the tagged types as parameters, and the global variable is finally --- examined to ensure that the correct version of primitive operation was --- dispatched correctly. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11C00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate -with Report; - -procedure CA11C02 is - - package Animal_Package renames FA11C00_0; - package Mammal_Package renames FA11C00_0.FA11C00_1; - package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; - - Max_Animals : constant := 3; - - type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37); - - Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); - -- Global variable. - - Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ", - Weight => 2); - - Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ", - Weight => 230, - Hair_Color => Mammal_Package.Brown); - - Lemur : Primate_Package.Primate := - (Common_Name => "Ring-Tailed Lemur ", - Weight => 5, - Hair_Color => Mammal_Package.Black, - Habitat => Primate_Package.Arboreal); -begin - - Report.Test ("CA11C02", "Check that primitive operations declared " & - "in a child package override operations declared " & - "in ancestor packages, and that operations " & - "on class-wide types defined in the ancestor " & - "packages dispatch as appropriate to these " & - "overriding implementations"); - - declare - - use Animal_Package, Mammal_Package, Primate_Package; - - -- The following procedure updates the global variable Zoo_Data_Base. - - procedure Enter_Data (A : Animal'Class; I : Integer) is - begin - Zoo_Data_Base (I) := Image (A); - end Enter_Data; - - begin - - -- Verify initial test conditions. - - if not (Zoo_Data_Base(1)(1..6) = " ") - or not - (Zoo_Data_Base(2)(1..6) = " ") - or not - (Zoo_Data_Base(3)(1..6) = " ") - then - Report.Failed ("Initial condition failure"); - end if; - - - -- Enter data from all three animals into the zoo database. - - Enter_Data (Macaw, 1); -- First entry in database. - Enter_Data (A => Manatee, I => 2); -- Second entry. - Enter_Data (Lemur, I => 3); -- Third entry. - - -- Verify the correct version of the overridden function Image was used - -- for entering the specific data. - - if not (Zoo_Data_Base(1)(1 .. 6) = "Animal") - or not - (Zoo_Data_Base(1)(26 .. 30) = "Macaw") - then - Report.Failed ("Incorrect version of Image for parent type"); - end if; - - if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal" - and - Zoo_Data_Base(2)(27 .. 33) = "Manatee") - then - Report.Failed ("Incorrect version of Image for child type"); - end if; - - if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate") - and - (Zoo_Data_Base(3)(30 .. 34) = "Lemur")) - then - Report.Failed ("Incorrect version of Image for grandchild type"); - end if; - - end; - - Report.Result; - -end CA11C02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a deleted file mode 100644 index b75a6603483..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a +++ /dev/null @@ -1,186 +0,0 @@ --- CA11C03.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 when a child unit is "withed", visibility is obtained to --- all ancestor units named in the expanded name of the "withed" child --- unit. Check that when the parent unit is "used", the simple name of --- a "withed" child unit is made directly visible. --- --- TEST DESCRIPTION: --- To satisfy the first part of the objective, various references are --- made to types and functions declared in the ancestor packages of the --- foundation code package hierarchy. Since the grandchild library unit --- package has been "withed" by this test, the visibility of these --- components demonstrates that visibility of the ancestor package names --- is provided when the expanded name of a child library unit is "withed". --- --- The declare block in the test program includes a "use" clause of the --- parent package (FA11C00_0.FA11C00_1) of the "withed" child package. --- As a result, the simple name of the child package (FA11C00_2) is --- directly visible. The type and function declared in the child --- package are now visible when qualified with the simple name of the --- "withed" package (FA11C00_2). --- --- This test simulates the formatting of data strings, based on the --- component fields of a "doubly-extended" tagged record type. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11C00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package - -- Animal.Mammal.Primate. - -- This will be used in conjunction with - -- a "use" of FA11C00_0.FA11C00_1 below - -- to verify a portion of the objective. -with Report; - -procedure CA11C03 is - - Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' '); - -- Visibility of grandparent package. - -- The package FA11C00_0 is visible since - -- it is an ancestor that is mentioned in - -- the expanded name of its "withed" - -- grandchild package. - - Blank_Hair_Color : - String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' '); - -- Visibility of parent package. - -- The package FA11C00_0.FA11C00_1 is - -- visible due to the "with" of its - -- child package. - - subtype Data_String_Type is String (1 .. 60); - - TC_Result_String : Data_String_Type := (others => ' '); - - -- - - function Format_Primate_Data (Name : String := Blank_Name_String; - Hair : String := Blank_Hair_Color) - return Data_String_Type is - - Pos : Integer := 1; - Hair_Color_Field_Separator : constant String := " Hair Color: "; - - Result_String : Data_String_Type := (others => ' '); - - begin - Result_String (Pos .. Name'Length) := Name; -- Enter name at start - -- of string. - Pos := Pos + Name'Length; -- Increment counter to - -- next blank position. - Result_String - (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) := - Hair_Color_Field_Separator & Hair; -- Include hair color data - -- in result string. - return (Result_String); - end Format_Primate_Data; - - -begin - - Report.Test ("CA11C03", "Check that when a child unit is WITHED, " & - "visibility is obtained to all ancestor units " & - "named in the expanded name of the WITHED child " & - "unit. Check that when the parent unit is USED, " & - "the simple name of a WITHED child unit is made " & - "directly visible" ); - - declare - use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct - -- visibility to the simple name of - -- package FA11C00_0.FA11C00_1.FA11C00_2, - -- since this child package was "withed" by - -- the main program. - - Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ", - Weight => 7, - Hair_Color => Brown, - Habitat => FA11C00_2.Arboreal); - - -- Demonstrates visibility of package - -- FA11C00_0.FA11C00_1.FA11C00_2. - -- - -- Type Primate referenced with the simple - -- name of package FA11C00_2 only. - -- - -- Simple name of package FA11C00_2 is - -- directly visible through "use" of parent. - - begin - - -- Verify that the Format_Primate_Data function will return a blank - -- filled string when no parameters are provided in the call. - - TC_Result_String := Format_Primate_Data; - - if (TC_Result_String (1 .. 20) /= Blank_Name_String) then - Report.Failed ("Incorrect initialization value from function"); - end if; - - - -- Use function Format_Primate_Data to return a formatted data string. - - TC_Result_String := - Format_Primate_Data - (Name => FA11C00_2.Image (Tarsier), - -- Function returns a 37 character string - -- value. - Hair => Hair_Color_Type'Image(Tarsier.Hair_Color)); - -- The Hair_Color_Type is referenced - -- directly, without package - -- FA11C00_0.FA11C00_1 qualifier. - -- No qualification of Hair_Color_Type is - -- needed due to "use" clause. - - -- Note that the result of calling 'Image - -- with an enumeration type argument - -- results in an upper-case string. - -- (See conditional statement below.) - - -- Verify the results of the function call. - - if not (TC_Result_String (1 .. 37) = - "Primate Species: East-Indian Tarsier " and then - TC_Result_String (38 .. 55) = - " Hair Color: BROWN") then - Report.Failed ("Incorrect result returned from function call"); - end if; - - end; - - Report.Result; - -end CA11C03; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a deleted file mode 100644 index 7ea0e226775..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a +++ /dev/null @@ -1,119 +0,0 @@ --- CA11D010.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: --- See CA11D013.AM --- --- TEST DESCRIPTION: --- See CA11D013.AM --- --- TEST FILES: --- The following files comprise this test: --- --- FA11D00.A --- => CA11D010.A --- CA11D011.A --- CA11D012.A --- CA11D013.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. --- ---! - --- Child package of FA11D00. - -package FA11D00.CA11D010 is -- Add_Subtract_Complex - - procedure Add (Left, Right : in Complex_Type; -- Add two complex - C : out Complex_Type); -- numbers. - - function Subtract (Left, Right : Complex_Type) -- Subtract two - return Complex_Type; -- complex numbers. - - - -end FA11D00.CA11D010; -- Add_Subtract_Complex - ---=======================================================================-- - -with Report; - -package body FA11D00.CA11D010 is -- Add_Subtract_Complex - - procedure Add (Left, Right : in Complex_Type; - C : out Complex_Type) is - begin - -- Zero is declared in parent package. - - if Left.Real < Zero.Real or else Right.Real < Zero.Real - or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then - raise Add_Error; -- Reference to exception in parent package. - Report.Failed ("Program control not transferred by raise in " & - "procedure Add"); - else - C.Real := (Left.Real + Right.Real); - C.Imag := (Left.Imag + Right.Imag); - end if; - - exception - when Add_Error => - TC_Handled_In_Child_Pkg_Proc := true; - C := Check_Value; -- Reference to object in parent package. - raise; -- Reraise the Add_Error exception in the subtest. - Report.Failed ("Exception not reraised in handler"); - - when others => - Report.Failed ("Unexpected exception raised in Add"); - - end Add; - ----------------------------------------------------------- - function Subtract (Left, Right : Complex_Type) - return Complex_Type is - begin - -- Zero is declared in parent package. - if Left.Real < Zero.Real or Right.Real < Zero.Real - or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then - raise Subtract_Error; -- Reference to exception in parent package. - Report.Failed ("Program control not transferred by raise in " & - "function Subtract"); - else - return ( Real => (Left.Real - Right.Real), - Imag => (Left.Imag - Right.Imag) ); - end if; - - exception - when Subtract_Error => - Report.Comment ("Exception is properly handled in Subtract"); - TC_Handled_In_Child_Pkg_Func := true; - return Check_Value; - - when others => - Report.Failed ("Unexpected exception raised in Subtract"); - - end Subtract; - -end FA11D00.CA11D010; -- Add_Subtract_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a deleted file mode 100644 index 014f74be78a..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a +++ /dev/null @@ -1,79 +0,0 @@ --- CA11D011.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: --- See CA11D013.AM --- --- TEST DESCRIPTION: --- See CA11D013.AM --- --- TEST FILES: --- The following files comprise this test: --- --- FA11D00.A --- CA11D010.A --- => CA11D011.A --- CA11D012.A --- CA11D013.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Dec 94 SAIC Declared child procedure specification --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with Report; - - --- Child procedure of FA11D00. - -procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; - C : out Complex_Type); - ---=======================================================================-- - -procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; - C : out Complex_Type) is --- Multiply_Complex. - -begin - -- Zero is declared in parent package. - - if Left.Real < Zero.Real or Right.Imag < Zero.Imag then - raise Multiply_Error; -- Reference to exception in parent package. - Report.Failed ("Program control not transferred by raise in " & - "child procedure FA11D00.CA11D011"); - else - C.Real := (Left.Real * Right.Real); - C.Imag := (Left.Imag * Right.Imag); - end if; - - exception - when others => - TC_Handled_In_Child_Sub := true; - C := Check_Value; -- Reference to object in parent package. - -end FA11D00.CA11D011; -- Multiply_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a deleted file mode 100644 index 1bb3bd7ac02..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a +++ /dev/null @@ -1,73 +0,0 @@ --- CA11D012.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: --- See CA11D013.AM --- --- TEST DESCRIPTION: --- See CA11D013.AM --- --- TEST FILES: --- The following files comprise this test: --- --- FA11D00.A --- CA11D010.A --- CA11D011.A --- => CA11D012.A --- CA11D013.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 21 Dec 94 SAIC Declared child function specification --- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with Report; - --- Child function of FA11D00. --- Does not divide zero complex numbers. - -function FA11D00.CA11D012 (Left, Right : Complex_Type) - return Complex_Type; - ---=======================================================================-- - -function FA11D00.CA11D012 (Left, Right : Complex_Type) - return Complex_Type is -- Divide_Complex - -begin - -- Zero is declared in parent package. - - if Right.Real = Zero.Real or Right.Imag = Zero.Imag then - raise Divide_Error; -- Reference to exception in parent package. - Report.Failed ("Program control not transferred by raise in " & - "child function FA11D00.CA11D012"); - else - return ( Real => (Left.Real / Right.Real), - Imag => (Left.Imag / Right.Imag) ); - end if; - -end FA11D00.CA11D012; -- Divide_Complex diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a deleted file mode 100644 index 7b4f48869b2..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a +++ /dev/null @@ -1,393 +0,0 @@ --- CA11D02.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 an exception declared in a package can be raised by a --- child of a child package. Check that it can be renamed in the --- child of the child package and raised with the correct effect. --- --- TEST DESCRIPTION: --- Declare a package which defines complex number abstraction with --- user-defined exceptions (foundation code). --- --- Add a public child package to the above package. Declare two --- subprograms for the parent type. --- --- Add a public grandchild package to the foundation package. Declare --- subprograms to raise exceptions. --- --- In the main program, "with" the grandchild package, then check that --- the exceptions are raised and handled as expected. Ensure that --- exceptions are: --- 1) raised in the public grandchild package and handled/reraised to --- be handled by the main program. --- 2) raised and handled locally by the "others" handler in the --- public grandchild package. --- 3) raised in the public grandchild and propagated to the main --- program. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11D00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Child package of FA11D00. - -package FA11D00.CA11D02_0 is -- Basic_Complex - - function "+" (Left, Right : Complex_Type) - return Complex_Type; -- Add two complex numbers. - - function "*" (Left, Right : Complex_Type) - return Complex_Type; -- Multiply two complex numbers. - -end FA11D00.CA11D02_0; -- Basic_Complex - ---=======================================================================-- - -package body FA11D00.CA11D02_0 is -- Basic_Complex - - function "+" (Left, Right : Complex_Type) return Complex_Type is - begin - return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); - end "+"; - -------------------------------------------------------------- - function "*" (Left, Right : Complex_Type) return Complex_Type is - begin - return ( Real => (Left.Real * Right.Real), - Imag => (Left.Imag * Right.Imag) ); - end "*"; - -end FA11D00.CA11D02_0; -- Basic_Complex - ---=======================================================================-- - --- Child package of FA11D00.CA11D02_0. --- Grandchild package of FA11D00. - -package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex - - Inverse_Error : exception renames Divide_Error; -- Reference to exception - -- in grandparent package. - Array_Size : constant := 2; - - type Complex_Array_Type is - array (1 .. Array_Size) of Complex_Type; -- Reference to type - -- in parent package. - - function Multiply (Left : Complex_Array_Type; -- Multiply two complex - Right : Complex_Array_Type) -- arrays. - return Complex_Array_Type; - - function Add (Left, Right : Complex_Array_Type) -- Add two complex - return Complex_Array_Type; -- arrays. - - procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex - Left : in out Complex_Array_Type); -- array. - -end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex - ---=======================================================================-- - -with Report; - - -package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex - - function Multiply (Left : Complex_Array_Type; - Right : Complex_Array_Type) - return Complex_Array_Type is - - -- This procedure will raise an exception depending on the input - -- parameter. The exception will be handled locally by the - -- "others" handler. - - Result : Complex_Array_Type := (others => Zero); - - subtype Vector_Size is Positive range Left'Range; - - begin - if Left = Result or else Right = Result then -- Do not multiply zero. - raise Multiply_Error; -- Refence to exception in - -- grandparent package. - Report.Failed ("Program control not transferred by raise"); - else - for I in Vector_Size loop - Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*". - end loop; - end if; - return (Result); - - exception - when others => - Report.Comment ("Exception is handled by others in Multiplication"); - TC_Handled_In_Grandchild_Pkg_Func := true; - return (Zero, Zero); - - end Multiply; - -------------------------------------------------------------- - function Add (Left, Right : Complex_Array_Type) - return Complex_Array_Type is - - -- This function will raise an exception depending on the input - -- parameter. The exception will be propagated and handled - -- by the caller. - - Result : Complex_Array_Type := (others => Zero); - - subtype Vector_Size is Positive range Left'Range; - - begin - if Left = Result or Right = Result then -- Do not add zero. - raise Add_Error; -- Refence to exception in - -- grandparent package. - Report.Failed ("Program control not transferred by raise"); - else - for I in Vector_Size loop - Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+". - end loop; - end if; - return (Result); - - end Add; - -------------------------------------------------------------- - procedure Inverse (Right : in Complex_Array_Type; - Left : in out Complex_Array_Type) is - - -- This function will raise an exception depending on the input - -- parameter. The exception will be handled/reraised to be - -- handled by the caller. - - Result : Complex_Array_Type := (others => Zero); - - Array_With_Zero : boolean := false; - - begin - for I in 1 .. Right'Length loop - if Right(I) = Zero then -- Check for zero. - Array_With_Zero := true; - end if; - end loop; - - If Array_With_Zero then - raise Inverse_Error; -- Do not inverse zero. - Report.Failed ("Program control not transferred by raise"); - else - for I in 1 .. Array_Size loop - Left(I).Real := - Right(I).Real; - Left(I).Imag := - Right(I).Imag; - end loop; - end if; - - exception - when Inverse_Error => - TC_Handled_In_Grandchild_Pkg_Proc := true; - Left := Result; - raise; -- Reraise the Inverse_Error exception in the subtest. - Report.Failed ("Exception not reraised in handler"); - - when others => - Report.Failed ("Unexpected exception in procedure Inverse"); - end Inverse; - -end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex - ---=======================================================================-- - -with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex, - -- implicitly with Basic_Complex. -with Report; - -procedure CA11D02 is - - package Complex_Pkg renames FA11D00; - package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1; - - use Complex_Pkg; - use Array_Complex_Pkg; - -begin - - Report.Test ("CA11D02", "Check that an exception declared in a package " & - "can be raised by a child of a child package"); - - Multiply_Complex_Subtest: - declare - Operand_1 : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (5))), - Complex (Int_Type (Report.Ident_Int (2)), - Int_Type (Report.Ident_Int (8))) ); - Operand_2 : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (1)), - Int_Type (Report.Ident_Int (2))), - Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (6))) ); - Operand_3 : Complex_Array_Type := ( Zero, Zero); - Mul_Result : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (10))), - Complex (Int_Type (Report.Ident_Int (6)), - Int_Type (Report.Ident_Int (48))) ); - Complex_No : Complex_Array_Type := (others => Zero); - - begin - If (Multiply (Operand_1, Operand_2) /= Mul_Result) then - Report.Failed ("Incorrect results from multiplication"); - end if; - - -- Error is raised and exception will be handled in grandchild package. - - Complex_No := Multiply (Operand_1, Operand_3); - - if Complex_No /= (Zero, Zero) then - Report.Failed ("Exception was not raised in multiplication"); - end if; - - exception - when Multiply_Error => - Report.Failed ("Exception raised in multiplication and " & - "propagated to caller"); - TC_Handled_In_Grandchild_Pkg_Func := false; - -- Improper exception handling in caller. - - when others => - Report.Failed ("Unexpected exception in multiplication"); - TC_Handled_In_Grandchild_Pkg_Func := false; - -- Improper exception handling in caller. - - end Multiply_Complex_Subtest; - - - Add_Complex_Subtest: - declare - Operand_1 : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (2)), - Int_Type (Report.Ident_Int (7))), - Complex (Int_Type (Report.Ident_Int (5)), - Int_Type (Report.Ident_Int (8))) ); - Operand_2 : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (4)), - Int_Type (Report.Ident_Int (1))), - Complex (Int_Type (Report.Ident_Int (2)), - Int_Type (Report.Ident_Int (3))) ); - Operand_3 : Complex_Array_Type := ( Zero, Zero); - Add_Result : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (6)), - Int_Type (Report.Ident_Int (8))), - Complex (Int_Type (Report.Ident_Int (7)), - Int_Type (Report.Ident_Int (11))) ); - Complex_No : Complex_Array_Type := (others => Zero); - - begin - Complex_No := Add (Operand_1, Operand_2); - - If (Complex_No /= Add_Result) then - Report.Failed ("Incorrect results from addition"); - end if; - - -- Error is raised in grandchild package and exception - -- will be propagated to caller. - - Complex_No := Add (Operand_1, Operand_3); - - if Complex_No = Add_Result then - Report.Failed ("Exception was not raised in addition"); - end if; - - exception - when Add_Error => - TC_Propagated_To_Caller := true; -- Exception is propagated. - - when others => - Report.Failed ("Unexpected exception in addition subtest"); - TC_Propagated_To_Caller := false; -- Improper exception handling - -- in caller. - end Add_Complex_Subtest; - - Inverse_Complex_Subtest: - declare - Operand_1 : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (1)), - Int_Type (Report.Ident_Int (5))), - Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (11))) ); - Operand_3 : Complex_Array_Type - := ( Zero, Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (6))) ); - Inv_Result : Complex_Array_Type - := ( Complex (Int_Type (Report.Ident_Int (-1)), - Int_Type (Report.Ident_Int (-5))), - Complex (Int_Type (Report.Ident_Int (-3)), - Int_Type (Report.Ident_Int (-11))) ); - Complex_No : Complex_Array_Type := (others => Zero); - - begin - Inverse (Operand_1, Complex_No); - - if (Complex_No /= Inv_Result) then - Report.Failed ("Incorrect results from inverse"); - end if; - - -- Error is raised in grandchild package and exception - -- will be handled/reraised to caller. - - Inverse (Operand_3, Complex_No); - - Report.Failed ("Exception was not handled in inverse"); - - exception - when Inverse_Error => - if not TC_Handled_In_Grandchild_Pkg_Proc then - Report.Failed ("Exception was not raised in inverse"); - else - TC_Handled_In_Caller := true; -- Exception is reraised from - -- child package. - end if; - - when others => - Report.Failed ("Unexpected exception in inverse"); - TC_Handled_In_Caller := false; - -- Improper exception handling in caller. - - end Inverse_Complex_Subtest; - - if not (TC_Handled_In_Caller and -- Check to see that all - TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled - TC_Handled_In_Grandchild_Pkg_Func and -- in proper location. - TC_Propagated_To_Caller) - then - Report.Failed ("Exceptions handled in incorrect locations"); - end if; - - Report.Result; - -end CA11D02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a deleted file mode 100644 index 901b8d2174d..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a +++ /dev/null @@ -1,174 +0,0 @@ --- CA11D03.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 an exception declared in a package can be raised by a --- client of a child of the package. Check that it can be renamed in --- the client of the child of the package and raised with the correct --- effect. --- --- TEST DESCRIPTION: --- Declare a package which defines complex number abstraction with --- user-defined exceptions (foundation code). --- --- Add a public child package to the above package. Declare two --- subprograms for the parent type. --- --- In the main program, "with" the child package, then check that --- an exception can be raised and handled as expected. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- FA11D00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Child package of FA11D00. -package FA11D00.CA11D03_0 is -- Basic_Complex - - function "+" (Left, Right : Complex_Type) - return Complex_Type; -- Add two complex numbers. - - function "*" (Left, Right : Complex_Type) - return Complex_Type; -- Multiply two complex numbers. - -end FA11D00.CA11D03_0; -- Basic_Complex - ---=======================================================================-- - -package body FA11D00.CA11D03_0 is -- Basic_Complex - - function "+" (Left, Right : Complex_Type) return Complex_Type is - begin - return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); - end "+"; - -------------------------------------------------------------- - function "*" (Left, Right : Complex_Type) return Complex_Type is - begin - return ( Real => (Left.Real * Right.Real), - Imag => (Left.Imag * Right.Imag) ); - end "*"; - -end FA11D00.CA11D03_0; -- Basic_Complex - ---=======================================================================-- - -with FA11D00.CA11D03_0; -- Basic_Complex, - -- implicitly with Complex_Definition. -with Report; - -procedure CA11D03 is - - package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg - package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex - - use Complex_Pkg; - use Basic_Complex_Pkg; - - TC_Handled_In_Subtest_1, - TC_Handled_In_Subtest_2 : boolean := false; - -begin - - Report.Test ("CA11D03", "Check that an exception declared in a package " & - "can be raised by a client of a child of the package"); - - Multiply_Complex_Subtest: - declare - Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), - Int_Type (Report.Ident_Int (2))); - -- Referenced to function in parent package. - Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)), - Int_Type (Report.Ident_Int (8))); - Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)), - Int_Type (Report.Ident_Int (16))); - Complex_No : Complex_Type := Zero; -- Zero is declared in parent package. - begin - Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*". - if Complex_No /= Mul_Res then - Report.Failed ("Incorrect results from multiplication"); - end if; - - -- Error is raised and exception will be handled. - if Complex_No = Mul_Res then - raise Multiply_Error; -- Reference to exception in - end if; -- parent package. - - exception - when Multiply_Error => - TC_Handled_In_Subtest_1 := true; - when others => - TC_Handled_In_Subtest_1 := false; -- Improper exception handling. - - end Multiply_Complex_Subtest; - - Add_Complex_Subtest: - declare - Error_In_Client : exception renames Add_Error; - -- Reference to exception in parent package. - Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), - Int_Type (Report.Ident_Int (7))); - Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)), - Int_Type (Report.Ident_Int (1))); - Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)), - Int_Type (Report.Ident_Int (8))); - Complex_No : Complex_Type := One; -- One is declared in parent - -- package. - begin - Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+". - - if Complex_No /= Add_Res then - Report.Failed ("Incorrect results from multiplication"); - end if; - - -- Error is raised and exception will be handled. - if Complex_No = Add_Res then - raise Error_In_Client; - end if; - - exception - when Error_In_Client => - TC_Handled_In_Subtest_2 := true; - - when others => - TC_Handled_In_Subtest_2 := false; -- Improper exception handling. - - end Add_Complex_Subtest; - - if not (TC_Handled_In_Subtest_1 and -- Check to see that all - TC_Handled_In_Subtest_2) -- exceptions were handled - -- in the proper location. - then - Report.Failed ("Exceptions handled in incorrect locations"); - end if; - - Report.Result; - -end CA11D03; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13001.a b/gcc/testsuite/ada/acats/tests/ca/ca13001.a deleted file mode 100644 index 094bd7a88e0..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca13001.a +++ /dev/null @@ -1,370 +0,0 @@ --- CA13001.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 separate protected unit declared in a non-generic child --- unit of a private parent have the same visibility into its parent, --- its siblings, and packages on which its parent depends as is available --- at the point of their declaration. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of having all --- members of one family to take out a transportation. The restriction --- is depend on each member to determine who can get a car, a clunker, --- or a bicycle. If no transportation is available, that member has to --- walk. --- --- Declare a package with location for each family member. Declare --- a public parent package. Declare a private child package. Declare a --- public grandchild of this private package. Declare a protected unit --- as a subunit in a public grandchild package. This subunit has --- visibility into it's parent body ancestor and its sibling. --- --- Declare another public parent package. The body of this package has --- visibility into its private sibling's descendants. --- --- In the main program, "with"s the parent package. Check that the --- protected subunit performs as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - -package CA13001_0 is - - type Location is (School, Work, Beach, Home); - type Family is (Father, Mother, Teen); - Destination : array (Family) of Location; - - -- Other type definitions and procedure declarations in real application. - -end CA13001_0; - --- No bodies required for CA13001_0. - - --==================================================================-- - --- Public parent. - -package CA13001_1 is - - type Transportation is (Bicycle, Clunker, New_Car); - type Key_Type is private; - Walking : boolean := false; - - -- Other type definitions and procedure declarations in real application. - -private - type Key_Type - is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car); - -end CA13001_1; - --- No bodies required for CA13001_1. - - --==================================================================-- - --- Private child. - -private package CA13001_1.CA13001_2 is - - type Transport is - record - In_Use : boolean := false; - end record; - Vehicles : array (Transportation) of Transport; - - -- Other type definitions and procedure declarations in real application. - -end CA13001_1.CA13001_2; - --- No bodies required for CA13001_1.CA13001_2. - - --==================================================================-- - --- Public grandchild of a private parent. - -package CA13001_1.CA13001_2.CA13001_3 is - - Flat_Tire : array (Transportation) of boolean := (others => false); - - -- Other type definitions and procedure declarations in real application. - -end CA13001_1.CA13001_2.CA13001_3; - --- No bodies required for CA13001_1.CA13001_2.CA13001_3. - - --==================================================================-- - --- Context clauses required for visibility needed by a separate subunit. - -with CA13001_0; -use CA13001_0; - --- Public grandchild of a private parent. - -package CA13001_1.CA13001_2.CA13001_4 is - - type Transit is - record - Available : boolean := false; - end record; - type Keys_Array is array (Transportation) of Transit; - Fuel : array (Transportation) of boolean := (others => true); - - protected Family_Transportation is - - procedure Get_Vehicle (Who : in Family; - Key : out Key_Type); - procedure Return_Vehicle (Tr : in Transportation); - function TC_Verify (What : Transportation) return boolean; - - private - Keys : Keys_Array; - - end Family_Transportation; - -end CA13001_1.CA13001_2.CA13001_4; - - --==================================================================-- - --- Context clause required for visibility needed by a separate subunit. - -with CA13001_1.CA13001_2.CA13001_3; -- Public sibling. - -package body CA13001_1.CA13001_2.CA13001_4 is - - protected body Family_Transportation is separate; - -end CA13001_1.CA13001_2.CA13001_4; - - --==================================================================-- - -separate (CA13001_1.CA13001_2.CA13001_4) -protected body Family_Transportation is - - procedure Get_Vehicle (Who : in Family; - Key : out Key_Type) is - begin - case Who is - when Father|Mother => - -- Drive new car to work - - -- Reference package with'ed by the subunit parent's body. - if Destination(Who) = Work then - - -- Reference type declared in the private parent of the subunit - -- parent's body. - -- Reference type declared in the visible part of the - -- subunit parent's body. - if not Vehicles(New_Car).In_Use and Fuel(New_Car) - - -- Reference type declared in the public sibling of the - -- subunit parent's body. - and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then - Vehicles(New_Car).In_Use := true; - - -- Reference type declared in the private part of the - -- protected subunit. - Keys(New_Car).Available := false; - Key := Transportation'pos(New_Car); - else - -- Reference type declared in the grandparent of the subunit - -- parent's body. - Walking := true; - end if; - - -- Drive clunker to other destinations. - else - if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not - CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then - Vehicles(Clunker).In_Use := true; - Keys(Clunker).Available := false; - Key := Transportation'pos(Clunker); - else - Walking := true; - Key := Transportation'pos(Bicycle); - end if; - end if; - - -- Similar for Teen. - when Teen => - if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not - CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then - Vehicles(Clunker).In_Use := true; - Keys(Clunker).Available := false; - Key := Transportation'pos(Clunker); - else - Walking := true; - Key := Transportation'pos(Bicycle); - end if; - end case; - - end Get_Vehicle; - - ---------------------------------------------------------------- - - -- Any family member can bring back the transportation with the key. - - procedure Return_Vehicle (Tr : in Transportation) is - begin - Vehicles(Tr).In_Use := false; - Keys(Tr).Available := true; - end Return_Vehicle; - - ---------------------------------------------------------------- - - function TC_Verify (What : Transportation) return boolean is - begin - return Keys(What).Available; - end TC_Verify; - -end Family_Transportation; - - --==================================================================-- - -with CA13001_0; -use CA13001_0; - --- Public child. - -package CA13001_1.CA13001_5 is - - -- In a real application, tasks could be used to demonstrate - -- a family transportation scenario, i.e., each member of - -- a family can take a vehicle out concurrently, then return - -- them at the same time. For the purposes of the test, family - -- transportation happens sequentially. - - procedure Provide_Transportation (Who : in Family; - Get_Key : out Key_Type; - Get_Veh : out boolean); - procedure Return_Transportation (What : in Transportation; - Rt_Veh : out boolean); - -end CA13001_1.CA13001_5; - - --==================================================================-- - -with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent, - -- implicitly with CA13001_1.CA13001_2. -package body CA13001_1.CA13001_5 is - - package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4; - use Transportation_Pkg; - - -- These two validation subprograms provide the capability to check the - -- components defined in the private packages from within the client - -- program. - - procedure Provide_Transportation (Who : in Family; - Get_Key : out Key_Type; - Get_Veh : out boolean) is - begin - -- Goto work, school, or to the beach. - Family_Transportation.Get_Vehicle (Who, Get_Key); - if not Family_Transportation.TC_Verify - (Transportation'Val(Get_Key)) then - Get_Veh := true; - else - Get_Veh := false; - end if; - - end Provide_Transportation; - - ---------------------------------------------------------------- - - procedure Return_Transportation (What : in Transportation; - Rt_Veh : out boolean) is - begin - Family_Transportation.Return_Vehicle (What); - if Family_Transportation.TC_Verify(What) and - not CA13001_1.CA13001_2.Vehicles(What).In_Use then - Rt_Veh := true; - else - Rt_Veh := false; - end if; - - end Return_Transportation; - -end CA13001_1.CA13001_5; - - --==================================================================-- - -with CA13001_0; -with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1. -with Report; - -procedure CA13001 is - - Mommy : CA13001_0.Family := CA13001_0.Mother; - Daddy : CA13001_0.Family := CA13001_0.Father; - BG : CA13001_0.Family := CA13001_0.Teen; - BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker; - Get_Key : CA13001_1.Key_Type; - Get_Transit : boolean := false; - Return_Transit : boolean := false; - -begin - Report.Test ("CA13001", "Check that a protected subunit declared in " & - "a child unit of a private parent have the same visibility " & - "into its parent, its parent's siblings, and packages on " & - "which its parent depends"); - - -- Get transportation for mother to go to work. - CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work; - CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit); - if not Get_Transit then - Report.Failed ("Failed to get mother transportation"); - end if; - - -- Get transportation for teen to go to school. - CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School; - Get_Transit := false; - CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit); - if not Get_Transit then - Report.Failed ("Failed to get teen transportation"); - end if; - - -- Get transportation for father to go to the beach. - CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach; - Get_Transit := false; - CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit); - if Get_Transit and not CA13001_1.Walking then - Report.Failed ("Failed to make daddy to walk to the beach"); - end if; - - -- Return the clunker. - CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit); - if not Return_Transit then - Report.Failed ("Failed to get back the clunker"); - end if; - - Report.Result; - -end CA13001; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13002.a b/gcc/testsuite/ada/acats/tests/ca/ca13002.a deleted file mode 100644 index e985174afd4..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca13002.a +++ /dev/null @@ -1,259 +0,0 @@ --- CA13002.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 two library child units and/or subunits may have the same --- simple names if they have distinct expanded names. --- --- TEST DESCRIPTION: --- Declare a package that provides some primitive functionality (minimal --- terminal driver operations in this case). Add child packages to --- expand the functionality for different but related contexts (different --- terminal kinds). Add child packages, or subunits, to the children to --- provide the same high level operation for each of the different --- contexts (terminals). Since the operations are the same, at the leaf --- level they are likely to have the same names. --- --- The main program "with"s the child packages. Check that the --- child units and subunits perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Public parent. -package CA13002_0 is -- Terminal_Driver. - - type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child); - type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit, - Second_Subunit); - type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean; - TC_Calls : TC_Calls_Arr := (others => (others => false)); - - -- In real application, Send_Control_Sequence sends keystrokes from - -- the terminal, i.e., space, escape, etc. - procedure Send_Control_Sequence (Row : in TC_Name; - Col : in TC_Call_From); - -end CA13002_0; - - --==================================================================-- - --- First child. -package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100 - - -- Move cursor up, down, left, or right. - procedure Move_Cursor (Col : in TC_Call_From); - -end CA13002_0.CA13002_1; - - --==================================================================-- - --- First grandchild. -procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up - - --==================================================================-- - --- Second child. -package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270 - - procedure Move_Cursor (Col : in TC_Call_From); - -end CA13002_0.CA13002_2; - - --==================================================================-- - --- Second grandchild. -procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up - - --==================================================================-- - --- Third child. -package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI - - procedure Move_Cursor (Col : in TC_Call_From); - - procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up - -- implementation will be as a - -- separate subunit. -end CA13002_0.CA13002_3; - - --==================================================================-- - --- Fourth child. -package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE - - procedure Move_Cursor (Col : in TC_Call_From); - - procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up - -- implementation will be as a - -- separate subunit. - -end CA13002_0.CA13002_4; - - --==================================================================-- - --- Terminal_Driver. -package body CA13002_0 is - - procedure Send_Control_Sequence (Row : in TC_Name; - Col : in TC_Call_From) is - begin - -- Reads a key and takes action. - TC_Calls (Row, Col) := true; - end Send_Control_Sequence; - -end CA13002_0; - - --==================================================================-- - --- Terminal_Driver.VT100. -package body CA13002_0.CA13002_1 is - - procedure Move_Cursor (Col : in TC_Call_From) is - begin - Send_Control_Sequence (First_Child, Col); - end Move_Cursor; - -end CA13002_0.CA13002_1; - - --==================================================================-- - --- Terminal_Driver.VT100.Cursor_Up. -procedure CA13002_0.CA13002_1.CA13002_5 is -begin - Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100. -end CA13002_0.CA13002_1.CA13002_5; - - --==================================================================-- - --- Terminal_Driver.IBM3270. -package body CA13002_0.CA13002_2 is - - procedure Move_Cursor (Col : in TC_Call_From) is - begin - Send_Control_Sequence (Second_Child, Col); - end Move_Cursor; - -end CA13002_0.CA13002_2; - - --==================================================================-- - --- Terminal_Driver.IBM3270.Cursor_Up. -procedure CA13002_0.CA13002_2.CA13002_5 is -begin - Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270. -end CA13002_0.CA13002_2.CA13002_5; - - --==================================================================-- - --- Terminal_Driver.DOS_ANSI. -package body CA13002_0.CA13002_3 is - - procedure Move_Cursor (Col : in TC_Call_From) is - begin - Send_Control_Sequence (Third_Child, Col); - end Move_Cursor; - - procedure CA13002_5 is separate; - -end CA13002_0.CA13002_3; - - --==================================================================-- - --- Terminal_Driver.DOS_ANSI.Cursor_Up. -separate (CA13002_0.CA13002_3) -procedure CA13002_5 is -begin - Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI. -end CA13002_5; - - --==================================================================-- - --- Terminal_Driver.WYSE. -package body CA13002_0.CA13002_4 is - - procedure Move_Cursor (Col : in TC_Call_From) is - begin - Send_Control_Sequence (Fourth_Child, Col); - end Move_Cursor; - - procedure CA13002_5 is separate; - -end CA13002_0.CA13002_4; - - --==================================================================-- - --- Terminal_Driver.WYSE.Cursor_Up. -separate (CA13002_0.CA13002_4) -procedure CA13002_5 is -begin - Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE. -end CA13002_5; - - --==================================================================-- - -with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up, - -- implicitly with parent, CA13002_0. -with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up. -with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI. -with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE. -with Report; -use CA13002_0; -- All primitive subprograms directly - -- visible. - -procedure CA13002 is - Expected_Calls : constant CA13002_0.TC_Calls_Arr - := ((true, false, false, false), - (false, true , false, false), - (false, false, true , false), - (false, false, false, true )); -begin - Report.Test ("CA13002", "Check that two library units and/or subunits " & - "may have the same simple names if they have distinct " & - "expanded names"); - - -- Note that the leaves all have the same name. - -- Call the first grandchild. - CA13002_0.CA13002_1.CA13002_5; - - -- Call the second grandchild. - CA13002_0.CA13002_2.CA13002_5; - - -- Call the first subunit. - CA13002_0.CA13002_3.CA13002_5; - - -- Call the second subunit. - CA13002_0.CA13002_4.CA13002_5; - - if TC_Calls /= Expected_Calls then - Report.Failed ("Wrong result"); - end if; - - Report.Result; - -end CA13002; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13003.a b/gcc/testsuite/ada/acats/tests/ca/ca13003.a deleted file mode 100644 index 607639efecd..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca13003.a +++ /dev/null @@ -1,256 +0,0 @@ --- CA13003.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 separate subunits which share an ancestor may have the --- same name if they have different fully qualified names. Check --- the case of separate subunits of separate subunits. --- This test is a change in semantics from Ada 83 to Ada 9X. --- --- TEST DESCRIPTION: --- Declare a package that provides file processing operations. Declare --- one separate package to do the file processing, and another to do the --- auditing. These packages contain similar functions declared in --- separate subunits. Verify that the main program can call the --- separate subunits with the same name. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Simulates a file processing application. The processing package opens --- files, reads files, does file processing, and generates reports. --- The auditing package opens files, read files, and generates reports. - -package CA13003_0 is - - type File_ID is range 1 .. 100; - subtype File_Name is string (1 .. 10); - - TC_Open_For_Process : boolean := false; - TC_Open_For_Audit : boolean := false; - TC_Report_From_Process : boolean := false; - TC_Report_From_Audit : boolean := false; - - type File_Rec is - record - Name : File_Name; - ID : File_ID; - end record; - - procedure Initialize_File_Rec (Name_In : in File_Name; - ID_In : in File_ID; - File_In : out File_Rec); - - ---------------------------------------------------------------------- - - package CA13003_1 is -- File processing - - procedure CA13003_3; -- Open files - function CA13003_4 (ID_In : File_ID; File_In : File_Rec) - return File_Name; -- Process files - package CA13003_5 is -- Generate report - procedure Generate_Report; - end CA13003_5; - - end CA13003_1; - - ---------------------------------------------------------------------- - - package CA13003_2 is -- File auditing - - procedure CA13003_3; -- Open files - function CA13003_4 (ID_In : File_ID; File_In : File_Rec) - return File_Name; -- Process files - package CA13003_5 is -- Generate report - procedure Generate_Report; - end CA13003_5; - - end CA13003_2; - -end CA13003_0; - - --==================================================================-- - -package body CA13003_0 is - - procedure Initialize_File_Rec (Name_In : in File_Name; - ID_In : in File_ID; - File_In : out File_Rec) is - -- Not a real initialization. Real application can use file - -- database to create the file record. - begin - File_In.Name := Name_In; - File_In.ID := ID_In; - end Initialize_File_Rec; - - package body CA13003_1 is separate; - package body CA13003_2 is separate; - -end CA13003_0; - - --==================================================================-- - -separate (CA13003_0) -package body CA13003_1 is - - procedure CA13003_3 is separate; -- Open files - function CA13003_4 (ID_In : File_ID; File_In : File_Rec) - return File_Name is separate; -- Process files - package body CA13003_5 is separate; -- Generate report - -end CA13003_1; - - --==================================================================-- - -separate (CA13003_0.CA13003_1) -procedure CA13003_3 is -- Open files -begin - -- In real file processing application, open file from database, setup - -- data structure, etc. - TC_Open_For_Process := true; -end CA13003_3; - - --==================================================================-- - -separate (CA13003_0.CA13003_1) -function CA13003_4 (ID_In : File_ID; -- Process files - File_In : File_Rec) return File_Name is -begin - -- In real file processing application, process files for more information. - return File_In.Name; -end CA13003_4; - - --==================================================================-- - -separate (CA13003_0.CA13003_1) -package body CA13003_5 is -- Generate report - procedure Generate_Report is - begin - -- In real file processing application, generate various report from the - -- file database. - TC_Report_From_Process := true; - end Generate_Report; - -end CA13003_5; - - --==================================================================-- - -separate (CA13003_0) -package body CA13003_2 is - - procedure CA13003_3 is separate; -- Open files - function CA13003_4 (ID_In : File_ID; File_In : File_Rec) - return File_Name is separate; -- Process files - package body CA13003_5 is separate; -- Generate report - -end CA13003_2; - - --==================================================================-- - -separate (CA13003_0.CA13003_2) -procedure CA13003_3 is -- Open files -begin - TC_Open_For_Audit := true; -end CA13003_3; - - --==================================================================-- - -separate (CA13003_0.CA13003_2) -function CA13003_4 (ID_In : File_ID; - File_In : File_Rec) return File_Name is -begin - return File_In.Name; -end CA13003_4; - - --==================================================================-- - -separate (CA13003_0.CA13003_2) -package body CA13003_5 is -- Generate report - procedure Generate_Report is - begin - TC_Report_From_Audit := true; - end Generate_Report; - -end CA13003_5; - - --==================================================================-- - -with CA13003_0; -with Report; - -procedure CA13003 is - First_File_Name : CA13003_0.File_Name := "Joe Smith "; - First_File_Id : CA13003_0.File_ID := 11; - Second_File_Name : CA13003_0.File_Name := "John Schep"; - Second_File_Id : CA13003_0.File_ID := 47; - Expected_Name : CA13003_0.File_Name := " "; - Student_File : CA13003_0.File_Rec; - - function Process_Input_Files (ID_In : CA13003_0.File_ID; - File_In : CA13003_0.File_Rec) return - CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4; - - function Process_Audit_Files (ID_In : CA13003_0.File_ID; - File_In : CA13003_0.File_Rec) return - CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4; -begin - Report.Test ("CA13003", "Check that separate subunits which share " & - "an ancestor may have the same name if they have " & - "different fully qualified names"); - - Student_File := (ID => First_File_Id, Name => First_File_Name); - - -- Note that all subunits have the same simple name. - -- Generate report from file processing. - CA13003_0.CA13003_1.CA13003_3; - Expected_Name := Process_Input_Files (First_File_Id, Student_File); - CA13003_0.CA13003_1.CA13003_5.Generate_Report; - - if not CA13003_0.TC_Open_For_Process or - not CA13003_0.TC_Report_From_Process or - Expected_Name /= First_File_Name then - Report.Failed ("Unexpected results in processing file"); - end if; - - CA13003_0.Initialize_File_Rec - (Second_File_Name, Second_File_Id, Student_File); - - -- Generate report from file auditing. - CA13003_0.CA13003_2.CA13003_3; - Expected_Name := Process_Audit_Files (Second_File_Id, Student_File); - CA13003_0.CA13003_2.CA13003_5.Generate_Report; - - if not CA13003_0.TC_Open_For_Audit or - not CA13003_0.TC_Report_From_Audit or - Expected_Name /= Second_File_Name then - Report.Failed ("Unexpected results in auditing file"); - end if; - - Report.Result; - -end CA13003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a deleted file mode 100644 index 3963bc61f19..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a +++ /dev/null @@ -1,320 +0,0 @@ --- CA13A01.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 subunits declared in non-generic child units of a public --- parent have the same visibility into its parent, its siblings --- (public and private), and packages on which its parent depends --- as is available at the point of their declaration. --- --- TEST DESCRIPTION: --- Declare an check system procedure as a subunit in a private child --- package of the basic operation package (FA13A00.A). This procedure --- has visibility into its parent ancestor and its private sibling. --- --- Declare an emergency procedure as a subunit in a public child package --- of the basic operation package (FA13A00.A). This procedure has --- visibility into its parent ancestor and its private sibling. --- --- Declare an express procedure as a subunit in a public child subprogram --- of the basic operation package (FA13A00.A). This procedure has --- visibility into its parent ancestor and its public sibling. --- --- In the main program, "with"s the child package and subprogram. Check --- that subunits perform as expected. --- --- TEST FILES: --- The following files comprise this test: --- --- FA13A00.A --- CA13A01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Private child package of an elevator application. This package --- provides maintenance operations. - -private package FA13A00_1.CA13A01_4 is -- Maintenance operation - - One_Floor : Floor_No := 1; -- Type declared in parent. - - procedure Check_System; - - -- other type definitions and procedure declarations in real application. - -end FA13A00_1.CA13A01_4; - - --==================================================================-- - --- Context clauses required for visibility needed by separate subunit. - -with FA13A00_0; -- Building Manager - -with FA13A00_1.FA13A00_2; -- Floor Calculation (private) - -with FA13A00_1.FA13A00_3; -- Move Elevator - -use FA13A00_0; - -package body FA13A00_1.CA13A01_4 is - - procedure Check_System is separate; - -end FA13A00_1.CA13A01_4; - - --==================================================================-- - -separate (FA13A00_1.CA13A01_4) - --- Subunit Check_System declared in Maintenance Operation. - -procedure Check_System is -begin - -- See if regular power is on. - - if Power /= V120 then -- Reference package with'ed by - TC_Operation := false; -- the subunit parent's body. - end if; - - -- Test elevator function. - - FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of - (Penthouse, Call_Waiting); -- the subunit parent's body. - - if not Call_Waiting (Penthouse) then -- Reference private part of the - TC_Operation := false; -- parent of the subunit package's - -- body. - end if; - - FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of - -- the subunit parent's body. - - if Current_Floor /= Floor'pred (Penthouse) then - TC_Operation := false; -- Reference type declared in the - end if; -- parent of the subunit parent's - -- body. - -end Check_System; - - --==================================================================-- - --- Public child package of an elevator application. This package provides --- an emergency operation. - -package FA13A00_1.CA13A01_5 is -- Emergency Operation - - -- Other type definitions in real application. - - procedure Emergency; - -private - type Bell_Type is (Inactive, Active); - -end FA13A00_1.CA13A01_5; - - --==================================================================-- - --- Context clauses required for visibility needed by separate subunit. - -with FA13A00_0; -- Building Manager - -with FA13A00_1.FA13A00_3; -- Move Elevator - -with FA13A00_1.CA13A01_4; -- Maintenance Operation (private) - -use FA13A00_0; - -package body FA13A00_1.CA13A01_5 is - - procedure Emergency is separate; - -end FA13A00_1.CA13A01_5; - - --==================================================================-- - -separate (FA13A00_1.CA13A01_5) - --- Subunit Emergency declared in Maintenance Operation. - -procedure Emergency is - Bell : Bell_Type; -- Reference type declared in the - -- subunit parent's body. - -begin - -- Calls maintenance operation. - - FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the - -- subunit parent 's body. - - -- Clear all calls to the elevator. - - Clear_Calls (Call_Waiting); -- Reference subprogram declared - -- in the parent of the subunit - -- parent's body. - for I in Floor loop - if Call_Waiting (I) then -- Reference private part of the - TC_Operation := false; -- parent of the subunit parent's - end if; -- body. - end loop; - - -- Move elevator to the basement. - - FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the - (Basement, Call_Waiting); -- subunit parent's body. - - if Current_Floor /= Basement then -- Reference type declared in the - TC_Operation := false; -- parent of the subunit parent's - end if; -- body. - - -- Shut off power. - - Power := Off; -- Reference package with'ed by - -- the subunit parent's body. - - -- Activate bell. - - Bell := Active; -- Reference type declared in the - -- subunit parent's body. - -end Emergency; - - --==================================================================-- - --- Public child subprogram of an elevator application. This subprogram --- provides an express operation. - -procedure FA13A00_1.CA13A01_6; - - --==================================================================-- - --- Context clauses required for visibility needed by separate subunit. - -with FA13A00_0; -- Building Manager - -with FA13A00_1.FA13A00_2; -- Floor Calculation (private) - -with FA13A00_1.FA13A00_3; -- Move Elevator - -use FA13A00_0; - -procedure FA13A00_1.CA13A01_6 is -- Express Operation - - -- Other type definitions in real application. - - procedure GoTo_Penthouse is separate; - -begin - GoTo_Penthouse; - -end FA13A00_1.CA13A01_6; - - --==================================================================-- - -separate (FA13A00_1.CA13A01_6) - --- Subunit GoTo_Penthouse declared in Express Operation. - -procedure GoTo_Penthouse is -begin - -- Go faster. - - Power := V240; -- Reference package with'ed by - -- the subunit parent's body. - - -- Call elevator. - - Call (Penthouse, Call_Waiting); -- Reference subprogram declared in - -- the parent of the subunit - -- parent's body. - - if not Call_Waiting (Penthouse) then -- Reference private part of the - TC_Operation := false; -- parent of the subunit parent's - end if; -- body. - - -- Move elevator to Penthouse. - - FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the - (Penthouse, Call_Waiting); -- subunit parent's body. - - if Current_Floor /= Penthouse then -- Reference type declared in the - TC_Operation := false; -- parent of the subunit parent's - end if; -- body. - - -- Return slowly - - while Current_Floor /= Floor1 loop -- Reference type, subprogram - FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the - -- subunit parent's body. - end loop; - - if Current_Floor /= Floor1 then -- Reference type declared in - TC_Operation := false; -- the parent of the subunit - end if; -- parent's body. - - -- Back to normal. - - Power := V120; -- Reference package with'ed by - -- the subunit parent's body. - -end GoTo_Penthouse; - - --==================================================================-- - -with FA13A00_1.CA13A01_5; -- Emergency Operation - -- implicitly with Basic Elevator - -- Operations - -with FA13A00_1.CA13A01_6; -- Express Operation - -with Report; - -procedure CA13A01 is - -begin - - Report.Test ("CA13A01", "Check that subunits declared in non-generic " & - "child units of a public parent have the same visibility " & - "into its parent, its parent's siblings, and packages on " & - "which its parent depends"); - - -- Go to Penthouse. - - FA13A00_1.CA13A01_6; - - -- Call emergency operation. - - FA13A00_1.CA13A01_5.Emergency; - - if not FA13A00_1.TC_Operation then - Report.Failed ("Incorrect elevator operation"); - end if; - - Report.Result; - -end CA13A01; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a deleted file mode 100644 index 82d1b6ea538..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a +++ /dev/null @@ -1,301 +0,0 @@ --- CA13A02.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 subunits declared in generic child units of a public --- parent have the same visibility into its parent, its siblings --- (public and private), and packages on which its parent depends --- as is available at the point of their declaration. --- --- TEST DESCRIPTION: --- Declare an outside elevator button operation as a subunit in a --- generic child package of the basic operation package (FA13A00.A). --- This procedure has visibility into its parent ancestor and its --- private sibling. --- --- In the main program, instantiate the child package. Check that --- subunits perform as expected. --- --- TEST FILES: --- The following files comprise this test: --- --- FA13A00.A --- CA13A02.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - --- Public generic child package of an elevator application. This package --- provides outside elevator button operations. - -generic -- Instantiate once for each floor. - Our_Floor : in Floor; -- Reference type declared in parent. - -package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations - - type Light is (Up, Down, Express, Off); - - type Direction is (Up, Down, Express); - - function Call_Elevator (D : Direction) return Light; - - -- other type definitions and procedure declarations in real application. - -end FA13A00_1.CA13A02_4; - - --==================================================================-- - --- Context clauses required for visibility needed by separate subunit. - -with FA13A00_0; -- Building Manager - -with FA13A00_1.FA13A00_2; -- Floor Calculation (private) - -with FA13A00_1.FA13A00_3; -- Move Elevator - -use FA13A00_0; - -package body FA13A00_1.CA13A02_4 is - - function Call_Elevator (D : Direction) return Light is separate; - -end FA13A00_1.CA13A02_4; - - --==================================================================-- - -separate (FA13A00_1.CA13A02_4) - --- Subunit Call_Elevator declared in Outside Elevator Button Operations. - -function Call_Elevator (D : Direction) return Light is - Elevator_Button : Light; - -begin - -- See if power is on. - - if Power = Off then -- Reference package with'ed by - Elevator_Button := Off; -- the subunit parent's body. - - else - case D is - when Express => - FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of - (Penthouse, Call_Waiting); -- the subunit parent's body. - - Elevator_Button := Express; - - when Up => - if Current_Floor < Our_Floor then - FA13A00_1.FA13A00_2.Up -- Reference private sibling of - (Floor'pos (Our_Floor) -- the subunit parent's body. - - Floor'pos (Current_Floor)); - else - FA13A00_1.FA13A00_2.Down -- Reference private sibling of - (Floor'pos (Current_Floor) -- the subunit parent's body. - - Floor'pos (Our_Floor)); - end if; - - -- Call elevator. - - Call - (Current_Floor, Call_Waiting); -- Reference subprogram declared - -- in the parent of the subunit - -- parent's body. - Elevator_Button := Up; - - when Down => - if Current_Floor > Our_Floor then - FA13A00_1.FA13A00_2.Down -- Reference private sibling of - (Floor'pos (Current_Floor) -- the subunit parent's body. - - Floor'pos (Our_Floor)); - else - FA13A00_1.FA13A00_2.Up -- Reference private sibling of - (Floor'pos (Our_Floor) -- the subunit parent's body. - - Floor'pos (Current_Floor)); - end if; - - Elevator_Button := Down; - - -- Call elevator. - - Call - (Current_Floor, Call_Waiting); -- Reference subprogram declared - -- in the parent of the subunit - -- parent's body. - end case; - - if not Call_Waiting (Current_Floor) -- Reference private part of the - then -- parent of the subunit parent's - -- body. - TC_Operation := false; - end if; - - end if; - - return Elevator_Button; - -end Call_Elevator; - - --==================================================================-- - -with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations - -- implicitly with Basic Elevator - -- Operations -with Report; - -procedure CA13A02 is - -begin - - Report.Test ("CA13A02", "Check that subunits declared in generic child " & - "units of a public parent have the same visibility into " & - "its parent, its parent's siblings, and packages on " & - "which its parent depends"); - --- Going from floor one to penthouse. - - Going_To_Penthouse: - declare - -- Declare instance of the child generic elevator package for penthouse. - - package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 - (FA13A00_1.Penthouse); - - use Call_Elevator_Pkg; - - Call_Button_Light : Light; - - begin - - Call_Button_Light := Call_Elevator (Express); - - if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then - Report.Failed ("Incorrect elevator operation going to penthouse"); - end if; - - end Going_To_Penthouse; - --- Going from penthouse to basement. - - Going_To_Basement: - declare - -- Declare instance of the child generic elevator package for basement. - - package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 - (FA13A00_1.Basement); - - use Call_Elevator_Pkg; - - Call_Button_Light : Light; - - begin - - Call_Button_Light := Call_Elevator (Down); - - if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then - Report.Failed ("Incorrect elevator operation going to basement"); - end if; - - end Going_To_Basement; - --- Going from basement to floor three. - - Going_To_Floor3: - declare - -- Declare instance of the child generic elevator package for floor - -- three. - - package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 - (FA13A00_1.Floor3); - - use Call_Elevator_Pkg; - - Call_Button_Light : Light; - - begin - - Call_Button_Light := Call_Elevator (Up); - - if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then - Report.Failed ("Incorrect elevator operation going to floor 3"); - end if; - - end Going_To_Floor3; - --- Going from floor three to floor two. - - Going_To_Floor2: - declare - -- Declare instance of the child generic elevator package for floor two. - - package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 - (FA13A00_1.Floor2); - - use Call_Elevator_Pkg; - - Call_Button_Light : Light; - - begin - - Call_Button_Light := Call_Elevator (Up); - - if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then - Report.Failed ("Incorrect elevator operation going to floor 2"); - end if; - - end Going_To_Floor2; - --- Going to floor one. - - Going_To_Floor1: - declare - -- Declare instance of the child generic elevator package for floor one. - - package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 - (FA13A00_1.Floor1); - - use Call_Elevator_Pkg; - - Call_Button_Light : Light; - - begin - -- Calling elevator from floor one. - - FA13A00_1.Current_Floor := FA13A00_1.Floor1; - - Call_Button_Light := Call_Elevator (Down); - - if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then - Report.Failed ("Incorrect elevator operation going to floor 1"); - end if; - - end Going_To_Floor1; - - Report.Result; - -end CA13A02; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140230.a b/gcc/testsuite/ada/acats/tests/ca/ca140230.a deleted file mode 100644 index 95b72b1ab71..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140230.a +++ /dev/null @@ -1,62 +0,0 @@ --- CA140230.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: --- See CA140232.AM. --- --- TEST DESCRIPTION: --- See CA140232.AM. --- --- TEST FILES: --- This test consists of the following files: --- -> CA140230.A --- CA140231.A --- CA140232.AM --- CA140233.A --- --- PASS/FAIL CRITERIA: --- See CA140232.AM. --- --- CHANGE HISTORY: --- 07 DEC 96 SAIC ACVC 2.1: Initial version. --- 13 SEP 99 RLB Changed to C-test (by AI-00077). --- 20 MAR 00 RLB Removed special requirements, because there --- aren't any. --- ---! - -package CA14023_0 is - subtype Little_float is float digits 4 range 0.0..100.0; - type Data_rec is tagged record - Data : Little_float; - end record; -end CA14023_0; - --------------------------------------------------------- - -generic - type Data_type is digits <>; - Floor : Data_type; -function CA14023_1 (P1, P2 : Data_type) return Data_type; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140231.a b/gcc/testsuite/ada/acats/tests/ca/ca140231.a deleted file mode 100644 index 32504b59008..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140231.a +++ /dev/null @@ -1,59 +0,0 @@ --- CA140231.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: --- See CA140232.AM. --- --- TEST DESCRIPTION: --- See CA140232.AM. --- --- TEST FILES: --- This test consists of the following files: --- CA140230.A --- -> CA140231.A --- CA140232.AM --- CA140233.A --- --- PASS/FAIL CRITERIA: --- See CA140232.AM. --- --- CHANGE HISTORY: --- 07 DEC 96 SAIC ACVC 2.1: Initial version. --- 13 SEP 99 RLB Changed to C-test (by AI-00077). --- 20 MAR 00 RLB Removed special requirements, because there --- aren't any. --- ---! - -function CA14023_1 (P1, P2 : Data_type) return Data_type is -begin - if Floor > P1 and Floor > P2 then - return Floor; - elsif P2 > P1 then - return P2; - else - return P1; - end if; -end CA14023_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140233.a b/gcc/testsuite/ada/acats/tests/ca/ca140233.a deleted file mode 100644 index a5334379dc9..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140233.a +++ /dev/null @@ -1,68 +0,0 @@ --- CA140233.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: --- See CA140232.AM. --- --- TEST DESCRIPTION: --- See CA140232.AM. --- --- TEST FILES: --- This test consists of the following files: --- CA140230.A --- CA140231.A --- CA140232.AM --- -> CA140233.A --- --- PASS/FAIL CRITERIA: --- See CA140232.AM. --- --- CHANGE HISTORY: --- 01 MAY 95 ACVC 1.12 LA5008T baseline version --- 29 JUN 95 SAIC Initial version --- 05 MAR 96 SAIC First revision after review --- 18 NOV 96 SAIC Modified unit names and prologue to conform --- to coding conventions. --- 07 DEC 96 SAIC Modified prologue to reflect new test --- file organization. --- 13 SEP 99 RLB Changed to C-test (by AI-00077). --- 20 MAR 00 RLB Removed special requirements, because there --- aren't any. ---! - --- here is the replacement body, correcting "errors" in --- the original - -function CA14023_1 (P1, P2 : Data_type) return Data_type is -begin - -- return min rather than max - if Floor < P1 and Floor < P2 then - return Floor; - elsif P2 < P1 then - return P2; - else - return P1; - end if; -end CA14023_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140280.a b/gcc/testsuite/ada/acats/tests/ca/ca140280.a deleted file mode 100644 index 1ffe3cbbf73..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140280.a +++ /dev/null @@ -1,77 +0,0 @@ --- CA140280.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: --- See CA140283.AM. --- --- TEST DESCRIPTION --- See CA140283.AM. --- --- TEST FILES: --- This test consists of the following files: --- -> CA140280.A --- CA140281.A --- CA140282.A --- CA140283.AM --- --- CHANGE HISTORY: --- JBG 05/28/85 CREATED ORGINAL TEST. --- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE --- NOT THE SAME. --- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. - -GENERIC - C : INTEGER; -PROCEDURE GENPROC_CA14028 (X : OUT INTEGER); - -WITH REPORT; USE REPORT; -PRAGMA ELABORATE (REPORT); -PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS -BEGIN - X := IDENT_INT(C); -END GENPROC_CA14028; - -GENERIC -FUNCTION GENFUNC_CA14028 RETURN INTEGER; - -FUNCTION GENFUNC_CA14028 RETURN INTEGER IS -BEGIN - RETURN 2; -END GENFUNC_CA14028; - -WITH GENPROC_CA14028; -PRAGMA ELABORATE (GENPROC_CA14028); -PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1); - -WITH GENFUNC_CA14028; -PRAGMA ELABORATE (GENFUNC_CA14028); -FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028; - -WITH GENPROC_CA14028; -PRAGMA ELABORATE (GENPROC_CA14028); -PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3); - -WITH GENFUNC_CA14028; -PRAGMA ELABORATE (GENFUNC_CA14028); -FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140281.a b/gcc/testsuite/ada/acats/tests/ca/ca140281.a deleted file mode 100644 index 57360c9ebb9..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140281.a +++ /dev/null @@ -1,67 +0,0 @@ --- CA140281.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: --- See CA140283.AM. --- --- TEST DESCRIPTION --- See CA140283.AM. --- --- TEST FILES: --- This test consists of the following files: --- CA140280.A --- -> CA140281.A --- CA140282.A --- CA140283.AM --- --- CHANGE HISTORY: --- JBG 05/28/85 CREATED ORGINAL TEST. --- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE --- NOT THE SAME. --- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. - -PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS -BEGIN - X := 3; -END CA14028_PROC1; - -WITH REPORT; USE REPORT; -PRAGMA ELABORATE (REPORT); -FUNCTION CA14028_FUNC2 RETURN INTEGER IS -BEGIN - RETURN IDENT_INT(4); -END CA14028_FUNC2; - -WITH REPORT; USE REPORT; -PRAGMA ELABORATE (REPORT); -PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS -BEGIN - X := FALSE; - Y := IDENT_INT(6); -END CA14028_PROC3; - -FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS -BEGIN - RETURN FALSE; -END CA14028_FUNC3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140282.a b/gcc/testsuite/ada/acats/tests/ca/ca140282.a deleted file mode 100644 index 437f01889c9..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca140282.a +++ /dev/null @@ -1,64 +0,0 @@ --- CA140282.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: --- See CA140283.AM. --- --- TEST DESCRIPTION --- See CA140283.AM. --- --- TEST FILES: --- This test consists of the following files: --- CA140280.A --- CA140281.A --- -> CA140282.A --- CA140283.AM --- --- CHANGE HISTORY: --- JBG 05/28/85 CREATED ORIGINAL TEST. --- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE --- NOT THE SAME. --- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. - -WITH GENPROC_CA14028; -PRAGMA ELABORATE (GENPROC_CA14028); -PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5); - -WITH GENFUNC_CA14028; -PRAGMA ELABORATE (GENFUNC_CA14028); -FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028; - -WITH REPORT; USE REPORT; -PRAGMA ELABORATE (REPORT); -PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS -BEGIN - X := IDENT_INT(4); -END CA14028_PROC3; - -WITH REPORT; USE REPORT; -PRAGMA ELABORATE (REPORT); -FUNCTION CA14028_FUNC3 RETURN INTEGER IS -BEGIN - RETURN IDENT_INT(7); -END CA14028_FUNC3; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca15003.a b/gcc/testsuite/ada/acats/tests/ca/ca15003.a deleted file mode 100644 index 08fe1516ddf..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca15003.a +++ /dev/null @@ -1,161 +0,0 @@ --- CA15003.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 the requirements of 10.1.5(4) and the modified 10.1.5(5) --- from Technical Corrigendum 1. (Originally discussed as AI95-00136.) --- Specifically: --- Check that program unit pragma for a generic package are accepted --- when given at the beginning of the package specification. --- Check that a program unit pragma can be given for a generic --- instantiation by placing the pragma immediately after the instantation. --- --- TEST DESCRIPTION --- This test checks the cases that are *not* forbidden by the RM, --- and makes sure such legal cases actually work. --- --- CHANGE HISTORY: --- 29 JUN 1999 RAD Initial Version --- 08 JUL 1999 RLB Cleaned up and added to test suite. --- 27 AUG 1999 RLB Repaired errors introduced by me. --- ---! - -with System; -package CA15003A is - pragma Pure; - - type Big_Int is range -System.Max_Int .. System.Max_Int; - type Big_Positive is new Big_Int range 1..Big_Int'Last; -end CA15003A; - -generic - type Int is new Big_Int; -package CA15003A.Pure is - pragma Pure; - function F(X: access Int) return Int; -end CA15003A.Pure; - -with CA15003A.Pure; -package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive); - pragma Pure(CA15003A.Pure_Instance); - -package body CA15003A.Pure is - function F(X: access Int) return Int is - begin - X.all := X.all + 1; - return X.all; - end F; -end CA15003A.Pure; - -generic -package CA15003A.Pure.Preelaborate is - pragma Preelaborate; - One: Int := 1; - function F(X: access Int) return Int; -end CA15003A.Pure.Preelaborate; - -package body CA15003A.Pure.Preelaborate is - function F(X: access Int) return Int is - begin - X.all := X.all + One; - return X.all; - end F; -end CA15003A.Pure.Preelaborate; - -with CA15003A.Pure_Instance; -with CA15003A.Pure.Preelaborate; -package CA15003A.Pure_Preelaborate_Instance is - new CA15003A.Pure_Instance.Preelaborate; - pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance); - -package CA15003A.Empty_Pure is - pragma Pure; - pragma Elaborate_Body; -end CA15003A.Empty_Pure; - -package body CA15003A.Empty_Pure is -end CA15003A.Empty_Pure; - -package CA15003A.Empty_Preelaborate is - pragma Preelaborate; - pragma Elaborate_Body; - One: Big_Int := 1; -end CA15003A.Empty_Preelaborate; - -package body CA15003A.Empty_Preelaborate is - function F(X: access Big_Int) return Big_Int is - begin - X.all := X.all + One; - return X.all; - end F; -end CA15003A.Empty_Preelaborate; - -package CA15003A.Empty_Elaborate_Body is - pragma Elaborate_Body; - Three: aliased Big_Positive := 1; - Two, Tres: Big_Positive'Base := 0; -end CA15003A.Empty_Elaborate_Body; - -with Report; use Report; pragma Elaborate_All(Report); -with CA15003A.Pure_Instance; -with CA15003A.Pure_Preelaborate_Instance; -use CA15003A; -package body CA15003A.Empty_Elaborate_Body is -begin - if Two /= Big_Positive'Base(Ident_Int(0)) then - Failed ("Two should be zero now"); - end if; - if Tres /= Big_Positive'Base(Ident_Int(0)) then - Failed ("Tres should be zero now"); - end if; - if Two /= Tres then - Failed ("Tres should be zero now"); - end if; - Two := Pure_Instance.F(Three'Access); - Tres := Pure_Preelaborate_Instance.F(Three'Access); - if Two /= Big_Positive(Ident_Int(2)) then - Failed ("Two should be 2 now"); - end if; - if Tres /= Big_Positive(Ident_Int(3)) then - Failed ("Tres should be 3 now"); - end if; -end CA15003A.Empty_Elaborate_Body; - -with Report; use Report; -with CA15003A.Empty_Pure; -with CA15003A.Empty_Preelaborate; -with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body; -use type CA15003A.Big_Positive'Base; -procedure CA15003 is -begin - Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages"); - if Two /= 2 then - Failed ("Two should be 2 now"); - end if; - if Tres /= 3 then - Failed ("Tres should be 3 now"); - end if; - Result; -end CA15003; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200020.a b/gcc/testsuite/ada/acats/tests/ca/ca200020.a deleted file mode 100644 index c9508f4cccb..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca200020.a +++ /dev/null @@ -1,70 +0,0 @@ --- CA200020.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and --- F08630-91-C-0015, 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 partition can be created even if the environment contains --- two units with the same name. (This is rule 10.2(19)). --- --- TEST DESCRIPTION: --- Declare the a parent package (CA20002_0). Declare a child package --- (CA20002_0.CA20002_1). Declare a subunit in the parent package body --- (CA20002_1). Declare a main subprogram that does NOT include the --- child package. Insure that this partition can be created. --- --- This test is intended to test the effects of program maintenance. --- After the programmer receives an error from creating a partition --- like that tested in test LA20001, the programmer may then repair --- the partition by eliminating the reference of the child unit. The --- partition should be able to be created. --- --- To build this test: --- 1) Compile the file CA200020 (and include the results in the --- program library). --- 2) Compile the file CA200021 (and include the results in the --- program library). --- 3) Compile the file CA200022 (and include the results in the --- program library). --- 4) Build an executable image, and run it. --- --- TEST FILES: --- This test consists of the following files: --- -> CA200020.A --- CA200021.A --- CA200022.AM --- --- CHANGE HISTORY: --- 27 Jan 99 RLB Initial test. --- 20 Mar 00 RLB Removed special requirements, because there --- aren't any. ---! - -package CA20002_0 is - procedure Do_a_Little (A : out Integer); - -end CA20002_0; - -package CA20002_0.CA20002_1 is - My_Global : Integer; -end CA20002_0.CA20002_1; - diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200021.a b/gcc/testsuite/ada/acats/tests/ca/ca200021.a deleted file mode 100644 index 0c5de38253b..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca200021.a +++ /dev/null @@ -1,66 +0,0 @@ --- CA200021.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and --- F08630-91-C-0015, 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: --- See CA200020.A. --- --- TEST DESCRIPTION: --- See CA200020.A. --- --- TEST FILES: --- This test consists of the following files: --- CA200020.A --- -> CA200021.A --- CA200022.AM --- --- PASS/FAIL CRITERIA: --- See CA200020.A. --- --- CHANGE HISTORY: --- 27 JAN 99 RLB Initial version. --- 20 MAR 00 RLB Removed special requirements, because there --- aren't any. --- ---! - -package body CA20002_0 is - - function CA20002_1 return Integer is separate; -- Has the same expanded name - -- as the child. - -- Note: An implementation may produce a warning about the child - -- unit at this point, but it must accept the subunit declaration. - - procedure Do_a_Little (A : out Integer) is - begin - A := CA20002_1; - end Do_a_Little; - -end CA20002_0; - -with Report; -separate (CA20002_0) -function CA20002_1 return Integer is -begin - return Report.Ident_Int(5); -end CA20002_1; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca21001.a b/gcc/testsuite/ada/acats/tests/ca/ca21001.a deleted file mode 100644 index 1056b65bfcc..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca21001.a +++ /dev/null @@ -1,152 +0,0 @@ --- CA21001.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and --- F08630-91-C-0015, 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 WHATSOVER, 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 the requirements of the revised 10.2.1(11) from Technical --- Corrigendum 1 (originally discussed as AI95-00002). --- A package subunit whose parent is a preelaborated subprogram need --- not be preelaborable. --- --- TEST DESCRIPTION --- We create several preelaborated library procedures with --- non-preelaborable package body subunits. We try various levels --- of nesting of package and procedure subunits. --- --- CHANGE HISTORY: --- 29 JUN 1999 RAD Initial Version --- 23 SEP 1999 RLB Improved comments, renamed, issued. --- ---! - -procedure CA21001_1(X: out Integer); - pragma Preelaborate(CA21001_1); - -procedure CA21001_1(X: out Integer) is - function F return Integer is separate; - - package Sub is - function G(X: Integer) return Integer; - -- Returns X + 1. - Not_Preelaborable: Integer := F; -- OK, by AI-2. - end Sub; - - package body Sub is separate; - -begin - X := -1; - X := F; - X := Sub.G(X); -end CA21001_1; - -separate(CA21001_1) -package body Sub is - package Sub_Sub is - -- Empty. - end Sub_Sub; - package body Sub_Sub is separate; - - function G(X: Integer) return Integer is separate; -begin - Not_Preelaborable := G(F); -- OK, by AI-2. - if Not_Preelaborable /= 101 then - raise Program_Error; -- Can't call Report.Failed, here, - -- because Report is not preelaborated. - end if; -end Sub; - -separate(CA21001_1.Sub) -package body Sub_Sub is -begin - X := X; -- OK by AI-2. -end Sub_Sub; - -separate(CA21001_1.Sub) -function G(X: Integer) return Integer is - - package G_Sub is - function H(X: Integer) return Integer; - -- Returns X + 1. - Not_Preelaborable: Integer := F; -- OK, by AI-2. - end G_Sub; - package body G_Sub is separate; - -begin - return G_Sub.H(X); -end G; - -separate(CA21001_1.Sub.G) -package body G_Sub is - function H(X: Integer) return Integer is separate; -begin - Not_Preelaborable := H(F); -- OK, by AI-2. - if Not_Preelaborable /= 101 then - raise Program_Error; -- Can't call Report.Failed, here, - -- because Report is not preelaborated. - end if; -end G_Sub; - -separate(CA21001_1.Sub.G.G_Sub) -function H(X: Integer) return Integer is -begin - return X + 1; -end H; - -separate(CA21001_1) -function F return Integer is - - package F_Sub is - -- Empty. - end F_Sub; - - package body F_Sub is separate; -begin - return 100; -end F; - -separate(CA21001_1.F) -package body F_Sub is - True_Var: Boolean; -begin - True_Var := True; - if True_Var then -- OK by AI-2. - X := X; - else - X := X + 2; - end if; -end F_Sub; - -with Report; use Report; -with CA21001_1; -procedure CA21001 is - X: Integer := 0; -begin - Test("CA21001", - "Test that a package subunit whose parent is a preelaborated" - & " subprogram need not be preelaborable"); - CA21001_1(X); - if X /= 101 then - Failed("Bad value for X"); - end if; - Result; -end CA21001; |