diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3')
92 files changed, 0 insertions, 22299 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330001.a b/gcc/testsuite/ada/acats/tests/c3/c330001.a deleted file mode 100644 index 218896d679d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c330001.a +++ /dev/null @@ -1,354 +0,0 @@ --- C330001.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 variable object of an indefinite type is properly --- initialized/constrained by an initial value assignment that is --- a) an aggregate, b) a function, or c) an object. Check that objects --- of the above types do not need explicit constraints if they have --- initial values. --- --- TEST DESCRIPTION: --- An indefinite subtype is either: --- a) An unconstrained array subtype. --- b) A subtype with unknown discriminants. --- c) A subtype with unconstrained discriminants without defaults. --- --- Declare several indefinite types in a parent package specification. --- In the private part, complete one type with a discriminant without --- default (indefinite) and the other with a default discriminant --- (definite). Declare objects of both indefinite and definite subtypes --- in children (private and public) with initialization expressions. The --- test verifies all values of the objects. It also verifies that --- Constraint_Error is raised if an attempt is made to change the --- discriminants of the objects of the indefinite subtypes. --- --- --- CHANGE HISTORY: --- 15 Jan 95 SAIC Initial version for ACVC 2.1 --- 25 Jul 96 SAIC Modified test description. Deleted use C330001_0. --- 20 Nov 98 RLB Added Elaborate pragmas to avoid problems --- with an unconventional, but legal, elaboration --- order. ---! - -package C330001_0 is - - subtype Sub_Type is Integer range 1 .. 20; - - type Tag_W_Disc (D : Sub_Type) is tagged record - C1 : String (1 .. D); - end record; - - -- Indefinite type declarations. - - type FullViewDefinite_Unknown_Disc (<>) is private; - - type Indefinite_No_Disc is array (Positive range <>) of Integer; - - type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged - record - C1 : Boolean := False; - end record; - - type Indefinite_New_W_Disc (ND : Sub_Type) is new - Indefinite_Tag_W_Disc (ND) with record - C2 : Integer := 9; - end record; - - type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with - record - S : Sub_Type := 18; - end record; - - type Indefinite_W_Inherit_Disc_2 is - new Tag_W_Disc with private; - - function Indef_Func_1 return FullViewDefinite_Unknown_Disc; - - function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2; - -private - - type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is - record - S : String (1 .. D) := "Hi"; - end record; - - type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with - record - S : Sub_Type; - end record; - -end C330001_0; - - --==================================================================-- - -package body C330001_0 is - - function Indef_Func_1 return FullViewDefinite_Unknown_Disc is - Var_1 : FullViewDefinite_Unknown_Disc; -- No need for explicit - -- constraints, use initial - begin -- values. - return Var_1; - end Indef_Func_1; - - ------------------------------------------------------------------ - function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is - Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P); - begin - return Var_2; - end Indef_Func_2; - -end C330001_0; - - --==================================================================-- - -with C330001_0; -pragma Elaborate(C330001_0); -- Insure that the functions can be called. -private -package C330001_0.C330001_1 is - - PrivateChild_Obj : Tag_W_Disc := (D => 4, C1 => "ACVC"); - - PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1 - := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15); - - -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in - -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization - -- expression. - - PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19); - - -- Since full view of FullViewDefinite_Unknown_Disc is definite in the - -- parent package, no initialization expression needed for - -- PrivateChild_Obj_03. - - PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc; - - PrivateChild_Obj_04 : Indefinite_No_Disc := (12, 15); - -end C330001_0.C330001_1; - - --==================================================================-- - -with C330001_0; -pragma Elaborate(C330001_0); -- Insure that the functions can be called. -package C330001_0.C330001_2 is - - PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1; - - PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (4); - - PublicChild_Obj_03 : Indefinite_No_Disc := (38, 72, 21, 59); - - PublicChild_Obj_04 : Indefinite_Tag_W_Disc := (D => 7, C1 => True); - - PublicChild_Obj_05 : Indefinite_Tag_W_Disc := PublicChild_Obj_04; - - PublicChild_Obj_06 : Indefinite_New_W_Disc (6); - - procedure Assign_Private_Obj_3; - - function Raised_CE_PublicChild_Obj return Boolean; - - function Raised_CE_PrivateChild_Obj return Boolean; - - -- The following functions check the private types defined in the parent - -- and the private child package from within the client program. - - function Verify_Public_Obj_1 return Boolean; - - function Verify_Public_Obj_2 return Boolean; - - function Verify_Private_Obj_1 return Boolean; - - function Verify_Private_Obj_2 return Boolean; - - function Verify_Private_Obj_3 return Boolean; - -end C330001_0.C330001_2; - - --==================================================================-- - -with Report; -with C330001_0.C330001_1; -package body C330001_0.C330001_2 is - - procedure Assign_Private_Obj_3 is - begin - C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha"); - end Assign_Private_Obj_3; - - ------------------------------------------------------------------ - function Raised_CE_PublicChild_Obj return Boolean is - begin - PublicChild_Obj_03 := (16, 13); -- C_E, can't change constraints - -- of PublicChild_Obj_03. - - Report.Failed ("Constraint_Error not raised - Public child"); - - -- Next line prevents dead assignment. - - Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image - (PublicChild_Obj_03'First) ); - return False; - - exception - when Constraint_Error => - return True; -- Exception is expected. - when others => - return False; - end Raised_CE_PublicChild_Obj; - - ------------------------------------------------------------------ - function Raised_CE_PrivateChild_Obj return Boolean is - begin - C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18); - -- C_E, can't change constraints - -- of PrivateChild_Obj_04. - - Report.Failed ("Constraint_Error not raised - Private child"); - - -- Next line prevents dead assignment. - - Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image - (C330001_0.C330001_1.PrivateChild_Obj_04'Last) ); - return False; - - exception - when Constraint_Error => - return True; -- Exception is expected. - when others => - return False; - end Raised_CE_PrivateChild_Obj; - - ------------------------------------------------------------------ - function Verify_Public_Obj_1 return Boolean is - begin - return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi"); - - end Verify_Public_Obj_1; - - ------------------------------------------------------------------ - function Verify_Public_Obj_2 return Boolean is - begin - return (PublicChild_Obj_02.D = 5 and - PublicChild_Obj_02.C1 = "Hello" and - PublicChild_Obj_02.S = 4); - - end Verify_Public_Obj_2; - - ------------------------------------------------------------------ - function Verify_Private_Obj_1 return Boolean is - begin - return (C330001_0.C330001_1.PrivateChild_Obj_01.D = 4 and - C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and - C330001_0.C330001_1.PrivateChild_Obj_01.S = 15); - - end Verify_Private_Obj_1; - - ------------------------------------------------------------------ - function Verify_Private_Obj_2 return Boolean is - begin - return (C330001_0.C330001_1.PrivateChild_Obj_02.D = 5 and - C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and - C330001_0.C330001_1.PrivateChild_Obj_02.S = 19); - - end Verify_Private_Obj_2; - - ------------------------------------------------------------------ - function Verify_Private_Obj_3 return Boolean is - begin - return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and - C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha"); - - end Verify_Private_Obj_3; - -end C330001_0.C330001_2; - - --==================================================================-- - -with C330001_0.C330001_2; -with Report; - -use C330001_0.C330001_2; - -procedure C330001 is -begin - Report.Test ("C330001", "Check that a variable object of an indefinite " & - "type is properly initialized/constrained by an initial " & - "value assignment that is a) an aggregate, b) a function, " & - "or c) an object. Check that objects of the above types " & - "do not need explicit constraints if they have initial " & - "values"); - - -- Verify values of public child objects. - - if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then - Report.Failed ("Wrong values for PublicChild_Obj_01 or " & - "PublicChild_Obj_02"); - end if; - - if PublicChild_Obj_03'First /= 1 or - PublicChild_Obj_03'Last /= 4 then - Report.Failed ("Wrong values for PublicChild_Obj_03"); - end if; - - if PublicChild_Obj_05.D /= 7 or - not PublicChild_Obj_05.C1 then - Report.Failed ("Wrong values for PublicChild_Obj_05"); - end if; - - if PublicChild_Obj_06.ND /= 6 or - PublicChild_Obj_06.C2 /= 9 or - PublicChild_Obj_06.C1 then - Report.Failed ("Wrong values for PublicChild_Obj_06"); - end if; - - -- Definite object can have its discriminant changed by assignment to - -- the entire object. - - Assign_Private_Obj_3; - - -- Verify values of private child objects. - - if not Verify_Private_Obj_1 or not - Verify_Private_Obj_2 or not - Verify_Private_Obj_3 then - Report.Failed ("Wrong values for PrivateChild_Obj_01 or " & - "PrivateChild_Obj_02 or PrivateChild_Obj_03"); - end if; - - -- Attempt to change the discriminants of the objects of the indefinite - -- subtypes: Constraint_Error. - - if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then - Report.Failed ("Constraint_Error not raised"); - end if; - - Report.Result; - -end C330001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c330002.a b/gcc/testsuite/ada/acats/tests/c3/c330002.a deleted file mode 100644 index 1403d5557b1..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c330002.a +++ /dev/null @@ -1,326 +0,0 @@ --- C330002.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 if a subtype indication of a variable object defines an --- indefinite subtype, then there is an initialization expression. --- Check that the object remains so constrained throughout its lifetime. --- Check for cases of tagged record, arrays and generic formal type. --- --- TEST DESCRIPTION: --- An indefinite subtype is either: --- a) An unconstrained array subtype. --- b) A subtype with unknown discriminants (this includes class-wide --- types). --- c) A subtype with unconstrained discriminants without defaults. --- --- Declare tagged types with unconstrained discriminants without --- defaults. Declare an unconstrained array. Declare a generic formal --- type with an unknown discriminant and a formal object of this type. --- In the generic package, declare an object of the formal type using --- the formal object as its initial value. In the main program, --- declare objects of tagged types. Instantiate the generic package. --- The test checks that Constraint_Error is raised if an attempt is --- made to change bounds as well as discriminants of the objects of the --- indefinite subtypes. --- --- --- CHANGE HISTORY: --- 01 Nov 95 SAIC Initial prerelease version. --- 27 Jul 96 SAIC Modified test description & Report.Test. Added --- code to prevent dead variable optimization. --- ---! - -package C330002_0 is - - subtype Small_Num is Integer range 1 .. 20; - - -- Types with unconstrained discriminants without defaults. - - type Tag_Type (Disc : Small_Num) is tagged - record - S : String (1 .. Disc); - end record; - - function Tag_Value return Tag_Type; - - procedure Assign_Tag (A : out Tag_Type); - - procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String); - - --------------------------------------------------------------------- - -- An unconstrained array type. - - type Array_Type is array (Positive range <>) of Integer; - - function Array_Value return Array_Type; - - procedure Assign_Array (A : out Array_Type); - - --------------------------------------------------------------------- - generic - -- Type with an unknown discriminant. - type Formal_Type (<>) is private; - FT_Obj : Formal_Type; - package Gen is - Gen_Obj : Formal_Type := FT_Obj; - end Gen; - -end C330002_0; - - --==================================================================-- - -with Report; -package body C330002_0 is - - procedure Assign_Tag (A : out Tag_Type) is - begin - A := (3, "Bye"); - end Assign_Tag; - - ---------------------------------------------------------------------- - procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is - Default : Tag_Type := (1, "!"); -- Unique value. - begin - if P = Default then -- Both If branches can't do the same thing. - Report.Failed (Msg & ": Constraint_Error not raised"); - else -- Subtests should always select this path. - Report.Failed ("Constraint_Error not raised " & Msg); - end if; - end Avoid_Optimization_and_Fail; - - ---------------------------------------------------------------------- - function Tag_Value return Tag_Type is - TO : Tag_Type := (4 , "ACVC"); - begin - return TO; - end Tag_Value; - - ---------------------------------------------------------------------- - function Array_Value return Array_Type is - IA : Array_Type := (20, 31); - begin - return IA; - end Array_Value; - - ---------------------------------------------------------------------- - procedure Assign_Array (A : out Array_Type) is - begin - A := (84, 36); - end Assign_Array; - -end C330002_0; - - --==================================================================-- - -with Report; -with C330002_0; -use C330002_0; - -procedure C330002 is - -begin - Report.Test ("C330002", "Check that if a subtype indication of a " & - "variable object defines an indefinite subtype, then " & - "there is an initialization expression. Check that " & - "the object remains so constrained throughout its " & - "lifetime. Check that Constraint_Error is raised " & - "if an attempt is made to change bounds as well as " & - "discriminants of the objects of the indefinite " & - "subtypes. Check for cases of tagged record and generic " & - "formal types"); - - TagObj_Block: - declare - TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is - -- aggregate. - TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is - -- an object. - TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is - -- function return value. - Ren_Obj : Tag_Type renames TObj_ByAgg; - - begin - - begin - if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then - Report.Failed ("Wrong initial values for TObj_ByAgg"); - end if; - - TObj_ByAgg := (2, "Hi"); -- C_E, can't change the - -- value of the discriminant. - - Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 1"); - end; - - - begin - Assign_Tag (Ren_Obj); -- C_E, can't change the - -- value of the discriminant. - - Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 2"); - end; - - - begin - if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then - Report.Failed ("Wrong initial values for TObj_ByObj"); - end if; - - TObj_ByObj := (3, "Bye"); -- C_E, can't change the - -- value of the discriminant. - - Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 3"); - end; - - - begin - if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then - Report.Failed ("Wrong initial values for TObj_ByFunc"); - end if; - - TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the - -- value of the discriminant. - - Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 4"); - end; - - end TagObj_Block; - - - ArrObj_Block: - declare - Arr_Const : constant Array_Type - := (9, 7, 6, 8); - Arr_ByAgg : Array_Type -- Initial assignment is - := (10, 11, 12); -- aggregate. - Arr_ByFunc : Array_Type -- Initial assignment is - := Array_Value; -- function return value. - Arr_ByObj : Array_Type -- Initial assignment is - := Arr_ByAgg; -- object. - - Arr_Obj : array (Positive range <>) of Integer - := (1, 2, 3, 4, 5); - begin - - begin - if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then - Report.Failed ("Wrong bounds for Arr_Const"); - end if; - - if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then - Report.Failed ("Wrong bounds for Arr_ByAgg"); - end if; - - if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then - Report.Failed ("Wrong bounds for Arr_ByFunc"); - end if; - - if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then - Report.Failed ("Wrong bounds for Arr_ByObj"); - end if; - - Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are - -- 1..3. - - Report.Failed ("Constraint_Error not raised - Subtest 5"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 5"); - end; - - - begin - if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then - Report.Failed ("Wrong bounds for Arr_Obj"); - end if; - - for I in 0 .. 5 loop - Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are - end loop; -- 1..5. - - Report.Failed ("Constraint_Error not raised - Subtest 6"); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 6"); - end; - - end ArrObj_Block; - - - GenericObj_Block: - declare - type Rec (Disc : Small_Num) is - record - S : Small_Num := Disc; - end record; - - Rec_Obj : Rec := (2, 2); - package IGen is new Gen (Rec, Rec_Obj); - - begin - IGen.Gen_Obj := (3, 3); -- C_E, can't change the - -- value of the discriminant. - - Report.Failed ("Constraint_Error not raised - Subtest 7"); - - -- Next line prevents dead assignment. - Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc)); - - exception - when Constraint_Error => null; -- Exception is expected. - when others => - Report.Failed ("Unexpected exception - Subtest 7"); - - end GenericObj_Block; - - Report.Result; - -end C330002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c332001.a b/gcc/testsuite/ada/acats/tests/c3/c332001.a deleted file mode 100644 index 21d65737304..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c332001.a +++ /dev/null @@ -1,226 +0,0 @@ --- C332001.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 static expression given for a number declaration may be --- of any numeric type. Check that the type of a named number is --- universal_integer or universal_real regardless of the type of the --- static expression that provides its value. --- --- TEST DESCRIPTION: --- This test defines a large cross section of mixed type named numbers. --- Well, obviously the named numbers don't have types (other than --- universal_integer and universal_real) associated with them. --- This test uses typed static values in the definition of several named --- numbers, and then mixes the named numbers to ensure that their typed --- origins do not interfere with the use of their values. --- --- --- CHANGE HISTORY: --- 10 OCT 95 SAIC Initial version --- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1 --- 24 NOV 98 RLB Removed decimal types to insure that this --- test is applicable to all implementations. --- ---! - ------------------------------------------------------------------ C332001_0 - -package C332001_0 is - - type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun ); - - type Integer_Type is range 0..1023; - - type Modular_Type is mod 256; - - type Floating_Type is digits 4; - - type Fixed_Type is delta 0.125 range -10.0 .. 10.0; - - type Mod_Array is array(Modular_Type) of Floating_Type; - - type Int_Array is array(Integer_Type) of Fixed_Type; - - type Record_Type is record - Pinkie : Integer_Type; - Ring : Modular_Type; - Middle : Floating_Type; - Index : Fixed_Type; - end record; - - Mod_Array_Object : Mod_Array; - Int_Array_Object : Int_Array; - - Record_Object : Record_Type; - - -- numeric_literals - - Nothing_New_Integer : constant := 1; - Nothing_New_Real : constant := 1.0; - - -- static constants - - Integ : constant Integer_Type := 2; - Modul : constant Modular_Type := 2; - Float : constant Floating_Type := 2.0; -- bad practice, good test - Fixed : constant Fixed_Type := 2.0; - - Named_Integer : constant := Integ; -- 2 - Named_Modular : constant := Modul; -- 2 - Named_Float : constant := Float; -- 2.0 - Named_Fixed : constant := Fixed; -- 2.0 - - -- function calls - -- parenthetical expressions - - Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4 - Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4 - Fn_Float : constant := (Float ** 2); -- 4.0 - Fn_Fixed : constant := - Fixed; -- -2.0 - -- attributes - - ITF : constant := Integer_Type'First; -- 0 - MTL : constant := Modular_Type'Last; -- 255 - MTM : constant := Modular_Type'Modulus; -- 256 - ENP : constant := Enumeration_Type'Pos(Ay); -- 3 - MTP : constant := Modular_Type'Pred(Modul); -- 1 - FTS : constant := Fixed_Type'Size; -- # impdef - ITS : constant := Integer_Type'Succ(Integ); -- 3 - - -- array attributes 'First, 'Last, 'Length - - MAFirst : constant := Mod_Array_Object'First; -- 0 - IALast : constant := Int_Array_Object'Last; -- 1023 - MAL : constant := Mod_Array_Object'Length; -- 255 - IAL : constant := Int_Array_Object'Length; -- 1024 - - -- type conversions - -- - -- F\T Int Mod Flt Fix - -- Int . X O X - -- Mod O . X O - -- Flt X O . X - -- Fix O X O . - - Int2Mod : constant := Modular_Type (Integ); -- 2 - Int2Fix : constant := Fixed_Type (Integ); -- 2.0 - Mod2Flt : constant := Floating_Type (Modul); -- 2.0 - Flt2Int : constant := Integer_Type(Float); -- 2 - Flt2Fix : constant := Fixed_Type (Float); -- 2.0 - Fix2Mod : constant := Modular_Type (Fixed); -- 2 - - procedure Check_Values; - - -- TRANSITION CHECKS - -- - -- The following were illegal in Ada83; they are now legal in Ada95 - -- - - Int_Base_First : constant := Integer'Base'First; -- # impdef - Int_First : constant := Integer'First; -- # impdef - Int_Last : constant := Integer'Last; -- # impdef - Int_Val : constant := Integer'Val(17); -- 17 - - -- END OF TRANSITION CHECKS - -end C332001_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C332001_0 is - - procedure Assert( Truth : Boolean; Message: String ) is - begin - if not Truth then - Report.Failed("Assertion " & Message & " not true" ); - end if; - end Assert; - - procedure Check_Values is - begin - - Assert( Nothing_New_Integer * Named_Integer = Named_Modular, - "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2 - Assert( Nothing_New_Real * Named_Float = Named_Fixed, - "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0 - - Assert( Fn_Integer = Int2Mod + Flt2Int, - "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2 - Assert( Fn_Modular = Flt2Int * 2, - "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2 - Assert( Fn_Float = Mod2Flt ** Fix2Mod, - "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2 - Assert( Fn_Fixed = (- Mod2Flt), - "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0) - - Assert( ITF = Modular_Type'First, - "ITF = Modular_Type'First" ); -- 0 = 0 - Assert( MTL < Integer_Type'Last, - "MTL < Integer_Type'Last" ); -- 255 < 1023 - Assert( MTM < Integer_Type'Last, - "MTM < Integer_Type'Last" ); -- 256 < 1023 - Assert( ENP > MTP, - "ENP > MTP" ); -- 3 > 1 - Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef... - "(FTS < MTL) or (FTS >= MTL)" ); -- True - Assert( FTS > ITS, - "FTS > ITS" ); -- impdef > 3 - - Assert( MAFirst = Int_Array_Object'First, - "MAFirst = Int_Array_Object'First" ); -- 0 = 0 - Assert( IALast > MAFirst, - "IALast > MAFirst" ); -- 1023 > 0 - Assert( MAL < IAL, - "MAL < IAL" ); -- 255 < 1024 - - Assert( Mod2Flt = Flt2Fix, - "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0 - - end Check_Values; - -end C332001_0; - -------------------------------------------------------------------- C332001 - -with Report; -with C332001_0; -procedure C332001 is - -begin -- Main test procedure. - - Report.Test ("C332001", "Check that the static expression given for a " & - "number declaration may be of any numeric type. " & - "Check that the type of the named number is " & - "universal_integer of universal_real regardless " & - "of the type of the static expression that " & - "provides its value" ); - - C332001_0.Check_Values; - - Report.Result; - -end C332001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c340001.a b/gcc/testsuite/ada/acats/tests/c3/c340001.a deleted file mode 100644 index dce98bdb05b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c340001.a +++ /dev/null @@ -1,470 +0,0 @@ --- C340001.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 user-defined equality operators are inherited by a --- derived type except when the derived type is a nonlimited record --- extension. In the latter case, ensure that the primitive --- equality operation of the record extension compares any extended --- components according to the predefined equality operators of the --- component types. Also check that the parent portion of the extended --- type is compared using the user-defined equality operation of the --- parent type. --- --- TEST DESCRIPTION: --- Declares a nonlimited tagged record and a limited tagged record --- type, each in a separate package. A user-defined "=" operation is --- defined for each type. Each type is extended with one new record --- component added. --- --- Objects are declared for each parent and extended types and are --- assigned values. For the limited type, modifier operations defined --- in the package are used to assign values. --- --- To verify the use of the user-defined "=", values are assigned so --- that predefined equality will return the opposite result if called. --- Similarly, values are assigned to the extended type objects so that --- one comparison will verify that the inherited components from the --- parent are compared using the user-defined equality operation. --- --- A second comparison sets the values of the inherited components to --- be the same so that equality based on the extended component may be --- verified. For the nonlimited type, the test for equality should --- fail, as the "=" defined for this type should include testing --- equality of the extended component. For the limited type, "=" of the --- parent should be inherited as-is, so the test for equality should --- succeed even though the records differ in the extended component. --- --- A third package declares a discriminated tagged record. Equality --- is user-defined and ignores the discriminant value. A type --- extension is declared which also contains a discriminant. Since --- an inherited discriminant may not be referenced other than in a --- "new" discriminant, the type extension is also discriminated. The --- discriminant is used as the constraint for the parent type. --- --- A variant part is declared in the type extension based on the new --- discriminant. Comparisons are made to confirm that the user-defined --- equality operator is used to compare values of the type extension. --- Two record objects are given values so that user-defined equality --- for the parent portion of the record succeeds, but the variant --- parts in the type extended object differ. These objects are checked --- to ensure that they are not equal. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- ---! - -with Ada.Calendar; -package C340001_0 is - - type DB_Record is tagged record - Key : Natural range 1 .. 9999; - Data : String (1..10); - end record; - - function "=" (L, R : in DB_Record) return Boolean; - - type Dated_Record is new DB_Record with record - Retrieval_Time : Ada.Calendar.Time; - end record; - -end C340001_0; - -package body C340001_0 is - - function "=" (L, R : in DB_Record) return Boolean is - -- Key is ignored in determining equality of records - begin - return L.Data = R.Data; - end "="; - -end C340001_0; - -package C340001_1 is - - type List_Contents is array (1..10) of Integer; - type List is tagged limited record - Length : Natural range 0..10 := 0; - Contents : List_Contents := (others => 0); - end record; - - procedure Add_To (L : in out List; New_Value : in Integer); - procedure Remove_From (L : in out List); - - function "=" (L, R : in List) return Boolean; - - subtype Revision_Mark is Character range 'A' .. 'Z'; - type Revisable_List is new List with record - Revision : Revision_Mark := 'A'; - end record; - - procedure Revise (L : in out Revisable_List); - -end C340001_1; - -package body C340001_1 is - - -- Note: This is not a complete abstraction of a list. Exceptions - -- are not defined and boundary checks are not made. - - procedure Add_To (L : in out List; New_Value : in Integer) is - begin - L.Length := L.Length + 1; - L.Contents (L.Length) := New_Value; - end Add_To; - - procedure Remove_From (L : in out List) is - -- The list length is decremented. "Old" values are left in the - -- array. They are overwritten when a new value is added. - begin - L.Length := L.Length - 1; - end Remove_From; - - function "=" (L, R : in List) return Boolean is - -- Two lists are equal if they are the same length and - -- the component values within that length are the same. - -- Values stored past the end of the list are ignored. - begin - return L.Length = R.Length - and then L.Contents (1..L.Length) = R.Contents (1..R.Length); - end "="; - - procedure Revise (L : in out Revisable_List) is - begin - L.Revision := Character'Succ (L.Revision); - end Revise; - -end C340001_1; - -package C340001_2 is - - type Media is (Paper, Electronic); - - type Transaction (Medium : Media) is tagged record - ID : Natural range 1000 .. 9999; - end record; - - function "=" (L, R : in Transaction) return Boolean; - - type Authorization (Kind : Media) is new Transaction (Medium => Kind) - with record - case Kind is - when Paper => - Signature_On_File : Boolean; - when Electronic => - Paper_Backup : Boolean; -- to retain opposing value - end case; - end record; - -end C340001_2; - -package body C340001_2 is - - function "=" (L, R : in Transaction) return Boolean is - -- There may be electronic and paper copies of the same transaction. - -- The ID uniquely identifies a transaction. The medium (stored in - -- the discriminant) is ignored. - begin - return L.ID = R.ID; - end "="; - -end C340001_2; - - -with C340001_0; -- nonlimited tagged record declarations -with C340001_1; -- limited tagged record declarations -with C340001_2; -- tagged variant declarations -with Ada.Calendar; -with Report; -procedure C340001 is - - DB_Rec1 : C340001_0.DB_Record := (Key => 1, - Data => "aaaaaaaaaa"); - DB_Rec2 : C340001_0.DB_Record := (Key => 55, - Data => "aaaaaaaaaa"); - -- DB_Rec1 = DB_Rec2 using user-defined equality - -- DB_Rec1 /= DB_Rec2 using predefined equality - - Some_Time : Ada.Calendar.Time := - Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993); - - Another_Time : Ada.Calendar.Time := - Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993); - - Dated_Rec1 : C340001_0.Dated_Record := (Key => 2, - Data => "aaaaaaaaaa", - Retrieval_Time => Some_Time); - Dated_Rec2 : C340001_0.Dated_Record := (Key => 77, - Data => "aaaaaaaaaa", - Retrieval_Time => Some_Time); - Dated_Rec3 : C340001_0.Dated_Record := (Key => 77, - Data => "aaaaaaaaaa", - Retrieval_Time => Another_Time); - -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion - -- Dated_Rec2 /= Dated_Rec3 if extended component is compared - -- using Ada.Calendar.Time."=" - - List1 : C340001_1.List; - List2 : C340001_1.List; - - RList1 : C340001_1.Revisable_List; - RList2 : C340001_1.Revisable_List; - RList3 : C340001_1.Revisable_List; - - Current : C340001_2.Transaction (C340001_2.Paper) := - (C340001_2.Paper, 2001); - Last : C340001_2.Transaction (C340001_2.Electronic) := - (C340001_2.Electronic, 2001); - -- Current = Last using user-defined equality - -- Current /= Last using predefined equality - - Approval1 : C340001_2.Authorization (C340001_2.Paper) - := (Kind => C340001_2.Paper, - ID => 1040, - Signature_On_File => True); - Approval2 : C340001_2.Authorization (C340001_2.Paper) - := (Kind => C340001_2.Paper, - ID => 2167, - Signature_On_File => False); - Approval3 : C340001_2.Authorization (C340001_2.Electronic) - := (Kind => C340001_2.Electronic, - ID => 2167, - Paper_Backup => False); - -- Approval1 /= Approval2 if user-defined equality extended with - -- component equality. - -- Approval2 /= Approval3 if differing variant parts checked - - -- Direct visibility to operator symbols - use type C340001_0.DB_Record; - use type C340001_0.Dated_Record; - - use type C340001_1.List; - use type C340001_1.Revisable_List; - - use type C340001_2.Transaction; - use type C340001_2.Authorization; - -begin - - Report.Test ("C340001", "Inheritance of user-defined ""="""); - - -- Approval1 /= Approval2 if user-defined equality extended with - -- component equality. - -- Approval2 /= Approval3 if differing variant parts checked - - --------------------------------------------------------------------- - -- Check that "=" and "/=" for the parent type call the user-defined - -- operation - --------------------------------------------------------------------- - - if not (DB_Rec1 = DB_Rec2) then - Report.Failed ("Nonlimited tagged record: " & - "User-defined equality did not override predefined " & - "equality"); - end if; - - if DB_Rec1 /= DB_Rec2 then - Report.Failed ("Nonlimited tagged record: " & - "User-defined equality did not override predefined " & - "inequality as well"); - end if; - - --------------------------------------------------------------------- - -- Check that "=" and "/=" for the type extension use the user-defined - -- equality operations from the parent to compare the inherited - -- components - --------------------------------------------------------------------- - - if not (Dated_Rec1 = Dated_Rec2) then - Report.Failed ("Nonlimited tagged record: " & - "User-defined equality was not used to compare " & - "components inherited from parent"); - end if; - - if Dated_Rec1 /= Dated_Rec2 then - Report.Failed ("Nonlimited tagged record: " & - "User-defined inequality was not used to compare " & - "components inherited from parent"); - end if; - - --------------------------------------------------------------------- - -- Check that equality and inequality for the type extension incorporate - -- the predefined equality operators for the extended component type - --------------------------------------------------------------------- - if Dated_Rec2 = Dated_Rec3 then - Report.Failed ("Nonlimited tagged record: " & - "Record equality was not extended with component " & - "equality"); - end if; - - if not (Dated_Rec2 /= Dated_Rec3) then - Report.Failed ("Nonlimited tagged record: " & - "Record inequality was not extended with component " & - "equality"); - end if; - - --------------------------------------------------------------------- - C340001_1.Add_To (List1, 1); - C340001_1.Add_To (List1, 2); - C340001_1.Add_To (List1, 3); - C340001_1.Remove_From (List1); - - C340001_1.Add_To (List2, 1); - C340001_1.Add_To (List2, 2); - - -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0)) - -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0)) - - -- List1 = List2 using user-defined equality - -- List1 /= List2 using predefined equality - - --------------------------------------------------------------------- - -- Check that "=" and "/=" for the parent type call the user-defined - -- operation - --------------------------------------------------------------------- - if not (List1 = List2) then - Report.Failed ("Limited tagged record : " & - "User-defined equality incorrectly implemented " ); - end if; - - if List1 /= List2 then - Report.Failed ("Limited tagged record : " & - "User-defined equality incorrectly implemented " ); - end if; - - --------------------------------------------------------------------- - -- RList1 and RList2 are made equal but "different" by adding - -- a nonzero value to RList1 then removing it. Removal updates - -- the list Length only, not its contents. The two lists will be - -- equal according to the defined list abstraction, but the records - -- will contain differing component values. - - C340001_1.Add_To (RList1, 1); - C340001_1.Add_To (RList1, 2); - C340001_1.Add_To (RList1, 3); - C340001_1.Remove_From (RList1); - - C340001_1.Add_To (RList2, 1); - C340001_1.Add_To (RList2, 2); - - C340001_1.Add_To (RList3, 1); - C340001_1.Add_To (RList3, 2); - - C340001_1.Revise (RList3); - - -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A') - -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A') - -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B') - - -- RList1 = RList2 if List."=" inherited - -- RList2 /= RList3 if List."=" inherited and extended with Character "=" - - --------------------------------------------------------------------- - -- Check that "=" and "/=" are the user-defined operations inherited - -- from the parent type. - --------------------------------------------------------------------- - if not (RList1 = RList2) then - Report.Failed ("Limited tagged record : " & - "User-defined equality was not inherited"); - end if; - - if RList1 /= RList2 then - Report.Failed ("Limited tagged record : " & - "User-defined inequality was not inherited"); - end if; - --------------------------------------------------------------------- - -- Check that "=" and "/=" for the type extension are NOT extended - -- with the predefined equality operators for the extended component. - -- A limited type extension should inherit the parent equality operation - -- as is. - --------------------------------------------------------------------- - if not (RList2 = RList3) then - Report.Failed ("Limited tagged record : " & - "Inherited equality operation was extended with " & - "component equality"); - end if; - - if RList2 /= RList3 then - Report.Failed ("Limited tagged record : " & - "Inherited inequality operation was extended with " & - "component equality"); - end if; - - --------------------------------------------------------------------- - -- Check that "=" and "/=" for the parent type call the user-defined - -- operation - --------------------------------------------------------------------- - if not (Current = Last) then - Report.Failed ("Variant record : " & - "User-defined equality did not override predefined " & - "equality"); - end if; - - if Current /= Last then - Report.Failed ("Variant record : " & - "User-defined inequality did not override predefined " & - "inequality"); - end if; - - --------------------------------------------------------------------- - -- Check that user-defined equality was incorporated and extended - -- with equality of extended components. - --------------------------------------------------------------------- - if not (Approval1 /= Approval2) then - Report.Failed ("Variant record : " & - "Inequality was not extended with component " & - "inequality"); - end if; - - if Approval1 = Approval2 then - Report.Failed ("Variant record : " & - "Equality was not extended with component " & - "equality"); - end if; - - --------------------------------------------------------------------- - -- Check that equality and inequality for the type extension - -- succeed despite the presence of differing variant parts. - --------------------------------------------------------------------- - if Approval2 = Approval3 then - Report.Failed ("Variant record : " & - "Equality succeeded even though variant parts " & - "in type extension differ"); - end if; - - if not (Approval2 /= Approval3) then - Report.Failed ("Variant record : " & - "Inequality failed even though variant parts " & - "in type extension differ"); - end if; - - --------------------------------------------------------------------- - Report.Result; - --------------------------------------------------------------------- - -end C340001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a01.a b/gcc/testsuite/ada/acats/tests/c3/c340a01.a deleted file mode 100644 index 108a30b5ff6..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c340a01.a +++ /dev/null @@ -1,165 +0,0 @@ --- C340A01.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 tagged type declared in a package specification --- may be passed as a generic formal (tagged) private type to a generic --- package declaration. Check that the formal type may be extended with --- a record extension in the generic package. --- --- Check that, in the instance, the record extension inherits the --- user-defined primitive subprograms of the tagged actual. --- --- TEST DESCRIPTION: --- Declare a tagged type and an associated primitive subprogram in a --- package specification (foundation code). Declare a generic package --- which takes a tagged type as a formal parameter, and then extends --- it with a record extension (foundation code). --- --- Instantiate the generic package with the tagged type from the first --- package (the "generic" extension should now have inherited --- the primitive subprogram of the tagged type from the first --- package). --- --- In the main program, call the primitive subprogram inherited by the --- "generic" extension, and verify the correctness of the components. --- --- TEST FILES: --- This test consists of the following files: --- --- F340A000.A --- F340A001.A --- => C340A01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous --- comments. --- ---! - -with F340A001; -- Book definitions. -package C340A01_0 is -- Raw data to be used in creating book elements. - - - Book_Count : constant := 3; - - subtype Number_Of_Books is Integer range 1 .. Book_Count; - - type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; - - Title_List : Data_List := (new String'("Wuthering Heights"), - new String'("Heart of Darkness"), - new String'("Ulysses")); - - Author_List : Data_List := (new String'("Bronte, Emily"), - new String'("Conrad, Joseph"), - new String'("Joyce, James")); - -end C340A01_0; - - - --==================================================================-- - - --- Library-level instantiation. Actual parameter is tagged record. - -with F340A001; -- Book definitions. -with F340A000; -- Singly-linked list abstraction. -package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type); - - - --==================================================================-- - - -with Report; - -with F340A001; -- Book definitions. -with C340A01_0; -- Raw book data. -with C340A01_1; -- Instance. - -use F340A001; -- Primitive operations of Book_Type directly visible. -use C340A01_1; -- Operations inherited by Node_Type directly visible. - -procedure C340A01 is - - - List_Of_Books : Node_Ptr := null; -- Head of linked list of books. - - - --========================================================-- - - - procedure Create_List (Title, Author : in C340A01_0.Data_List; - Head : in out Node_Ptr) is - - Book : Node_Type; -- Object of extended type. - Book_Ptr : Node_Ptr; - - begin - for I in C340A01_0.Number_Of_Books loop - Create_Book (Title (I), Author (I), Book); -- Call inherited - -- operation. - Book_Ptr := new Node_Type'(Book); - Add (Book_Ptr, Head); - end loop; - end Create_List; - - - --========================================================-- - - - function Bad_List_Contents return Boolean is - begin - return (List_Of_Books.Title.all /= "Ulysses" or - List_Of_Books.Author.all /= "Joyce, James" or - List_Of_Books.Next.Title.all /= "Heart of Darkness" or - List_Of_Books.Next.Author.all /= "Conrad, Joseph" or - List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or - List_Of_Books.Next.Next.Author.all /= "Bronte, Emily"); - end Bad_List_Contents; - - - --========================================================-- - - -begin -- Main program. - - Report.Test ("C340A01", "Inheritance of primitive operations: record " & - "extension of formal tagged private type; actual is " & - "an ultimate ancestor type"); - - -- Create linked list using inherited operation: - Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books); - - -- Verify results: - if Bad_List_Contents then - Report.Failed ("Wrong values after call to inherited operation"); - end if; - - Report.Result; - -end C340A01; diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a02.a b/gcc/testsuite/ada/acats/tests/c3/c340a02.a deleted file mode 100644 index 2dd8f175c09..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c340a02.a +++ /dev/null @@ -1,221 +0,0 @@ --- C340A02.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 record extension (declared in a package specification) of --- a tagged type (declared in a different package specification) may be --- passed as a generic formal (tagged) private type to a generic package --- declaration. Check that the formal type may be further extended with a --- record extension in the generic package. --- --- Check that, in the instance, the record extension inherits the --- user-defined primitive subprograms of the tagged actual, including --- those inherited by the actual from its parent. --- --- TEST DESCRIPTION: --- Declare a tagged type and an associated primitive subprogram in a --- package specification (foundation code). Declare a record extension --- of the tagged type and an associated primitive subprogram in a second --- package specification. Declare a generic package which takes a tagged --- type as a formal parameter, and then extends it with a record --- extension (foundation code). --- --- Instantiate the generic package with the record extension from the --- second package (the "generic" extension should now have inherited --- the primitive subprograms of the record extension from the second --- package). --- --- In the main program, call the primitive subprograms inherited by the --- "generic" extension. There are two: (1) Create_Book, declared for --- the root tagged type in the first package (inherited by the record --- extension of the second package, and then in turn by the "generic" --- extension), and (2) Update_Pages, declared for the record extension --- in the second package. Verify the correctness of the components. --- --- TEST FILES: --- This test consists of the following files: --- --- F340A000.A --- F340A001.A --- => C340A02.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous --- comments. --- ---! - -with F340A001; -- Book definitions. -package C340A02_0 is -- Extended book abstraction. - - - type Detailed_Book_Type is new F340A001.Book_Type with record - Pages : Natural; -- Record ext. - end record; -- of root tagged - -- type. - - -- Inherits Create_Book from Book_Type. - - procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op. - Pages : in Natural); -- of extension. - - -end C340A02_0; - - - --==================================================================-- - - -package body C340A02_0 is - - - procedure Update_Pages (Book : in out Detailed_Book_Type; - Pages : in Natural) is - begin - Book.Pages := Pages; - end Update_Pages; - - -end C340A02_0; - - - --==================================================================-- - - -with F340A001; -- Book definitions. -package C340A02_1 is -- Raw data to be used in creating book elements. - - - Book_Count : constant := 3; - - subtype Number_Of_Books is Integer range 1 .. Book_Count; - - type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; - type Page_Counts is array (Number_Of_Books) of Natural; - - Title_List : Data_List := (new String'("Wuthering Heights"), - new String'("Heart of Darkness"), - new String'("Ulysses")); - - Author_List : Data_List := (new String'("Bronte, Emily"), - new String'("Conrad, Joseph"), - new String'("Joyce, James")); - - Page_List : Page_Counts := (237, 215, 456); - -end C340A02_1; - - - --==================================================================-- - - --- Library-level instantiation. Actual parameter is record extension. - -with C340A02_0; -- Extended book abstraction. -with F340A000; -- Singly-linked list abstraction. -package C340A02_2 is new F340A000 - (Parent_Type => C340A02_0.Detailed_Book_Type); - - - --==================================================================-- - - -with Report; - -with C340A02_0; -- Extended book abstraction. -with C340A02_1; -- Raw book data. -with C340A02_2; -- Instance. - -use C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible. -use C340A02_2; -- Operations inherited by Node_Type directly visible. - -procedure C340A02 is - - - List_Of_Books : Node_Ptr := null; -- Head of linked list of books. - - - --========================================================-- - - - procedure Create_List (Title, Author : in C340A02_1.Data_List; - Pages : in C340A02_1.Page_Counts; - Head : in out Node_Ptr) is - - Book : Node_Type; -- Object of extended type. - Book_Ptr : Node_Ptr; - - begin - for I in C340A02_1.Number_Of_Books loop - Create_Book (Title (I), Author (I), Book); -- Call twice-inherited - -- operation. - Update_Pages (Book, Pages (I)); -- Call inherited op. - Book_Ptr := new Node_Type'(Book); - Add (Book_Ptr, Head); - end loop; - end Create_List; - - - --========================================================-- - - - function Bad_List_Contents return Boolean is - begin - return (List_Of_Books.Title.all /= "Ulysses" or - List_Of_Books.Author.all /= "Joyce, James" or - List_Of_Books.Pages /= 456 or - List_Of_Books.Next.Title.all /= "Heart of Darkness" or - List_Of_Books.Next.Author.all /= "Conrad, Joseph" or - List_Of_Books.Next.Pages /= 215 or - List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or - List_Of_Books.Next.Next.Author.all /= "Bronte, Emily" or - List_Of_Books.Next.Next.Pages /= 237); - - end Bad_List_Contents; - - - --========================================================-- - - -begin -- Main program. - - Report.Test ("C340A02", "Inheritance of primitive operations: record " & - "extension of formal tagged private type; actual is " & - "a record extension"); - - -- Create linked list using inherited operation: - Create_List (C340A02_1.Title_List, C340A02_1.Author_List, - C340A02_1.Page_List, List_Of_Books); - - -- Verify results: - if Bad_List_Contents then - Report.Failed ("Wrong values after call to inherited operations"); - end if; - - Report.Result; - -end C340A02; diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a01.a b/gcc/testsuite/ada/acats/tests/c3/c341a01.a deleted file mode 100644 index 34a1eeeaac6..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c341a01.a +++ /dev/null @@ -1,117 +0,0 @@ --- C341A01.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 formal parameters of a class-wide type can be passed --- values of any specific type within the class. --- --- TEST DESCRIPTION: --- Define an object of a root tagged type and of various types derived --- from the root. Define objects of the root class, and initialize them --- by parameter association of objects of the specific types (root and --- extended types) within the class. --- --- The particular root and extended types used in this abstraction are --- defined in foundation code (F341A00.A), and are graphically displayed --- as follows: --- --- package Bank --- type Account --- | --- | --- | --- package Checking --- type Account --- | --- | --- | --- package Interest_Checking --- type Account --- --- --- TEST FILES: --- This test depends on the following foundation code: --- --- F341A00.A --- --- The following files comprise this test: --- --- => C341A01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with F341A00_0; -- package Bank -with F341A00_1; -- package Checking -with F341A00_2; -- package Interest_Checking -with Report; - -procedure C341A01 is - - package Bank renames F341A00_0; - use type Bank.Dollar_Amount; - package Checking renames F341A00_1; - package Interest_Checking renames F341A00_2; - - Max_Accts : constant := 3; - Bank_Balance : Bank.Dollar_Amount := 0.00; - - -- Initialize objects of specific tagged types. - B_Acct : Bank.Account := (Current_Balance => 10.00); - C_Acct : Checking.Account := (100.00, 10.00); - IC_Acct : Interest_Checking.Account := (1000.00, 10.00, 0.030); - - -- Define and initialize (by parameter association) objects of class-wide - -- type originating from the root type (Bank.Account). - - -- Define an account auditing procedure with a class-wide - -- variable that can hold a value of any object within the class. - procedure Audit (Next_Account : Bank.Account'Class) is - begin - Bank_Balance := Bank_Balance + Next_Account.Current_Balance; - end Audit; - - -begin -- C341A01 - - Report.Test ("C341A01", "Check that objects of a class-wide type can " & - "be initialized, by direct assignment, to a " & - "value of any specific type within the class" ); - - -- Perform nightly audit of total funds on deposit in bank. - Audit (B_Acct); - Audit (C_Acct); - Audit (IC_Acct); - - if Bank_Balance /= 1110.00 then - Report.Failed ("Class-wide object processing failed"); - end if; - - Report.Result; - -end C341A01; diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a02.a b/gcc/testsuite/ada/acats/tests/c3/c341a02.a deleted file mode 100644 index 4fa9842bf60..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c341a02.a +++ /dev/null @@ -1,145 +0,0 @@ --- C341A02.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 class-wide objects can be reassigned with objects from - -- the same specific type used to initialize them. - -- - -- TEST DESCRIPTION: - -- Define new objects of specific types from within a class. Reassign - -- previously declared class-wide objects with the new specific type - -- objects. Check that new assignments were performed. - -- - -- The particular root and extended types used in this abstraction are - -- defined in foundation code (F341A00.A), and are graphically displayed - -- as follows: - -- - -- package Bank - -- type Account - -- | - -- | - -- | - -- package Checking - -- type Account - -- | - -- | - -- | - -- package Interest_Checking - -- type Account - -- - -- TEST FILES: - -- This test depends on the following foundation code: - -- - -- F341A00.A - -- - -- The following files comprise this test: - -- - -- => C341A02.A - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - with F341A00_0; -- package Bank - with F341A00_1; -- package Checking - with F341A00_2; -- package Interest_Checking - with Report; - - procedure C341A02 is - - package Bank renames F341A00_0; - package Checking renames F341A00_1; - package Interest_Checking renames F341A00_2; - - Max_Accts : constant := 3; - Bank_Balance : Bank.Dollar_Amount := 0.00; - - -- Define and initialize objects of specific types. - B_Acct : aliased Bank.Account := (Current_Balance => 10.00); - C_Acct : aliased Checking.Account := (100.00, 10.00); - IC_Acct : aliased Interest_Checking.Account := (1000.00, 10.00, 0.030); - New_B_Acct : aliased Bank.Account := (Current_Balance => 20.00); - New_C_Acct : aliased Checking.Account := (200.00, 20.00); - New_IC_Acct : aliased Interest_Checking.Account := (2000.00, 20.00, 0.060); - - - -- Define and initialize (by direct assignment) objects of a class-wide - -- type originating from the root type (Bank.Account). - - type ATM_Card is access all Bank.Account'Class; - - Accounts : array (1 .. Max_Accts) of ATM_Card := - (1 => B_Acct'Access, 2 => C_Acct'Access, 3 => IC_Acct'Access); - - New_Accounts : array (1 .. Max_Accts) of ATM_Card := - (1 => New_B_Acct'Access, - 2 => New_C_Acct'Access, - 3 => New_IC_Acct'Access); - - -- Define an account auditing procedure with a class-wide - -- variable that can hold a value of any object within the class, - -- and once initialized, can hold other values of the same specific type. - - procedure Audit (Num : in integer; - Amt : out Bank.Dollar_Amount) is - Account_Being_Audited : Bank.Account'Class := Accounts(Num).all; - use type Bank.Dollar_Amount; - begin - Amt := Account_Being_Audited.Current_Balance; - -- Reassign class-wide variable to another object of the type used to - -- initialize it. - Account_Being_Audited := New_Accounts(Num).all; - Amt := Amt + Account_Being_Audited.Current_Balance; -- Reading OUT - end Audit; -- parameter. - - - begin - - Report.Test ("C341A02", "Check that class-wide objects can be " & - "reassigned with objects from the same " & - "specific type used to initialize them" ); - Night_Audit: - declare - use type Bank.Dollar_Amount; - Acct_Value : Bank.Dollar_Amount := 0.00; - begin - -- Perform nightly audit of total funds on deposit in bank. - for i in 1 .. Max_Accts loop - Audit (i, Acct_Value); - Bank_Balance := Bank_Balance + Acct_Value; - end loop; - - if Bank_Balance /= 3330.00 then - Report.Failed ("Class-wide object processing failed"); - end if; - - end Night_Audit; - - Report.Result; - - end C341A02; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a03.a b/gcc/testsuite/ada/acats/tests/c3/c341a03.a deleted file mode 100644 index 0911e636d57..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c341a03.a +++ /dev/null @@ -1,140 +0,0 @@ --- C341A03.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 object of one class-wide type can initialize a --- class-wide object of a different type when the operation is embedded --- in a generic unit. --- --- TEST DESCRIPTION: --- Declare specific-type objects of an extended type. Declare an array --- of access values designating class-wide objects, initialized to point --- to the objects of the specific type. Define a generic subprogram --- having a generic formal derived type parameter. Within the generic, --- declare a class-wide variable of the formal parameter type. Verify --- that the variable can be initialized with the value of an object --- of another class-wide type within the class. --- --- The particular root and extended types used in this abstraction are --- defined in foundation code (F341A00.A), and are graphically displayed --- as follows: --- --- package Bank --- type Account --- | --- | --- | --- package Checking --- type Account --- | --- | --- | --- package Interest_Checking --- type Account --- --- TEST FILES: --- This test depends on the following foundation code: --- --- F341A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Dec 94 SAIC Changed level of 'Class for ATM_Card --- ---! - -with F341A00_0; -- package Bank -generic - type Account_Type is new F341A00_0.Account with private; -- new Bank.Account -function C341A03_0 (The_Account : Account_Type'Class) -- function Audit - return F341A00_0.Dollar_Amount; - -function C341A03_0 (The_Account : Account_Type'Class) - return F341A00_0.Dollar_Amount is - Acct : Account_Type'Class := The_Account; -- Init. of class-wide with -begin -- another class-wide object. - return Acct.Current_Balance; -end C341A03_0; - - - --=================================================================-- - - -with F341A00_0; -- package Bank -with F341A00_1; -- package Checking -with C341A03_0; -- generic function Audit -with Report; - -procedure C341A03 is - - package Bank renames F341A00_0; - package Checking renames F341A00_1; - - Current_Checking_Accounts : constant := 3; - - Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00, - Overdraft_Fee => 5.00); - Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00, - Overdraft_Fee => 5.00); - Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00, - Overdraft_Fee => 5.00); - - type ATM_Card is access all Checking.Account'Class; - - -- Declare array of accesses to class-wide objects. - Account_Array : array (1 .. Current_Checking_Accounts) of - ATM_Card := (Checking_Acct1'Access, - Checking_Acct2'Access, - Checking_Acct3'Access); -begin -- C341A03 - - Report.Test ("C341A03", "Check that an object of one class-wide type " & - "can initialize a class-wide object of a " & - "different type when the operation is embedded " & - "in a generic unit" ); - - Audit_Checking_Accounts: - declare - Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00; - -- Instantiate with a specific extended type. - function Checking_Audit is new C341A03_0 (Checking.Account); - use type Bank.Dollar_Amount; - begin - - for I in 1 .. Current_Checking_Accounts loop - Balance_In_Checking_Accounts := Balance_In_Checking_Accounts + - Checking_Audit (Account_Array (I).all); - end loop; - - if Balance_In_Checking_Accounts /= 60.00 then - Report.Failed ("Incorrect initialization of class-wide object"); - end if; - - end Audit_Checking_Accounts; - - Report.Result; - -end C341A03; diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a04.a b/gcc/testsuite/ada/acats/tests/c3/c341a04.a deleted file mode 100644 index d7392568e48..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c341a04.a +++ /dev/null @@ -1,141 +0,0 @@ --- C341A04.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 class-wide objects can be initialized using allocation. - -- - -- TEST DESCRIPTION: - -- Declare access types that refer to class-wide types, one with basis - -- of the root type, another with basis of a type extended from the root. - -- Declare objects of these access types, and allocate class-wide - -- objects, initialized to values of specific types within the particular - -- classes. - -- - -- The particular root and extended types used in this abstraction are - -- defined in foundation code (F341A00.A), and are graphically displayed - -- as follows: - -- - -- package Bank - -- type Account - -- | - -- | - -- | - -- package Checking - -- type Account - -- | - -- | - -- | - -- package Interest_Checking - -- type Account - -- - -- TEST FILES: - -- This test depends on the following foundation code: - -- - -- F341A00.A - -- - -- The following files comprise this test: - -- - -- => C341A04.A - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - with F341A00_0; -- package Bank - with F341A00_1; -- package Checking - with F341A00_2; -- package Interest_Checking - with Report; - - procedure C341A04 is - - package Bank renames F341A00_0; - package Checking renames F341A00_1; - package Interest_Checking renames F341A00_2; - - use type Bank.Dollar_Amount; - - Max_Accts : constant := 3; - Bank_Balance : Bank.Dollar_Amount := 0.00; - - -- Define access types referring to class of types rooted at - -- Bank.Account (root). - - type Bank_Account_Pointer is access Bank.Account'Class; - - -- - -- Define class-wide objects, initializing them through allocation. - -- - - -- Initialized to specific type that is basis of class. - Bank_Acct : Bank_Account_Pointer := - new Bank.Account'(Current_Balance => 10.00); - - -- Initialized to specific type that has been extended from the basis - -- of the class. - Checking_Acct : Bank_Account_Pointer := - new Checking.Account'(Current_Balance => 100.00, - Overdraft_Fee => 10.00); - - -- Initialized to specific type that has been twice extended from the - -- basis of the class. - IC_Acct : Bank_Account_Pointer := - new Interest_Checking.Account'(Current_Balance => 1000.00, - Overdraft_Fee => 10.00, - Rate => 0.030); - - -- Declare and initialize array of pointers to objects of - -- Bank.Account'Class. - - Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer := - (Bank_Acct, Checking_Acct, IC_Acct); - - - -- Audit will process any account object within Bank.Account'Class. - - function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is - begin - return (Ptr.Current_Balance); - end Audit; - - - begin -- C341A04 - - Report.Test ("C341A04", "Check that class-wide objects were " & - "successfully initialized using allocation" ); - - for i in 1 .. Max_Accts loop - Bank_Balance := Bank_Balance + Audit (Accounts(i)); - end loop; - - if Bank_Balance /= 1110.00 then - Report.Failed ("Failed class-wide object allocation"); - end if; - - Report.Result; - - end C341A04; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c352001.a b/gcc/testsuite/ada/acats/tests/c3/c352001.a deleted file mode 100644 index 04b094f1ff3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c352001.a +++ /dev/null @@ -1,270 +0,0 @@ --- --- C352001.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 predefined Character type comprises 256 positions. --- Check that the names of the non-graphic characters are usable with --- the attributes (Wide_)Image and (Wide_)Value, and that these --- attributes produce the correct result. --- --- TEST DESCRIPTION: --- Build two tables of nongraphic characters from positions of Row 00 --- (0000-001F and 007F-009F) of the ISO 10646 Basic Multilingual Plane. --- Fill the first table with compiler created strings. Fill the second --- table with strings defined by the language. Compare the two tables. --- Check 256 positions of the predefined character type. Use attributes --- (Wide_)Image and (Wide_)Value to check the values of the non-graphic --- characters and the last 2 characters. --- --- --- CHANGE HISTORY: --- 20 Jun 95 SAIC Initial prerelease version. --- 27 Jan 96 SAIC Revised for 2.1. Hid values, added "del" case. --- ---! - -with Ada.Characters.Handling; -with Report; -procedure C352001 is - - Lower_Bound : Integer := 0; - Middle_Bound : Integer := 31; - Upper_Bound : Integer := 159; - Half_Bound : Integer := 127; - Max_Bound : Integer := 255; - - type Dyn_String is access String; - type Value_Result is array (Character) of Dyn_String; - - Table_Of_Character : Value_Result; - TC_Table : Value_Result; - - function CVII(K : Natural) return Character is - begin - return Character'Val( Report.Ident_Int(K) ); - end CVII; - - function "=" (L, R : String) return Boolean is - UCL : String (L'First .. L'Last); - UCR : String (R'First .. R'last); - begin - UCL := Ada.Characters.Handling.To_Upper (L); - UCR := Ada.Characters.Handling.To_Upper (R); - if UCL'Last /= UCR'Last then - return False; - else - for I in UCL'First .. UCR'Last loop - if UCL (I) /= UCR (I) then - return False; - end if; - end loop; - return True; - end if; - end "="; - -begin - - Report.Test ("C352001", "Check that, the predefined Character type " & - "comprises 256 positions. Check that the names of the " & - "non-graphic characters are usable with the attributes " & - "(Wide_)Image and (Wide_)Value, and that these attributes " & - "produce the correct result"); - - -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO - -- 10646 Basic Multilingual Plane created by the compiler. - - for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop - Table_Of_Character (I) := new String'(Character'Image(I)); - end loop; - - -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO - -- 10646 Basic Multilingual Plane created by the compiler. - - for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop - Table_Of_Character (I) := new String'(Character'Image(I)); - end loop; - - -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO - -- 10646 Basic Multilingual Plane defined by the language. - - TC_Table (CVII(0)) := new String'("nul"); - TC_Table (CVII(1)) := new String'("soh"); - TC_Table (CVII(2)) := new String'("stx"); - TC_Table (CVII(3)) := new String'("etx"); - TC_Table (CVII(4)) := new String'("eot"); - TC_Table (CVII(5)) := new String'("enq"); - TC_Table (CVII(6)) := new String'("ack"); - TC_Table (CVII(7)) := new String'("bel"); - TC_Table (CVII(8)) := new String'("bs"); - TC_Table (CVII(9)) := new String'("ht"); - TC_Table (CVII(10)) := new String'("lf"); - TC_Table (CVII(11)) := new String'("vt"); - TC_Table (CVII(12)) := new String'("ff"); - TC_Table (CVII(13)) := new String'("cr"); - TC_Table (CVII(14)) := new String'("so"); - TC_Table (CVII(15)) := new String'("si"); - TC_Table (CVII(16)) := new String'("dle"); - TC_Table (CVII(17)) := new String'("dc1"); - TC_Table (CVII(18)) := new String'("dc2"); - TC_Table (CVII(19)) := new String'("dc3"); - TC_Table (CVII(20)) := new String'("dc4"); - TC_Table (CVII(21)) := new String'("nak"); - TC_Table (CVII(22)) := new String'("syn"); - TC_Table (CVII(23)) := new String'("etb"); - TC_Table (CVII(24)) := new String'("can"); - TC_Table (CVII(25)) := new String'("em"); - TC_Table (CVII(26)) := new String'("sub"); - TC_Table (CVII(27)) := new String'("esc"); - TC_Table (CVII(28)) := new String'("fs"); - TC_Table (CVII(29)) := new String'("gs"); - TC_Table (CVII(30)) := new String'("rs"); - TC_Table (CVII(31)) := new String'("us"); - TC_Table (CVII(127)) := new String'("del"); - - -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO - -- 10646 Basic Multilingual Plane defined by the language. - - TC_Table (CVII(128)) := new String'("reserved_128"); - TC_Table (CVII(129)) := new String'("reserved_129"); - TC_Table (CVII(130)) := new String'("bph"); - TC_Table (CVII(131)) := new String'("nbh"); - TC_Table (CVII(132)) := new String'("reserved_132"); - TC_Table (CVII(133)) := new String'("nel"); - TC_Table (CVII(134)) := new String'("ssa"); - TC_Table (CVII(135)) := new String'("esa"); - TC_Table (CVII(136)) := new String'("hts"); - TC_Table (CVII(137)) := new String'("htj"); - TC_Table (CVII(138)) := new String'("vts"); - TC_Table (CVII(139)) := new String'("pld"); - TC_Table (CVII(140)) := new String'("plu"); - TC_Table (CVII(141)) := new String'("ri"); - TC_Table (CVII(142)) := new String'("ss2"); - TC_Table (CVII(143)) := new String'("ss3"); - TC_Table (CVII(144)) := new String'("dcs"); - TC_Table (CVII(145)) := new String'("pu1"); - TC_Table (CVII(146)) := new String'("pu2"); - TC_Table (CVII(147)) := new String'("sts"); - TC_Table (CVII(148)) := new String'("cch"); - TC_Table (CVII(149)) := new String'("mw"); - TC_Table (CVII(150)) := new String'("spa"); - TC_Table (CVII(151)) := new String'("epa"); - TC_Table (CVII(152)) := new String'("sos"); - TC_Table (CVII(153)) := new String'("reserved_153"); - TC_Table (CVII(154)) := new String'("sci"); - TC_Table (CVII(155)) := new String'("csi"); - TC_Table (CVII(156)) := new String'("st"); - TC_Table (CVII(157)) := new String'("osc"); - TC_Table (CVII(158)) := new String'("pm"); - TC_Table (CVII(159)) := new String'("apc"); - - - -- Compare the first half of two tables. - for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop - if TC_Table(I).all /= Table_Of_Character(I).all then - Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) & - " is not the same in the first half of the table"); - end if; - end loop; - - - -- Compare the second half of two tables. - for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop - if TC_Table(I).all /= Table_Of_Character(I).all then - Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) & - " is not the same in the second half of the table"); - end if; - end loop; - - - -- Check the first character. - if Character'Image( Character'First ) /= "NUL" then - Report.Failed("Value of character#" & - Integer'Image(Character'Pos (Character'First)) & - " is not NUL"); - end if; - - - -- Check that the names of the non-graphic characters are usable with - -- Image and Value attributes. - if Character'Value( Character'Image( CVII(153) )) /= - CVII( 153 ) then - Report.Failed ("Value of character#" & - Integer'Image( Character'Pos(CVII(153)) ) & - " is not reserved_153"); - end if; - - - for I in CVII(Lower_Bound) .. CVII(Max_Bound) loop - if Character'Value( - Report.Ident_Str( - Character'Image(CVII(Character'Pos(I))))) - /= CVII( Character'Pos(I)) then - Report.Failed ("Value of character#" & - Integer'Image( Character'Pos(I) ) & - " is not the same as the predefined character type"); - end if; - end loop; - - - -- Check Wide_Character attributes. - for I in Wide_Character'Val(Lower_Bound) .. Wide_Character'Val(Max_Bound) - loop - if Wide_Character'Wide_Value( - Report.Ident_Wide_Str( - Wide_Character'Wide_Image( - Wide_Character'Val(Wide_Character'Pos(I))))) - /= Wide_Character'Val(Wide_Character'Pos(I)) - then - Report.Failed ("Value of the predefined Wide_Character type " & - "is not correct"); - end if; - end loop; - - - if Wide_Character'Value( Wide_Character'Image(Wide_Character'Val(132)) ) - /= Wide_Character'Val( Report.Ident_Int(132) ) then - Report.Failed ("Wide_Character at 132 is not reserved_132"); - end if; - - - if Wide_Character'Image( Wide_Character'First ) /= "NUL" then - Report.Failed ("Wide_Character'First is not NUL"); - end if; - - - if Wide_Character'Image - (Wide_Character'Pred (Wide_Character'Last) ) /= "FFFE" then - Report.Failed ("Wide_Character at 65534 is not FFFE"); - end if; - - - if Wide_Character'Image(Wide_Character'Last) /= "FFFF" then - Report.Failed ("Wide_Character'Last is not FFFF"); - end if; - - Report.Result; - -end C352001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c354002.a b/gcc/testsuite/ada/acats/tests/c3/c354002.a deleted file mode 100644 index 3129182b704..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c354002.a +++ /dev/null @@ -1,335 +0,0 @@ --- --- C354002.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 attributes of modular types yield --- correct values/results. The attributes checked are: --- --- First, Last, Range, Base, Min, Max, Succ, Pred, --- Image, Width, Value, Pos, and Val --- --- TEST DESCRIPTION: --- This test defines several modular types. One type defined at --- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, --- a power of two half that of System.Max_Binary_Modulus, one less --- than that power of two; one more than that power of two, two --- less than a (large) power of two. For each of these types, --- determine the correct operation of the following attributes: --- --- First, Last, Range, Base, Min, Max, Succ, Pred, Image, Width, --- Value, Pos, Val, and Modulus --- --- The attributes Wide_Image and Wide_Value are deferred to C354003. --- --- --- --- CHANGE HISTORY: --- 08 SEP 94 SAIC Initial version --- 17 NOV 94 SAIC Revised version --- 13 DEC 94 SAIC split off Wide_String attributes into C354003 --- 06 JAN 95 SAIC Promoted to next release --- 19 APR 95 SAIC Revised in accord with reviewer comments --- 27 JAN 96 SAIC Eliminated 32/64 bit potential conflict for 2.1 --- ---! - -with Report; -with System; -with TCTouch; -procedure C354002 is - - function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; - function ID(Local_Value: String) return String renames Report.Ident_Str; - - Power_2_Bits : constant := System.Storage_Unit; - Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; - - type Max_Binary is mod System.Max_Binary_Modulus; - type Max_NonBinary is mod System.Max_Nonbinary_Modulus; - type Half_Max_Binary is mod Half_Max_Binary_Value; - - type Medium is mod 2048; - type Medium_Plus is mod 2042; - type Medium_Minus is mod 2111; - - type Small is mod 2; - type Finger is mod 5; - - MBL : constant := Max_NonBinary'Last; - MNBM : constant := Max_NonBinary'Modulus; - - Ones_Complement_Permission : constant Boolean := MBL = MNBM; - - type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); - - subtype Midrange is Medium_Minus range 222 .. 1111; - --- a few numbers for testing purposes - Max_Binary_Mod_Over_3 : constant := Max_Binary'Modulus / 3; - Max_NonBinary_Mod_Over_4 : constant := Max_NonBinary'Modulus / 4; - System_Max_Bin_Mod_Pred : constant := System.Max_Binary_Modulus - 1; - System_Max_NonBin_Mod_Pred : constant := System.Max_Nonbinary_Modulus - 1; - Half_Max_Bin_Value_Pred : constant := Half_Max_Binary_Value - 1; - - AMB, BMB : Max_Binary; - AHMB, BHMB : Half_Max_Binary; - AM, BM : Medium; - AMP, BMP : Medium_Plus; - AMM, BMM : Medium_Minus; - AS, BS : Small; - AF, BF : Finger; - - TC_Pass_Case : Boolean := True; - - procedure Value_Fault( S: String ) is - -- check 'Value for failure modes - begin - -- the evaluation of the 'Value expression should raise C_E - TCTouch.Assert_Not( Midrange'Value(S) = 0, "Value_Fault" ); - if Midrange'Value(S) not in Midrange'Base then - Report.Failed("'Value(" & S & ") raised no exception"); - end if; - exception - when Constraint_Error => null; -- expected case - when others => - Report.Failed("'Value(" & S & ") raised wrong exception"); - end Value_Fault; - -begin -- Main test procedure. - - Report.Test ("C354002", "Check attributes of modular types" ); - --- Base - TCTouch.Assert( Midrange'Base'First = 0, "Midrange'Base'First" ); - TCTouch.Assert( Midrange'Base'Last = Medium_Minus'Last, - "Midrange'Base'Last" ); - --- First - TCTouch.Assert( Max_Binary'First = 0, "Max_Binary'First" ); - TCTouch.Assert( Max_NonBinary'First = 0, "Max_NonBinary'First" ); - TCTouch.Assert( Half_Max_Binary'First = 0, "Half_Max_Binary'First" ); - - TCTouch.Assert( Medium'First = Medium(ID(0)), "Medium'First" ); - TCTouch.Assert( Medium_Plus'First = Medium_Plus(ID(0)), - "Medium_Plus'First" ); - TCTouch.Assert( Medium_Minus'First = Medium_Minus(ID(0)), - "Medium_Minus'First" ); - - TCTouch.Assert( Small'First = Small(ID(0)), "Small'First" ); - TCTouch.Assert( Finger'First = Finger(ID(0)), "Finger'First" ); - TCTouch.Assert( Midrange'First = Midrange(ID(222)), - "Midrange'First" ); - --- Image - TCTouch.Assert( Half_Max_Binary'Image(255) = " 255", - "Half_Max_Binary'Image" ); - TCTouch.Assert( Medium'Image(0) = ID(" 0"), "Medium'Image" ); - TCTouch.Assert( Medium_Plus'Image(Medium_Plus'Last) = " 2041", - "Medium_Plus'Image" ); - TCTouch.Assert( Medium_Minus'Image(Medium_Minus(ID(1024))) = " 1024", - "Medium_Minus'Image" ); - TCTouch.Assert( Small'Image(Small(ID(1))) = " 1", "Small'Image" ); - TCTouch.Assert( Midrange'Image(Midrange(ID(333))) = " 333", - "Midrange'Image" ); - --- Last - TCTouch.Assert( Max_Binary'Last = System_Max_Bin_Mod_Pred, - "Max_Binary'Last"); - if Ones_Complement_Permission then - TCTouch.Assert( Max_NonBinary'Last >= System_Max_NonBin_Mod_Pred, - "Max_NonBinary'Last (ones comp)"); - else - TCTouch.Assert( Max_NonBinary'Last = System_Max_NonBin_Mod_Pred, - "Max_NonBinary'Last"); - end if; - TCTouch.Assert( Half_Max_Binary'Last = Half_Max_Bin_Value_Pred, - "Half_Max_Binary'Last"); - - TCTouch.Assert( Medium'Last = Medium(ID(2047)), "Medium'Last"); - TCTouch.Assert( Medium_Plus'Last = Medium_Plus(ID(2041)), - "Medium_Plus'Last"); - TCTouch.Assert( Medium_Minus'Last = Medium_Minus(ID(2110)), - "Medium_Minus'Last"); - TCTouch.Assert( Small'Last = Small(ID(1)), "Small'Last"); - TCTouch.Assert( Finger'Last = Finger(ID(4)), "Finger'Last"); - TCTouch.Assert( Midrange'Last = Midrange(ID(1111)), "Midrange'Last"); - --- Max - TCTouch.Assert( Max_Binary'Max(Power_2_Bits, Max_Binary'Last) - = Max_Binary'Last, "Max_Binary'Max"); - TCTouch.Assert( Max_NonBinary'Max(100,2000) = 2000, "Max_NonBinary'Max"); - TCTouch.Assert( Half_Max_Binary'Max(123,456) = 456, - "Half_Max_Binary'Max"); - - TCTouch.Assert( Medium'Max(0,2040) = 2040, "Medium'Max"); - TCTouch.Assert( Medium_Plus'Max(0,1) = 1, "Medium_Plus'Max"); - TCTouch.Assert( Medium_Minus'Max(2001,1995) = 2001, "Medium_Minus'Max"); - TCTouch.Assert( Small'Max(1,0) = 1, "Small'Max"); - TCTouch.Assert( Finger'Max(Finger'Last+1,4) = 4, "Finger'Max"); - TCTouch.Assert( Midrange'Max(Midrange'First+1,222) = Midrange'First+1, - "Midrange'Max"); - --- Min - TCTouch.Assert( Max_Binary'Min(Power_2_Bits, Max_Binary'Last) - = Power_2_Bits, "Max_Binary'Min"); - TCTouch.Assert( Max_NonBinary'Min(100,2000) = 100, "Max_NonBinary'Min"); - TCTouch.Assert( Half_Max_Binary'Min(123,456) = 123, - "Half_Max_Binary'Min"); - - TCTouch.Assert( Medium'Min(0,Medium(ID(2040))) = 0, "Medium'Min"); - TCTouch.Assert( Medium_Plus'Min(0,1) = 0, "Medium_Plus'Min"); - TCTouch.Assert( Medium_Minus'Min(2001,1995) = 1995, "Medium_Minus'Min"); - TCTouch.Assert( Small'Min(1,0) = 0, "Small'Min"); - TCTouch.Assert( Finger'Min(Finger'Last+1,4) /= 4, "Finger'Min"); - TCTouch.Assert( Midrange'Min(Midrange'First+1,222) = 222, - "Midrange'Min"); --- Modulus - TCTouch.Assert( Max_Binary'Modulus = System.Max_Binary_Modulus, - "Max_Binary'Modulus"); - TCTouch.Assert( Max_NonBinary'Modulus = System.Max_Nonbinary_Modulus, - "Max_NonBinary'Modulus"); - TCTouch.Assert( Half_Max_Binary'Modulus = Half_Max_Binary_Value, - "Half_Max_Binary'Modulus"); - - TCTouch.Assert( Medium'Modulus = 2048, "Medium'Modulus"); - TCTouch.Assert( Medium_Plus'Modulus = 2042, "Medium_Plus'Modulus"); - TCTouch.Assert( Medium_Minus'Modulus = 2111, "Medium_Minus'Modulus"); - TCTouch.Assert( Small'Modulus = 2, "Small'Modulus"); - TCTouch.Assert( Finger'Modulus = 5, "Finger'Modulus"); - TCTouch.Assert( Midrange'Modulus = ID(2111), "Midrange'Modulus"); - --- Pos - declare - Int : Natural := 222; - begin - for I in Midrange loop - TC_Pass_Case := TC_Pass_Case and Midrange'Pos(I) = Int; - - Int := Int +1; - end loop; - end; - - TCTouch.Assert( TC_Pass_Case, "Midrange'Pos"); - --- Pred - TCTouch.Assert( Max_Binary'Pred(0) = System_Max_Bin_Mod_Pred, - "Max_Binary'Pred(0)"); - if Ones_Complement_Permission then - TCTouch.Assert( Max_NonBinary'Pred(0) >= System_Max_NonBin_Mod_Pred, - "Max_NonBinary'Pred(0) (ones comp)"); - else - TCTouch.Assert( Max_NonBinary'Pred(0) = System_Max_NonBin_Mod_Pred, - "Max_NonBinary'Pred(0)"); - end if; - TCTouch.Assert( Half_Max_Binary'Pred(0) = Half_Max_Bin_Value_Pred, - "Half_Max_Binary'Pred(0)"); - - TCTouch.Assert( Medium'Pred(Medium(ID(0))) = 2047, "Medium'Pred(0)"); - TCTouch.Assert( Medium_Plus'Pred(0) = 2041, "Medium_Plus'Pred(0)"); - TCTouch.Assert( Medium_Minus'Pred(0) = 2110, "Medium_Minus'Pred(0)"); - TCTouch.Assert( Small'Pred(0) = 1, "Small'Pred(0)"); - TCTouch.Assert( Finger'Pred(Finger(ID(0))) = 4, "Finger'Pred(0)"); - TCTouch.Assert( Midrange'Pred(222) = 221, "Midrange'Pred('First)"); - --- Range - for I in Midrange'Range loop - if I not in Midrange then - Report.Failed("Midrange loop test"); - end if; - end loop; - for I in Medium'Range loop - if I not in Medium then - Report.Failed("Medium loop test"); - end if; - end loop; - for I in Medium_Minus'Range loop - if I not in 0..2110 then - Report.Failed("Medium loop test"); - end if; - end loop; - --- Succ - TCTouch.Assert( Max_Binary'Succ(System_Max_Bin_Mod_Pred) = 0, - "Max_Binary'Succ('Last)"); - if Ones_Complement_Permission then - TCTouch.Assert( (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0) - or (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) - = Max_NonBinary'Last), - "Max_NonBinary'Succ('Last) (ones comp)"); - else - TCTouch.Assert( Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0, - "Max_NonBinary'Succ('Last)"); - end if; - TCTouch.Assert( Half_Max_Binary'Succ(Half_Max_Bin_Value_Pred) = 0, - "Half_Max_Binary'Succ('Last)"); - - TCTouch.Assert( Medium'Succ(2047) = 0, "Medium'Succ('Last)"); - TCTouch.Assert( Medium_Plus'Succ(2041) = 0, "Medium_Plus'Succ('Last)"); - TCTouch.Assert( Medium_Minus'Succ(2110) = 0, "Medium_Minus'Succ('Last)"); - TCTouch.Assert( Small'Succ(1) = 0, "Small'Succ('Last)"); - TCTouch.Assert( Finger'Succ(4) = 0, "Finger'Succ('Last)"); - TCTouch.Assert( Midrange'Succ(Midrange(ID(1111))) = 1112, - "Midrange'Succ('Last)"); - --- Val - for I in Natural range ID(222)..ID(1111) loop - TCTouch.Assert( Midrange'Val(I) = Medium_Minus(I), "Midrange'Val"); - end loop; - --- Value - - TCTouch.Assert( Half_Max_Binary'Value("255") = 255, - "Half_Max_Binary'Value" ); - - TCTouch.Assert( Medium'Value(" 1e2") = 100, "Medium'Value(""1e2"")" ); - TCTouch.Assert( Medium'Value(" 0 ") = 0, "Medium'Value" ); - TCTouch.Assert( Medium_Plus'Value(ID("2041")) = 2041, - "Medium_Plus'Value" ); - TCTouch.Assert( Medium_Minus'Value(ID("+10_24")) = 1024, - "Medium_Minus'Value" ); - - TCTouch.Assert( Small'Value("+1") = 1, "Small'Value" ); - TCTouch.Assert( Midrange'Value(ID("333")) = 333, "Midrange'Value" ); - TCTouch.Assert( Midrange'Value("1E3") = 1000, - "Midrange'Value(""1E3"")" ); - - Value_Fault( "bad input" ); - Value_Fault( "-333" ); - Value_Fault( "9999" ); - Value_Fault( ".1" ); - Value_Fault( "1e-1" ); - --- Width - TCTouch.Assert( Medium'Width = 5, "Medium'Width"); - TCTouch.Assert( Medium_Plus'Width = 5, "Medium_Plus'Width"); - TCTouch.Assert( Medium_Minus'Width = 5, "Medium_Minus'Width"); - TCTouch.Assert( Small'Width = 2, "Small'Width"); - TCTouch.Assert( Finger'Width = 2, "Finger'Width"); - TCTouch.Assert( Midrange'Width = 5, "Midrange'Width"); - - Report.Result; - -end C354002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c354003.a b/gcc/testsuite/ada/acats/tests/c3/c354003.a deleted file mode 100644 index 1f607a7e691..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c354003.a +++ /dev/null @@ -1,211 +0,0 @@ --- C354003.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 Wide_String attributes of modular types yield --- correct values/results. The attributes checked are: --- --- Wide_Image --- Wide_Value --- --- TEST DESCRIPTION: --- This test is split from C354002. It tests only the attributes: --- --- Wide_Image, Wide_Value --- --- This test defines several modular types. One type defined at --- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, --- a power of two half that of System.Max_Binary_Modulus, one less --- than that power of two; one more than that power of two, two --- less than a (large) power of two. For each of these types, --- determine the correct operation of the Wide_String attributes. --- --- --- CHANGE HISTORY: --- 13 DEC 94 SAIC Initial version --- 06 JAN 94 SAIC Promoted to future release --- 19 APR 95 SAIC Revised in accord with reviewer comments --- 01 DEC 95 SAIC Corrected for 2.0.1 --- 27 JAN 96 SAIC Eliminated potential 32/64 bit conflict for 2.1 --- 24 FEB 97 PWB.CTA Corrected out-of-range value ---! - -with Report; -with System; -with TCTouch; -with Ada.Characters.Handling; -procedure C354003 is - - function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; - function ID(Local_Value: String) return String renames Report.Ident_Str; - - function ID(Local_Value: String) return Wide_String is - begin - return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) ); - end ID; - - Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; - - type Max_Binary is mod System.Max_Binary_Modulus; - type Max_NonBinary is mod System.Max_Nonbinary_Modulus; - type Half_Max_Binary is mod Half_Max_Binary_Value; - - type Medium is mod 2048; - type Medium_Plus is mod 2042; - type Medium_Minus is mod 2111; - - type Small is mod 2; - type Finger is mod 5; - - type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); - - subtype Midrange is Medium_Minus range 222 .. 1111; - - AMB, BMB : Max_Binary; - AHMB, BHMB : Half_Max_Binary; - AM, BM : Medium; - AMP, BMP : Medium_Plus; - AMM, BMM : Medium_Minus; - AS, BS : Small; - AF, BF : Finger; - - procedure Wide_Value_Fault( S: Wide_String ) is - -- check 'Wide_Value for failure modes - begin - -- the evaluation of the 'Wide_Value expression should raise C_E - TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" ); - if Midrange'Wide_Value(S) not in Midrange'Base then - Report.Failed("'Wide_Value raised no exception"); - end if; - exception - when Constraint_Error => null; -- expected case - when others => - Report.Failed("'Wide_Value raised wrong exception"); - end Wide_Value_Fault; - - - The_Cap, The_Toe : Natural; - - procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is - subtype Non_Static is Medium range Lower_Bound..Upper_Bound; - begin - -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val - - TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" ); - TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap), - "Non_Static'Last" ); - TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range, - "Non_Static'Range" ); - TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)), - Medium(Report.Ident_Int(200))) = 100, - "Non_Static'Min" ); - TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)), - Medium(Report.Ident_Int(200))) = 200, - "Non_Static'Max" ); - TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap)) - = Medium'Succ(Upper_Bound), - "Non_Static'Succ" ); - TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap))) - = Non_Static(Report.Ident_Int(The_Cap-1)), - "Non_Static'Pred" ); - TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap), - "Non_Static'Pos" ); - TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound, - "Non_Static'Val" ); - - end Check_Non_Static_Cases; - - -begin -- Main test procedure. - - Report.Test ("C354003", "Check Wide_String attributes of modular types" ); - - Wide_Strings_Needed: declare - - Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3; - Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4; - - begin - --- Wide_Image - - TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255", - "Half_Max_Binary'Wide_Image" ); - - TCTouch.Assert( Medium'Wide_Image(0) = " 0", "Medium'Wide_Image" ); - - TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041", - "Medium_Plus'Wide_Image" ); - - TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024", - "Medium_Minus'Wide_Image" ); - - TCTouch.Assert( Small'Wide_Image(1) = " 1", "Small'Wide_Image" ); - - TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333", - "Midrange'Wide_Image" ); - --- Wide_Value - - TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255, - "Half_Max_Binary'Wide_Value" ); - - TCTouch.Assert( Medium'Wide_Value(" 0 ") = 0, "Medium'Wide_Value" ); - - TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last, - "Medium_Plus'Wide_Value" ); - - TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14, - "Medium_Minus'Wide_Value" ); - - TCTouch.Assert( Small'Wide_Value("+1") = 1, "Small'Wide_Value" ); - - TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333, - "Midrange'Wide_Value" ); - - TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000, - "Midrange'Wide_Value(""1E3"")" ); - - Wide_Value_Fault( "bad input" ); - Wide_Value_Fault( "-333" ); - Wide_Value_Fault( "9999" ); - Wide_Value_Fault( ".1" ); - Wide_Value_Fault( "1e-1" ); - - end Wide_Strings_Needed; - - The_Toe := Report.Ident_Int(25); - The_Cap := Report.Ident_Int(256); - Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), - Medium(Report.Ident_Int(The_Cap)) ); - - The_Toe := Report.Ident_Int(40); - The_Cap := Report.Ident_Int(2047); - Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), - Medium(Report.Ident_Int(The_Cap)) ); - - Report.Result; - -end C354003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c360002.a b/gcc/testsuite/ada/acats/tests/c3/c360002.a deleted file mode 100644 index 95cb3ef07d7..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c360002.a +++ /dev/null @@ -1,268 +0,0 @@ --- C360002.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 modular types may be used as array indices. --- --- Check that if aliased appears in the component_definition of an --- array_type that each component of the array is aliased. --- --- Check that references to aliased array objects produce correct --- results, and that out-of-bounds indexing correctly produces --- Constraint_Error. --- --- TEST DESCRIPTION: --- This test defines several array types and subtypes indexed by modular --- types; some aliased some not, some with aliased components, some not. --- --- It then checks that assignments move the correct data. --- --- --- CHANGE HISTORY: --- 28 SEP 95 SAIC Initial version --- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict --- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code ---! - -------------------------------------------------------------------- C360002 - -with Report; - -procedure C360002 is - - Verbose : Boolean := Report.Ident_Bool( False ); - - type Mod_128 is mod 128; - - function Ident_128( I: Integer ) return Mod_128 is - begin - return Mod_128( Report.Ident_Int( I ) ); - end Ident_128; - - type Unconstrained_Array - is array( Mod_128 range <> ) of Integer; - - type Unconstrained_Array_Aliased - is array( Mod_128 range <> ) of aliased Integer; - - type Access_All_Unconstrained_Array - is access all Unconstrained_Array; - - type Access_All_Unconstrained_Array_Aliased - is access all Unconstrained_Array_Aliased; - - subtype Array_01_10 - is Unconstrained_Array(01..10); - - subtype Array_11_20 - is Unconstrained_Array(11..20); - - subtype Array_Aliased_01_10 - is Unconstrained_Array_Aliased(01..10); - - subtype Array_Aliased_11_20 - is Unconstrained_Array_Aliased(11..20); - - subtype Access_All_01_10_Array - is Access_All_Unconstrained_Array(01..10); - - subtype Access_All_01_10_Array_Aliased - is Access_All_Unconstrained_Array_Aliased(01..10); - - subtype Access_All_11_20_Array - is Access_All_Unconstrained_Array(11..20); - - subtype Access_All_11_20_Array_Aliased - is Access_All_Unconstrained_Array_Aliased(11..20); - - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - -- these 'filler' functions create unique values for every element that - -- is used and/or tested in this test. - - Well_Bottom : Integer := 0; - - function Filler( Size : Mod_128 ) return Unconstrained_Array is - It : Unconstrained_Array( 0..Size-1 ); - begin - for Eyes in It'Range loop - It(Eyes) := Integer( Eyes ) + Well_Bottom; - end loop; - Well_Bottom := Well_Bottom + It'Length; - return It; - end Filler; - - function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is - It : Unconstrained_Array_Aliased( 0..Size-1 ); - begin - for Ayes in It'Range loop - It(Ayes) := Integer( Ayes ) + Well_Bottom; - end loop; - Well_Bottom := Well_Bottom + It'Length; - return It; - end Filler; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - An_Integer : Integer; - - type AAI is access all Integer; - - An_Integer_Access : AAI; - - Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9 - - Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding) - - Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29 - - Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39 - - Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49 - - Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59 - - Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10 - := Filler(10); -- 60..69 - - Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20 - := Filler(10); -- 70..79 - - Check_Item : Access_All_Unconstrained_Array; - - Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - procedure Fail( Message : String; CI, SB : Integer ) is - begin - Report.Failed("Wrong value passed " & Message); - if Verbose then - Report.Comment("got" & Integer'Image(CI) & - " should be" & Integer'Image(SB) ); - end if; - end Fail; - - procedure Check_Array_01_10( Checked_Item : Array_01_10; - Low_SB : Integer ) is - begin - for Index in Checked_Item'Range loop - if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then - Fail("unaliased 1..10", Checked_Item(Index), - (Low_SB +Integer(Index)-1)); - end if; - end loop; - end Check_Array_01_10; - - procedure Check_Array_11_20( Checked_Item : Array_11_20; - Low_SB : Integer ) is - begin - for Index in Checked_Item'Range loop - if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then - Fail("unaliased 11..20", Checked_Item(Index), - (Low_SB +Integer(Index)-11)); - end if; - end loop; - end Check_Array_11_20; - - procedure Check_Single_Integer( The_Integer, SB : Integer; - Message : String ) is - begin - if The_Integer /= SB then - Report.Failed("Wrong integer value for " & Message ); - end if; - end Check_Single_Integer; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("C360002", "Check that modular types may be used as array " & - "indices. Check that if aliased appears in " & - "the component_definition of an array_type that " & - "each component of the array is aliased. Check " & - "that references to aliased array objects " & - "produce correct results, and that out of bound " & - "references to aliased objects correctly " & - "produce Constraint_Error" ); - -- start with checks that the Filler assignments produced the expected - -- result. This is a "case 0" test to check that nothing REALLY surprising - -- is happening - - Check_Array_01_10( Array_Item_01_10, 0 ); - Check_Array_11_20( Array_Item_11_20, 10 ); - - -- check that having the variable aliased makes no difference - Check_Array_01_10( Aliased_Array_Item_01_10, 40 ); - Check_Array_11_20( Aliased_Array_Item_11_20, 50 ); - - -- now check that conversion between array types where the only - -- difference in the definitions is that the components are aliased works - - Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 ); - Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 ); - - -- check that conversion of an aliased object with aliased components - -- also works - - Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ), - 60 ); - Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), - 70 ); - - -- check that the bounds will slide - - Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 ); - Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 ); - - -- point at some of the components and check them - - An_Integer_Access := Array_Aliased_Item_01_10(5)'Access; - - Check_Single_Integer( An_Integer_Access.all, 24, - "Aliased component 'Access"); - - An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access; - - Check_Single_Integer( An_Integer_Access.all, 66, - "Aliased Aliased component 'Access"); - - -- check some assignments - - Array_Item_01_10 := Aliased_Array_Item_01_10; - Check_Array_01_10( Array_Item_01_10, 40 ); - - Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20); - Check_Array_01_10( Aliased_Array_Item_01_10, 50 ); - - Aliased_Array_Aliased_Item_11_20(11..20) - := Aliased_Array_Aliased_Item_01_10; - Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), - 60 ); - - Report.Result; - -end C360002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c371001.a b/gcc/testsuite/ada/acats/tests/c3/c371001.a deleted file mode 100644 index f6823570b06..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c371001.a +++ /dev/null @@ -1,388 +0,0 @@ --- C371001.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 if a discriminant constraint depends on a discriminant, --- the evaluation of the expressions in the constraint is deferred --- until an object of the subtype is created. Check for cases of --- records with private type component. --- --- TEST DESCRIPTION: --- This transition test defines record type and incomplete types with --- discriminant components which depend on the discriminants. The --- discriminants are calculated by function calls. The test verifies --- that Constraint_Error is raised during the object creations when --- values of discriminants are incompatible with the subtypes. --- --- Inspired by C37214A.ADA and C37216A.ADA. --- --- --- CHANGE HISTORY: --- 11 Apr 96 SAIC Initial version for ACVC 2.1. --- 06 Oct 96 SAIC Added LM references. Replaced "others exception" --- with "unexpected exception" --- ---! - -with Report; - -procedure C371001 is - - subtype Small_Int is Integer range 1..10; - - Func1_Cons : Integer := 0; - - --------------------------------------------------------- - function Func1 return Integer is - begin - Func1_Cons := Func1_Cons + Report.Ident_Int(1); - return Func1_Cons; - end Func1; - - -begin - Report.Test ("C371001", "Check that if a discriminant constraint " & - "depends on a discriminant, the evaluation of the " & - "expressions in the constraint is deferred until " & - "object declarations"); - - --------------------------------------------------------- - -- Constraint checks on an object declaration of a record. - - begin - - declare - - package C371001_0 is - - type PT_W_Disc (D : Small_Int) is private; - type Rec_W_Private (D1 : Integer) is - record - C : PT_W_Disc (D1); - end record; - - type Rec (D3 : Integer) is - record - C1 : Rec_W_Private (D3); - end record; - - private - type PT_W_Disc (D : Small_Int) is - record - Str : String (1 .. D) := (others => '*'); - end record; - - end C371001_0; - - --=====================================================-- - - Obj : C371001_0.Rec(Report.Ident_Int(0)); -- Constraint_Error raised. - - begin - Report.Failed ("Obj - Constraint_Error should be raised"); - if Obj.C1.D1 /= 0 then - Report.Failed ("Obj - Shouldn't get here"); - end if; - - exception - when others => - Report.Failed ("Obj - exception raised too late"); - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj - unexpected exception raised"); - end; - - ------------------------------------------------------------------- - -- Constraint checks on an object declaration of an array. - - begin - declare - - package C371001_1 is - - type PT_W_Disc (D : Small_Int) is private; - type Rec_W_Private (D1 : Integer) is - record - C : PT_W_Disc (D1); - end record; - - type Rec_01 (D3 : Integer) is - record - C1 : Rec_W_Private (D3); - end record; - - type Arr is array (1 .. 5) of - Rec_01(Report.Ident_Int(0)); -- No Constraint_Error - -- raised. - private - type PT_W_Disc (D : Small_Int) is - record - Str : String (1 .. D) := (others => '*'); - end record; - - end C371001_1; - - --=====================================================-- - - begin - declare - Obj1 : C371001_1.Arr; -- Constraint_Error raised. - begin - Report.Failed ("Obj1 - Constraint_Error should be raised"); - if Obj1(1).D3 /= 0 then - Report.Failed ("Obj1 - Shouldn't get here"); - end if; - - exception - when others => - Report.Failed ("Obj1 - exception raised too late"); - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj1 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Arr - Constraint_Error raised"); - when others => - Report.Failed ("Arr - unexpected exception raised"); - end; - - - ------------------------------------------------------------------- - -- Constraint checks on an object declaration of an access type. - - begin - declare - - package C371001_2 is - - type PT_W_Disc (D : Small_Int) is private; - type Rec_W_Private (D1 : Integer) is - record - C : PT_W_Disc (D1); - end record; - - type Rec_02 (D3 : Integer) is - record - C1 : Rec_W_Private (D3); - end record; - - type Acc_Rec2 is access Rec_02 -- No Constraint_Error - (Report.Ident_Int(11)); -- raised. - - private - type PT_W_Disc (D : Small_Int) is - record - Str : String (1 .. D) := (others => '*'); - end record; - - end C371001_2; - - --=====================================================-- - - begin - declare - Obj2 : C371001_2.Acc_Rec2; -- No Constraint_Error - -- raised. - begin - Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11)); - -- Constraint_Error raised. - - Report.Failed ("Obj2 - Constraint_Error should be raised"); - if Obj2.D3 /= 1 then - Report.Failed ("Obj2 - Shouldn't get here"); - end if; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj2 - unexpected exception raised in " & - "assignment"); - end; - - exception - when Constraint_Error => - Report.Failed ("Obj2 - Constraint_Error raised in declaration"); - when others => - Report.Failed ("Obj2 - unexpected exception raised in " & - "declaration"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_Rec2 - Constraint_Error raised"); - when others => - Report.Failed ("Acc_Rec2 - unexpected exception raised"); - end; - - ------------------------------------------------------------------- - -- Constraint checks on an object declaration of a subtype. - - Func1_Cons := -1; - - begin - declare - - package C371001_3 is - - type PT_W_Disc (D1, D2 : Small_Int) is private; - type Rec_W_Private (D3, D4 : Integer) is - record - C : PT_W_Disc (D3, D4); - end record; - - type Rec_03 (D5 : Integer) is - record - C1 : Rec_W_Private (D5, Func1); -- Func1 evaluated, - end record; -- value 0. - - subtype Subtype_Rec is Rec_03(1); -- No Constraint_Error - -- raised. - private - type PT_W_Disc (D1, D2 : Small_Int) is - record - Str1 : String (1 .. D1) := (others => '*'); - Str2 : String (1 .. D2) := (others => '*'); - end record; - - end C371001_3; - - --=====================================================-- - - begin - declare - Obj3 : C371001_3.Subtype_Rec; -- Constraint_Error raised. - begin - Report.Failed ("Obj3 - Constraint_Error should be raised"); - if Obj3.D5 /= 1 then - Report.Failed ("Obj3 - Shouldn't get here"); - end if; - - exception - when others => - Report.Failed ("Obj3 - exception raised too late"); - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj3 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Subtype_Rec - Constraint_Error raised"); - when others => - Report.Failed ("Subtype_Rec - unexpected exception raised"); - end; - - ------------------------------------------------------------------- - -- Constraint checks on an object declaration of an incomplete type. - - Func1_Cons := 10; - - begin - declare - - package C371001_4 is - - type Rec_04 (D3 : Integer); - type PT_W_Disc (D : Small_Int) is private; - type Rec_W_Private (D1, D2 : Small_Int) is - record - C : PT_W_Disc (D2); - end record; - - type Rec_04 (D3 : Integer) is - record - C1 : Rec_W_Private (D3, Func1); -- Func1 evaluated - end record; -- value 11. - - type Acc_Rec4 is access Rec_04 (1); -- No Constraint_Error - -- raised. - private - type PT_W_Disc (D : Small_Int) is - record - Str : String (1 .. D) := (others => '*'); - end record; - - end C371001_4; - - --=====================================================-- - - begin - declare - Obj4 : C371001_4.Acc_Rec4; -- No Constraint_Error - -- raised. - begin - Obj4 := new C371001_4.Rec_04 (1); -- Constraint_Error raised. - - Report.Failed ("Obj4 - Constraint_Error should be raised"); - if Obj4.D3 /= 1 then - Report.Failed ("Obj4 - Shouldn't get here"); - end if; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj4 - unexpected exception raised in " & - "assignment"); - end; - - exception - when Constraint_Error => - Report.Failed ("Obj4 - Constraint_Error raised in declaration"); - when others => - Report.Failed ("Obj4 - unexpected exception raised in " & - "declaration"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_Rec4 - Constraint_Error raised"); - when others => - Report.Failed ("Acc_Rec4 - unexpected exception raised"); - end; - - Report.Result; - -exception - when others => - Report.Failed ("Discriminant value checked too soon"); - Report.Result; - -end C371001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c371002.a b/gcc/testsuite/ada/acats/tests/c3/c371002.a deleted file mode 100644 index ea532550cd8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c371002.a +++ /dev/null @@ -1,364 +0,0 @@ --- C371002.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 if a discriminant constraint depends on a discriminant, --- the evaluation of the expressions in the constraint is deferred until --- an object of the subtype is created. Check for cases of records. --- --- TEST DESCRIPTION: --- This transition test defines record types with discriminant components --- which depend on the discriminants. The discriminants are calculated --- by function calls. The test verifies that Constraint_Error is raised --- during the object creations when values of discriminants are --- incompatible with the subtypes. --- --- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA. --- --- --- CHANGE HISTORY: --- 05 Apr 96 SAIC Initial version for ACVC 2.1. --- ---! - -with Report; - -procedure C371002 is - - subtype Small_Int is Integer range 1..10; - - type Rec_W_Disc (Disc1, Disc2 : Small_Int) is - record - Str1 : String (1 .. Disc1) := (others => '*'); - Str2 : String (1 .. Disc2) := (others => '*'); - end record; - - type My_Array is array (Small_Int range <>) of Integer; - - Func1_Cons : Integer := 0; - - --------------------------------------------------------- - function Chk (Cons : Integer; - Value : Integer; - Message : String) return Boolean is - begin - if Cons /= Value then - Report.Failed (Message & ": Func1_Cons is " & - Integer'Image(Func1_Cons)); - end if; - return True; - end Chk; - - --------------------------------------------------------- - function Func1 return Integer is - begin - Func1_Cons := Func1_Cons + Report.Ident_Int(1); - return Func1_Cons; - end Func1; - -begin - Report.Test ("C371002", "Check that if a discriminant constraint " & - "depends on a discriminant, the evaluation of the " & - "expressions in the constraint is deferred until " & - "object declarations"); - - --------------------------------------------------------- - declare - type Rec1 (D3 : Integer) is - record - C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. - end record; - - Chk1 : Boolean := Chk (Func1_Cons, 1, - "Func1 not evaluated for Rec1"); - - Obj1 : Rec1 (1); -- Func1 not evaluated again. - Obj2 : Rec1 (2); -- Func1 not evaluated again. - - Chk2 : Boolean := Chk (Func1_Cons, 1, - "Func1 evaluated too many times"); - begin - if Obj1 /= (D3 => 1, - C1 => (Disc1 => 1, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) or - Obj2 /= (D3 => 2, - C1 => (Disc1 => 2, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) then - Report.Failed ("Obj1 & Obj2 - Discriminant values not correct"); - end if; - end; - - --------------------------------------------------------- - Func1_Cons := -11; - - declare - type Rec_Of_Rec_01 (D3 : Integer) is - record - C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10. - end record; -- Constraint_Error not raised. - - type Rec_Of_MyArr_01 (D3 : Integer) is - record - C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9. - end record; -- Constraint_Error not raised. - - type Rec_Of_Rec_02 (D3 : Integer) is - record - C1 : Rec_W_Disc (D3, 1); - end record; - - type Rec_Of_MyArr_02 (D3 : Integer) is - record - C1 : My_Array (D3 .. 1); - end record; - - begin - - --------------------------------------------------------- - begin - declare - Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised. - begin - Report.Failed ("Obj3 - Constraint_Error should be raised"); - if Obj3 /= (1, (1, 1, others => (others => '*'))) then - Report.Comment ("Obj3 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj3 - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - subtype Subtype_Rec is Rec_Of_Rec_01(1); - -- No Constraint_Error raised. - begin - declare - Obj4 : Subtype_Rec; -- Constraint_Error raised. - begin - Report.Failed ("Obj4 - Constraint_Error should be raised"); - if Obj4 /= (D3 => 1, - C1 => (Disc1 => 1, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) then - Report.Comment ("Obj4 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj4 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Subtype_Rec - Constraint_Error raised"); - when others => - Report.Failed ("Subtype_Rec - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - type Arr is array (1..5) -- No Constraint_Error raised. - of Rec_Of_Rec_01(1); - - begin - declare - Obj5 : Arr; -- Constraint_Error raised. - begin - Report.Failed ("Obj5 - Constraint_Error should be raised"); - if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then - Report.Comment ("Obj5 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj5 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Arr - Constraint_Error raised"); - when others => - Report.Failed ("Arr - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - type Rec_Of_Rec_Of_MyArr is - record - C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised. - end record; - begin - declare - Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. - begin - Report.Failed ("Obj6 - Constraint_Error should be raised"); - if Obj6 /= (C1 => (1, (1, 1))) then - Report.Comment ("Obj6 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj6 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); - when others => - Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - type New_Rec is - new Rec_Of_MyArr_01(1); -- No Constraint_Error raised. - - begin - declare - Obj7 : New_Rec; -- Constraint_Error raised. - begin - Report.Failed ("Obj7 - Constraint_Error should be raised"); - if Obj7 /= (1, (1, 1)) then - Report.Comment ("Obj7 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj7 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("New_Rec - Constraint_Error raised"); - when others => - Report.Failed ("New_Rec - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - type Acc_Rec is - access Rec_Of_Rec_02 (Report.Ident_Int(0)); - -- No Constraint_Error raised. - begin - declare - Obj8 : Acc_Rec; -- No Constraint_Error raised. - - begin - Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0)); - -- Constraint_Error raised. - - Report.Failed ("Obj8 - Constraint_Error should be raised"); - if Obj8.all /= (D3 => 1, - C1 => (Disc1 => 1, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) then - Report.Comment ("Obj8 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj8 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_Rec - Constraint_Error raised"); - when others => - Report.Failed ("Acc_Rec - others exception raised"); - end; - - --------------------------------------------------------- - begin - declare - type Acc_Rec_MyArr is access - Rec_Of_MyArr_02; -- No Constraint_Error - -- raised for either - Obj9 : Acc_Rec_MyArr; -- declaration. - - begin - Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0)); - -- Constraint_Error raised. - - Report.Failed ("Obj9 - Constraint_Error should be raised"); - - if Obj9.all /= (1, (1, 1)) then - Report.Comment ("Obj9 - Shouldn't get here"); - end if; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj9 - others exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised"); - when others => - Report.Failed ("Acc_Rec_MyArr - others exception raised"); - end; - - end; - - Report.Result; - -exception - when others => - Report.Failed ("Discriminant value checked too soon"); - Report.Result; - -end C371002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c371003.a b/gcc/testsuite/ada/acats/tests/c3/c371003.a deleted file mode 100644 index c4a8345f610..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c371003.a +++ /dev/null @@ -1,474 +0,0 @@ --- C371003.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 if a discriminant constraint depends on a discriminant, --- the evaluation of the expressions in the constraint is deferred --- until an object of the subtype is created. Check for cases of --- records where the component containing the constraint is present --- in the subtype. --- --- TEST DESCRIPTION: --- This transition test defines record types with discriminant components --- which depend on the discriminants. The discriminants are calculated --- by function calls. The test verifies that Constraint_Error is raised --- during the object creations when values of discriminants are --- incompatible with the subtypes. Also check for cases, where the --- component is absent. --- --- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA. --- --- --- CHANGE HISTORY: --- 10 Apr 96 SAIC Initial version for ACVC 2.1. --- 14 Jul 96 SAIC Modified test description. Added exception handler --- for VObj_10 assignment. --- 26 Oct 96 SAIC Added LM references. --- ---! - -with Report; - -procedure C371003 is - - subtype Small_Int is Integer range 1..10; - - type Rec_W_Disc (Disc1, Disc2 : Small_Int) is - record - Str1 : String (1 .. Disc1) := (others => '*'); - Str2 : String (1 .. Disc2) := (others => '*'); - end record; - - type My_Array is array (Small_Int range <>) of Integer; - - Func1_Cons : Integer := 0; - - --------------------------------------------------------- - function Chk (Cons : Integer; - Value : Integer; - Message : String) return Boolean is - begin - if Cons /= Value then - Report.Failed (Message & ": Func1_Cons is " & - Integer'Image(Func1_Cons)); - end if; - return True; - end Chk; - - --------------------------------------------------------- - function Func1 return Integer is - begin - Func1_Cons := Func1_Cons + Report.Ident_Int(1); - return Func1_Cons; - end Func1; - - -begin - Report.Test ("C371003", "Check that if a discriminant constraint " & - "depends on a discriminant, the evaluation of the " & - "expressions in the constraint is deferred until " & - "object declarations"); - - --------------------------------------------------------- - declare - type VRec_01 (D3 : Integer) is - record - case D3 is - when -5..10 => - C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. - when others => - C2 : Integer := Report.Ident_Int(0); - end case; - end record; - - Chk1 : Boolean := Chk (Func1_Cons, 1, - "Func1 not evaluated for VRec_01"); - - VObj_1 : VRec_01(1); -- Func1 not evaluated again - VObj_2 : VRec_01(2); -- Func1 not evaluated again - - Chk2 : Boolean := Chk (Func1_Cons, 1, - "Func1 evaluated too many times"); - - begin - if VObj_1 /= (D3 => 1, - C1 => (Disc1 => 1, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) or - VObj_2 /= (D3 => 2, - C1 => (Disc1 => 2, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) then - Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct"); - end if; - end; - - --------------------------------------------------------- - Func1_Cons := -11; - - declare - type VRec_Of_VRec_01 (D3 : Integer) is - record - case D3 is - when -5..10 => - C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10. - when others => -- Constraint_Error not raised. - C2 : Integer := Report.Ident_Int(0); - end case; - end record; - - type VRec_Of_VRec_02 (D3 : Integer) is - record - case D3 is - when -5..10 => - C1 : Rec_W_Disc (1, D3); - when others => - C2 : Integer := Report.Ident_Int(0); - end case; - end record; - - type VRec_Of_MyArr_01 (D3 : Integer) is - record - case D3 is - when -5..10 => - C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9. - when others => -- Constraint_Error not raised. - C2 : Integer := Report.Ident_Int(0); - end case; - end record; - - type VRec_Of_MyArr_02 (D3 : Integer) is - record - case D3 is - when -5..10 => - C1 : My_Array (D3..1); - when others => - C2 : Integer := Report.Ident_Int(0); - end case; - end record; - - begin - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised. - begin - Report.Failed ("VObj_3 - Constraint_Error should be raised"); - if VObj_3 /= (1, (1, 1, others => (others => '*'))) then - Report.Comment ("VObj_3 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("VObj_3 - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - subtype Subtype_VRec is -- No Constraint_Error raised. - VRec_Of_VRec_01(Report.Ident_Int(1)); - begin - declare - VObj_4 : Subtype_VRec; -- Constraint_Error raised. - begin - Report.Failed ("VObj_4 - Constraint_Error should be raised"); - if VObj_4 /= (D3 => 1, - C1 => (Disc1 => 1, - Disc2 => 1, - Str1 => (others => '*'), - Str2 => (others => '*'))) then - Report.Comment ("VObj_4 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("VObj_4 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Subtype_VRec - Constraint_Error raised"); - when others => - Report.Failed ("Subtype_VRec - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is absent. - begin - declare - type Arr is array (1..5) of - VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error - VObj_5 : Arr; -- for either declaration. - - begin - if VObj_5 /= (1 .. 5 => (-6, 0)) then - Report.Comment ("VObj_5 - wrong values"); - end if; - end; - - exception - when others => - Report.Failed ("Arr - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - type Rec_Of_Rec_Of_MyArr is - record - C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised. - end record; - begin - declare - Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. - begin - Report.Failed ("Obj_6 - Constraint_Error should be raised"); - if Obj_6 /= (C1 => (1, (1, 1))) then - Report.Comment ("Obj_6 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("Obj_6 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); - when others => - Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " & - "raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is absent. - begin - declare - type New_VRec_Arr is - new VRec_Of_MyArr_01(11); -- No Constraint_Error raised - Obj_7 : New_VRec_Arr; -- for either declaration. - - begin - if Obj_7 /= (11, 0) then - Report.Failed ("Obj_7 - value incorrect"); - end if; - end; - - exception - when others => - Report.Failed ("New_VRec_Arr - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - type New_VRec is new - VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error - -- raised. - begin - declare - VObj_8 : New_VRec; -- Constraint_Error raised. - begin - Report.Failed ("VObj_8 - Constraint_Error should be raised"); - if VObj_8 /= (1, (1, 1, others => (others => '*'))) then - Report.Comment ("VObj_8 - Shouldn't get here"); - end if; - end; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("VObj_8 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("New_VRec - Constraint_Error raised"); - when others => - Report.Failed ("New_VRec - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is absent. - begin - declare - subtype Sub_VRec is - VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error - VObj_9 : Sub_VRec; -- raised for either - -- declaration. - begin - if VObj_9 /= (11, 0) then - Report.Comment ("VObj_9 - wrong values"); - end if; - end; - - exception - when others => - Report.Failed ("Sub_VRec - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - type Acc_VRec_01 is access - VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error - -- raised. - begin - declare - VObj_10 : Acc_VRec_01; -- No Constraint_Error - -- raised. - begin - VObj_10 := new VRec_Of_VRec_02 - (Report.Ident_Int(0)); -- Constraint_Error - -- raised. - Report.Failed ("VObj_10 - Constraint_Error should be raised"); - if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then - Report.Comment ("VObj_10 - Shouldn't get here"); - end if; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("VObj_10 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("VObj_10 - Constraint_Error exception raised"); - when others => - Report.Failed ("VObj_10 - unexpected exception raised at " & - "declaration"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_VRec_01 - Constraint_Error raised"); - when others => - Report.Failed ("Acc_VRec_01 - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is absent. - begin - declare - type Acc_VRec_02 is access - VRec_Of_VRec_02(11); -- No Constraint_Error - -- raised for either - VObj_11 : Acc_VRec_02; -- declaration. - - begin - VObj_11 := new VRec_Of_VRec_02(11); - if VObj_11.all /= (11, 0) then - Report.Comment ("VObj_11 - wrong values"); - end if; - end; - - exception - when others => - Report.Failed ("Acc_VRec_02 - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is present. - begin - declare - type Acc_VRec_03 is access - VRec_Of_MyArr_02; -- No Constraint_Error - -- raised for either - VObj_12 : Acc_VRec_03; -- declaration. - begin - VObj_12 := new VRec_Of_MyArr_02 - (Report.Ident_Int(0)); -- Constraint_Error raised. - - Report.Failed ("VObj_12 - Constraint_Error should be raised"); - if VObj_12.all /= (1, (1, 1)) then - Report.Comment ("VObj_12 - Shouldn't get here"); - end if; - - exception - when Constraint_Error => -- Exception expected. - null; - when others => - Report.Failed ("VObj_12 - unexpected exception raised"); - end; - - exception - when Constraint_Error => - Report.Failed ("Acc_VRec_03 - Constraint_Error raised"); - when others => - Report.Failed ("Acc_VRec_03 - unexpected exception raised"); - end; - - --------------------------------------------------------- - -- Component containing the constraint is absent. - begin - declare - type Acc_VRec_04 is access - VRec_Of_MyArr_02(11); -- No Constraint_Error - -- raised for either - VObj_13 : Acc_VRec_04; -- declaration. - - begin - VObj_13 := new VRec_Of_MyArr_02(11); - if VObj_13.all /= (11, 0) then - Report.Comment ("VObj_13 - wrong values"); - end if; - end; - - exception - when others => - Report.Failed ("Acc_VRec_04 - unexpected exception raised"); - end; - - end; - - Report.Result; - -exception - when others => - Report.Failed ("Discriminant value checked too soon"); - Report.Result; - -end C371003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c380001.a b/gcc/testsuite/ada/acats/tests/c3/c380001.a deleted file mode 100644 index 0ebe4d31cfb..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c380001.a +++ /dev/null @@ -1,128 +0,0 @@ --- C380001.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 ACAA 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 checks are made properly when a per-object expression contains --- an attribute whose prefix denotes the current instance of the type. --- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, --- RM95 3.8(18/1)). --- --- CHANGE HISTORY: --- 9 FEB 2001 PHL Initial version. --- 29 JUN 2002 RLB Readied for release. --- ---! -with Ada.Exceptions; -use Ada.Exceptions; -with Report; -use Report; -procedure C380001 is - - type Negative is range Integer'First .. -1; - - type R1 is - record - C : Negative := Negative (Ident_Int (R1'Size)); - end record; - - - type R2; - - type R3 (D1 : access R2; D2 : Natural) is limited null record; - - type R2 is limited - record - C : R3 (R2'Access, Ident_Int (-1)); - end record; - -begin - Test ("C380001", "Check that checks are made properly when a " & - "per-object expression contains an attribute whose " & - "prefix denotes the current instance of the type"); - begin - declare - X : R1; - begin - Failed - ("No exception raised when evaluating a per-object expression " & - "containing an attribute - 1"); - end; - exception - when Constraint_Error => - null; - when E: others => - Failed ("Exception " & Exception_Name (E) & - " raised - " & Exception_Information (E) & " - 1"); - end; - - declare - type A is access R1; - X : A; - begin - X := new R1; - Failed ("No exception raised when evaluating a per-object expression " & - "containing an attribute - 2"); - exception - when Constraint_Error => - null; - when E: others => - Failed ("Exception " & Exception_Name (E) & - " raised - " & Exception_Information (E) & " - 2"); - end; - - begin - declare - X : R2; - begin - Failed - ("No exception raised when elaborating a per-object constraint " & - "containing an attribute - 3"); - end; - exception - when Constraint_Error => - null; - when E: others => - Failed ("Exception " & Exception_Name (E) & - " raised - " & Exception_Information (E) & " - 3"); - end; - - declare - type A is access R2; - X : A; - begin - X := new R2; - Failed - ("No exception raised when evaluating a per-object constraint " & - "containing an attribute - 4"); - exception - when Constraint_Error => - null; - when E: others => - Failed ("Exception " & Exception_Name (E) & - " raised - " & Exception_Information (E) & " - 4"); - end; - - Result; -end C380001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c380002.a b/gcc/testsuite/ada/acats/tests/c3/c380002.a deleted file mode 100644 index ae58676cb26..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c380002.a +++ /dev/null @@ -1,72 +0,0 @@ --- C380002.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 ACAA 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 expression in a per-object discriminant constraint which is --- part of a named association is evaluated once for each association. --- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, --- RM95 3.8(18.1/1)). --- --- CHANGE HISTORY: --- 9 FEB 2001 PHL Initial version. --- 29 JUN 2002 RLB Readied for release. --- ---! -with Ada.Exceptions; -use Ada.Exceptions; -with Report; -use Report; -procedure C380002 is - - F_Val : Integer := Ident_Int (0); - - function F return Integer is - begin - F_Val := F_Val + Ident_Int (1); - return F_Val; - end F; - - type R1; - - type R2 (D0 : Integer; D1 : access R1; D2 : Integer; D3 : Integer) is - limited null record; - - type R1 is limited - record - C : R2 (D1 => R1'Access, D0 | D2 | D3 => F); - end record; - -begin - Test ("C380002", "Check that an expression in a per-object discriminant " & - "constraint which is part of a named association is " & - "evaluated once for each association"); - - if not Equal (F_Val, 3) then - Failed ("Expression not evaluated the proper number of times"); - end if; - - Result; -end C380002; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c380003.a b/gcc/testsuite/ada/acats/tests/c3/c380003.a deleted file mode 100644 index 451d177036c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c380003.a +++ /dev/null @@ -1,223 +0,0 @@ --- C380003.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 ACAA 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 per-object expressions are evaluated as specified for --- protected components. (Defect Report 8652/0002, as reflected in --- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)). --- --- CHANGE HISTORY: --- 9 FEB 2001 PHL Initial version. --- 29 JUN 2002 RLB Readied for release. --- ---! -with Report; -use Report; -procedure C380003 is - - subtype Sm is Integer range 1 .. 10; - - type Rec (D1, D2 : Sm) is - record - null; - end record; - -begin - Test ("C380003", - "Check compatibility of discriminant expressions" & - " when the constraint depends on discriminants, " & - "and the discriminants have defaults - protected components"); - - declare - protected type Cons (D3 : Integer := Ident_Int (11)) is - function C1_D1 return Integer; - function C1_D2 return Integer; - private - C1 : Rec (D3, 1); - end Cons; - protected body Cons is - function C1_D1 return Integer is - begin - return C1.D1; - end C1_D1; - function C1_D2 return Integer is - begin - return C1.D2; - end C1_D2; - end Cons; - - function Is_Ok - (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) - return Boolean is - begin - return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; - end Is_Ok; - - begin - begin - declare - X : Cons; - begin - Failed ("Discriminant check not performed - 1"); - if not Is_Ok (X, 1, 1, 1) then - Comment ("Shouldn't get here"); - end if; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception - 1"); - end; - - begin - declare - type Acc_Cons is access Cons; - X : Acc_Cons; - begin - X := new Cons; - Failed ("Discriminant check not performed - 2"); - begin - if not Is_Ok (X.all, 1, 1, 1) then - Comment ("Irrelevant"); - end if; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception raised - 2"); - end; - exception - when others => - Failed ("Constraint checked too soon - 2"); - end; - - begin - declare - subtype Scons is Cons; - begin - declare - X : Scons; - begin - Failed ("Discriminant check not performed - 3"); - if not Is_Ok (X, 1, 1, 1) then - Comment ("Irrelevant"); - end if; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception raised - 3"); - end; - exception - when others => - Failed ("Constraint checked too soon - 3"); - end; - - begin - declare - type Arr is array (1 .. 5) of Cons; - begin - declare - X : Arr; - begin - Failed ("Discriminant check not performed - 4"); - for I in Arr'Range loop - if not Is_Ok (X (I), 1, 1, 1) then - Comment ("Irrelevant"); - end if; - end loop; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception raised - 4"); - end; - exception - when others => - Failed ("Constraint checked too soon - 4"); - end; - - begin - declare - type Nrec is - record - C1 : Cons; - end record; - begin - declare - X : Nrec; - begin - Failed ("Discriminant check not performed - 5"); - if not Is_Ok (X.C1, 1, 1, 1) then - Comment ("Irrelevant"); - end if; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception raised - 5"); - end; - exception - when others => - Failed ("Constraint checked too soon - 5"); - end; - - begin - declare - type Drec is new Cons; - begin - declare - X : Drec; - begin - Failed ("Discriminant check not performed - 6"); - if not Is_Ok (Cons (X), 1, 1, 1) then - Comment ("Irrelevant"); - end if; - end; - exception - when Constraint_Error => - null; - when others => - Failed ("Unexpected exception raised - 6"); - end; - exception - when others => - Failed ("Constraint checked too soon - 6"); - end; - - end; - - Result; - -exception - when others => - Failed ("Constraint check done too early"); - Result; -end C380003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c380004.a b/gcc/testsuite/ada/acats/tests/c3/c380004.a deleted file mode 100644 index f83728b5f48..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c380004.a +++ /dev/null @@ -1,385 +0,0 @@ --- C380004.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 ACAA 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 per-object expressions are evaluated as specified for entry --- families and protected components. (Defect Report 8652/0002, --- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and --- 9.5.2(22/1)). --- --- CHANGE HISTORY: --- 9 FEB 2001 PHL Initial version. --- 29 JUN 2002 RLB Readied for release. --- ---! -with Report; -use Report; -procedure C380004 is - - type Rec (D1, D2 : Positive) is - record - null; - end record; - - F1_Poe : Integer; - - function Chk (Poe : Integer; Value : Integer; Message : String) - return Boolean is - begin - if Poe /= Value then - Failed (Message & ": Poe is " & Integer'Image (Poe)); - end if; - return True; - end Chk; - - function F1 return Integer is - begin - F1_Poe := F1_Poe - Ident_Int (1); - return F1_Poe; - end F1; - - generic - type T is limited private; - with function Is_Ok (X : T; - Param1 : Integer; - Param2 : Integer; - Param3 : Integer) return Boolean; - procedure Check; - - procedure Check is - begin - - declare - type Poe is new T; - Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated"); - X : Poe; -- F1 evaluated - Y : Poe; -- F1 evaluated - Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated"); - begin - if not Is_Ok (T (X), 16, 16, 17) or - not Is_Ok (T (Y), 15, 15, 17) then - Failed ("Discriminant values not correct - 0"); - end if; - end; - - declare - type Poe is new T; - begin - begin - declare - X : Poe; - begin - if not Is_Ok (T (X), 14, 14, 17) then - Failed ("Discriminant values not correct - 1"); - end if; - end; - exception - when others => - Failed ("Unexpected exception - 1"); - end; - - declare - type Acc_Poe is access Poe; - X : Acc_Poe; - begin - X := new Poe; - begin - if not Is_Ok (T (X.all), 13, 13, 17) then - Failed ("Discriminant values not correct - 2"); - end if; - end; - exception - when others => - Failed ("Unexpected exception raised - 2"); - end; - - declare - subtype Spoe is Poe; - X : Spoe; - begin - if not Is_Ok (T (X), 12, 12, 17) then - Failed ("Discriminant values not correct - 3"); - end if; - exception - when others => - Failed ("Unexpected exception raised - 3"); - end; - - declare - type Arr is array (1 .. 2) of Poe; - X : Arr; - begin - if Is_Ok (T (X (1)), 11, 11, 17) and then - Is_Ok (T (X (2)), 10, 10, 17) then - null; - elsif Is_Ok (T (X (2)), 11, 11, 17) and then - Is_Ok (T (X (1)), 10, 10, 17) then - null; - else - Failed ("Discriminant values not correct - 4"); - end if; - exception - when others => - Failed ("Unexpected exception raised - 4"); - end; - - declare - type Nrec is - record - C1, C2 : Poe; - end record; - X : Nrec; - begin - if Is_Ok (T (X.C1), 8, 8, 17) and then - Is_Ok (T (X.C2), 9, 9, 17) then - null; - elsif Is_Ok (T (X.C2), 8, 8, 17) and then - Is_Ok (T (X.C1), 9, 9, 17) then - null; - else - Failed ("Discriminant values not correct - 5"); - end if; - exception - when others => - Failed ("Unexpected exception raised - 5"); - end; - - declare - type Drec is new Poe; - X : Drec; - begin - if not Is_Ok (T (X), 7, 7, 17) then - Failed ("Discriminant values not correct - 6"); - end if; - exception - when others => - Failed ("Unexpected exception raised - 6"); - end; - end; - end Check; - - -begin - Test ("C380004", - "Check evaluation of discriminant expressions " & - "when the constraint depends on a discriminant, " & - "and the discriminants have defaults - discriminant-dependent" & - "entry families and protected components"); - - - Comment ("Discriminant-dependent entry families for task types"); - - F1_Poe := 18; - - declare - task type Poe (D3 : Positive := F1) is - entry E (D3 .. F1); -- F1 evaluated - entry Is_Ok (D3 : Integer; - E_First : Integer; - E_Last : Integer; - Ok : out Boolean); - end Poe; - task body Poe is - begin - loop - select - accept Is_Ok (D3 : Integer; - E_First : Integer; - E_Last : Integer; - Ok : out Boolean) do - declare - Cnt : Natural; - begin - if Poe.D3 = D3 then - -- Can't think of a better way to check the - -- bounds of the entry family. - begin - Cnt := E (E_First)'Count; - Cnt := E (E_Last)'Count; - exception - when Constraint_Error => - Ok := False; - return; - end; - begin - Cnt := E (E_First - 1)'Count; - Ok := False; - return; - exception - when Constraint_Error => - null; - when others => - Ok := False; - return; - end; - begin - Cnt := E (E_Last + 1)'Count; - Ok := False; - return; - exception - when Constraint_Error => - null; - when others => - Ok := False; - return; - end; - Ok := True; - else - Ok := False; - return; - end if; - end; - end Is_Ok; - or - terminate; - end select; - end loop; - end Poe; - - function Is_Ok - (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) - return Boolean is - Ok : Boolean; - begin - C.Is_Ok (D3, E_First, E_Last, Ok); - return Ok; - end Is_Ok; - - procedure Chk is new Check (Poe, Is_Ok); - - begin - Chk; - end; - - - Comment ("Discriminant-dependent entry families for protected types"); - - F1_Poe := 18; - - declare - protected type Poe (D3 : Integer := F1) is - entry E (D3 .. F1); -- F1 evaluated - function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) - return Boolean; - end Poe; - protected body Poe is - entry E (for I in D3 .. F1) when True is - begin - null; - end E; - function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) - return Boolean is - Cnt : Natural; - begin - if Poe.D3 = D3 then - -- Can't think of a better way to check the - -- bounds of the entry family. - begin - Cnt := E (E_First)'Count; - Cnt := E (E_Last)'Count; - exception - when Constraint_Error => - return False; - end; - begin - Cnt := E (E_First - 1)'Count; - return False; - exception - when Constraint_Error => - null; - when others => - return False; - end; - begin - Cnt := E (E_Last + 1)'Count; - return False; - exception - when Constraint_Error => - null; - when others => - return False; - end; - return True; - else - return False; - end if; - end Is_Ok; - end Poe; - - function Is_Ok - (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) - return Boolean is - begin - return C.Is_Ok (D3, E_First, E_Last); - end Is_Ok; - - procedure Chk is new Check (Poe, Is_Ok); - - begin - Chk; - end; - - Comment ("Protected components"); - - F1_Poe := 18; - - declare - protected type Poe (D3 : Integer := F1) is - function C1_D1 return Integer; - function C1_D2 return Integer; - private - C1 : Rec (D3, F1); -- F1 evaluated - end Poe; - protected body Poe is - function C1_D1 return Integer is - begin - return C1.D1; - end C1_D1; - function C1_D2 return Integer is - begin - return C1.D2; - end C1_D2; - end Poe; - - function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) - return Boolean is - begin - return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; - end Is_Ok; - - procedure Chk is new Check (Poe, Is_Ok); - - begin - Chk; - end; - - Result; - -exception - when others => - Failed ("Unexpected exception"); - Result; - -end C380004; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900010.a b/gcc/testsuite/ada/acats/tests/c3/c3900010.a deleted file mode 100644 index 6d9ddb4a1db..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900010.a +++ /dev/null @@ -1,147 +0,0 @@ --- C3900010.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 C3900011.AM. --- --- TEST DESCRIPTION: --- See C3900011.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- => C3900010.A --- C3900011.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package C3900010 is - - - -- Declarations used by component Display_On and procedure Display. - - type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); - type Display_Counters is array (Device_Enum) of Natural; - - Display_Count_For : Display_Counters := (others => 0); - - - -- Declarations required for component Arrival_Time. - - Default_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1901, 1, 1); - Alert_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1991, 6, 15); - - - type Alert_Type is tagged record -- Root tagged type. - Arrival_Time : Ada.Calendar.Time := Default_Time; - Display_On : Device_Enum := Null_Device; - end record; - - - procedure Display (A : in Alert_Type); -- To be inherited by - -- all derivatives. - - procedure Handle (A : in out Alert_Type); -- To be inherited by - -- all derivatives. - - - - type Low_Alert_Type is new Alert_Type with record -- Record extension of - Level : Integer := 0; -- root tagged type. - end record; - - -- Inherits procedure Display from Alert. - -- Inherits procedure Handle from Alert. - - function Level_Of (LA : in Low_Alert_Type) -- To be inherited by - return Integer; -- all derivatives. - - - - -- Declarations required for component Action_Officer; - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - - type Medium_Alert_Type is new Low_Alert_Type with record - Action_Officer : Person_Enum := Nobody; -- Record extension of - end record; -- record extension. - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits (inherited) procedure Handle from Low_Alert_Type. - - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - -end C3900010; - - - --==================================================================-- - - -package body C3900010 is - - - procedure Display (A : in Alert_Type) is - begin - Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; - end Display; - - - procedure Handle (A : in out Alert_Type) is - begin - A.Arrival_Time := Alert_Time; - end Handle; - - - function Level_Of (LA : in Low_Alert_Type) return Integer is - begin - return (LA.Level + 1); - end Level_Of; - - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - -end C3900010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390002.a b/gcc/testsuite/ada/acats/tests/c3/c390002.a deleted file mode 100644 index b3d11afed26..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390002.a +++ /dev/null @@ -1,165 +0,0 @@ --- C390002.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 tagged base type may be declared, and derived --- from in simple, private and extended forms. (Overlaps with C390B04) --- Check that the package Ada.Tags is present and correctly implemented. --- Check for the correct operation of Expanded_Name, External_Tag and --- Internal_Tag within that package. Check that the exception Tag_Error --- is correctly raised on calling Internal_Tag with bad input. --- --- TEST DESCRIPTION: --- This test declares a tagged type, and derives three types from it. --- These types are then used to test the presence and function of the --- package Ada.Tags. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 27 Jan 96 SAIC Update RM references for 2.1 --- ---! - -with Report; -with Ada.Tags; - -procedure C390002 is - - package Vehicle is - - type Object is tagged limited private; -- ancestor type - procedure Create( The_Vehicle : in out Object; Wheels : in Natural ); - function Wheels( The_Vehicle : Object ) return Natural; - - private - - type Object is tagged limited record - Wheel_Count : Natural := 0; - end record; - - end Vehicle; - - package Motivators is - - type Bicycle is new Vehicle.Object with null record; -- simple - - type Car is new Vehicle.Object with record -- extended - Convertible : Boolean; - end record; - - type Truck is new Vehicle.Object with private; -- private - - private - - type Truck is new Vehicle.Object with record - Air_Horn : Boolean; - end record; - - end Motivators; - - package body Vehicle is - - procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is - begin - The_Vehicle.Wheel_Count := Wheels; - end Create; - - function Wheels( The_Vehicle : Object ) return Natural is - begin - return The_Vehicle.Wheel_Count; - end Wheels; - - end Vehicle; - - function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is - begin - return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) ); - Report.Comment("This message intentionally blank."); - end TC_ID_Tag; - - procedure Check_Tags( Machine : in Vehicle.Object'Class; - Expected_Name : in String; - External_Tag : in String ) is - The_Tag : constant Ada.Tags.Tag := Machine'Tag; - use type Ada.Tags.Tag; - begin - if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then - Report.Failed ("Failed in Check_Tags, Expanded_Name " - & Expected_Name); - end if; - if Ada.Tags.External_Tag(The_Tag) /= External_Tag then - Report.Failed ("Failed in Check_Tags, External_Tag " - & Expected_Name); - end if; - if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then - Report.Failed ("Failed in Check_Tags, Internal_Tag " - & Expected_Name); - end if; - end Check_Tags; - - procedure Check_Exception is - Boeing_777_Id : Ada.Tags.Tag; - begin - Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!"); - Report.Failed ("Failed in Check_Exception, no exception"); - Boeing_777_Id := TC_ID_Tag( Boeing_777_Id ); - exception - when Ada.Tags.Tag_Error => null; - when others => - Report.Failed ("Failed in Check_Exception, wrong exception"); - end Check_Exception; - - use Motivators; - Two_Wheeler : Bicycle; - Four_Wheeler : Car; - Eighteen_Wheeler : Truck; - -begin -- Main test procedure. - - Report.Test ("C390002", "Check that a tagged type may be declared and " & - "derived from in simple, private and extended forms. " & - "Check package Ada.Tags" ); - - Create( Two_Wheeler, 2 ); - Create( Four_Wheeler, 4 ); - Create( Eighteen_Wheeler, 18 ); - - Check_Tags( Machine => Two_Wheeler, - Expected_Name => "C390002.MOTIVATORS.BICYCLE", - External_Tag => Bicycle'External_Tag ); - Check_Tags( Machine => Four_Wheeler, - Expected_Name => "C390002.MOTIVATORS.CAR", - External_Tag => Car'External_Tag ); - Check_Tags( Machine => Eighteen_Wheeler, - Expected_Name => "C390002.MOTIVATORS.TRUCK", - External_Tag => Truck'External_Tag ); - - Check_Exception; - - Report.Result; - -end C390002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc/testsuite/ada/acats/tests/c3/c390003.a deleted file mode 100644 index 643aad1cd18..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390003.a +++ /dev/null @@ -1,419 +0,0 @@ --- C390003.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 for a subtype S of a tagged type T, S'Class denotes a --- class-wide subtype. Check that T'Tag denotes the tag of the type T, --- and that, for a class-wide tagged type X, X'Tag denotes the tag of X. --- Check that the tags of stand alone objects, record and array --- components, aggregates, and formal parameters identify their type. --- Check that the tag of a value of a formal parameter is that of the --- actual parameter, even if the actual is passed by a view conversion. --- --- TEST DESCRIPTION: --- This test defines a class hierarchy (based on C390002) and --- uses it to determine the correctness of the resulting tag --- information generated by the compiler. A type is defined in the --- class which contains components of the class as part of its --- definition. This is to reduce the overall number of types --- required, and to achieve the required nesting to accomplish --- this test. The model is that of a car carrier truck; both car --- and truck being in the class of Vehicle. --- --- Class Hierarchy: --- Vehicle - - - - - - - (Bicycle) --- / | \ / \ --- Truck Car Q_Machine Tandem Motorcycle --- | --- Auto_Carrier --- Contains: --- Auto_Carrier( Car ) --- Q_Machine( Car, Motorcycle ) --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed ARM references from objective text. --- 20 Dec 94 SAIC Replaced three unnecessary extension --- aggregates with simple aggregates. --- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 --- ---! - ------------------------------------------------------------------ C390003_1 - -with Ada.Tags; -package C390003_1 is -- Vehicle - - type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy); - type States is (Good, Flat, Worn); - - type Wheel_List is array(Positive range <>) of States; - - type Object(Wheels: Positive) is tagged record - Wheel_State : Wheel_List(1..Wheels); - end record; - - procedure TC_Validate( It: Object; Key: TC_Keys ); - procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ); - - procedure Create( The_Vehicle : in out Object; Tyres : in States ); - procedure Rotate( The_Vehicle : in out Object ); - function Wheels( The_Vehicle : Object ) return Positive; - -end C390003_1; -- Vehicle; - ------------------------------------------------------------------ C390003_2 - -with C390003_1; -package C390003_2 is -- Motivators - - package Vehicle renames C390003_1; - subtype Bicycle is Vehicle.Object(2); -- constrained subtype - - type Motorcycle is new Bicycle with record - Displacement : Natural; - end record; - procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ); - - type Tandem is new Bicycle with null record; - procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ); - - type Car is new Vehicle.Object(4) with -- extended, constrained - record - Displacement : Natural; - end record; - procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ); - - type Truck is new Vehicle.Object with -- extended, unconstrained - record - Tare : Natural; - end record; - procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ); - -end C390003_2; -- Motivators; - ------------------------------------------------------------------ C390003_3 - -with C390003_1; -with C390003_2; -package C390003_3 is -- Special_Trucks - package Vehicle renames C390003_1; - package Motivators renames C390003_2; - Max_Cars_On_Vehicle : constant := 6; - type Cargo_Index is range 0..Max_Cars_On_Vehicle; - type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle) - of Motivators.Car; - type Auto_Carrier is new Motivators.Truck(18) with - record - Load_Count : Cargo_Index := 0; - Payload : Cargo; - end record; - procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ); - procedure Load ( The_Car : in Motivators.Car; - Onto : in out Auto_Carrier); - procedure Unload( The_Car : out Motivators.Car; - Off_of : in out Auto_Carrier); -end C390003_3; - ------------------------------------------------------------------ C390003_4 - -with C390003_1; -with C390003_2; -package C390003_4 is -- James_Bond - - package Vehicle renames C390003_1; - package Motivators renames C390003_2; - - type Q_Machine is new Vehicle.Object(4) with record - Car_Part : Motivators.Car; - Bike_Part : Motivators.Motorcycle; - end record; - procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ); - -end C390003_4; - ------------------------------------------------------------------ C390003_1 - -with Report; -with Ada.Tags; -package body C390003_1 is -- Vehicle - - function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; - - procedure TC_Validate( It: Object; Key: TC_Keys ) is - begin - if Key /= Veh then - Report.Failed("Expected Veh Key"); - end if; - end TC_Validate; - - procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is - begin - if It'Tag /= The_Tag then - Report.Failed("Unexpected Tag for classwide formal"); - end if; - end TC_Validate; - - procedure Create( The_Vehicle : in out Object; Tyres : in States ) is - begin - The_Vehicle.Wheel_State := ( others => Tyres ); - end Create; - - function Wheels( The_Vehicle : Object ) return Positive is - begin - return The_Vehicle.Wheels; - end Wheels; - - procedure Rotate( The_Vehicle : in out Object ) is - Push : States; - Pulled : States - := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last); - begin - for Finger in - The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop - Push := The_Vehicle.Wheel_State(Finger); - The_Vehicle.Wheel_State(Finger) := Pulled; - Pulled := Push; - end loop; - end Rotate; - -end C390003_1; -- Vehicle; - ------------------------------------------------------------------ C390003_2 - -with Ada.Tags; -with Report; -package body C390003_2 is -- Motivators - - function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; - function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; - - procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.MC then - Report.Failed("Expected MC Key"); - end if; - end TC_Validate; - - procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.Tand then - Report.Failed("Expected Tand Key"); - end if; - end TC_Validate; - - procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.Car then - Report.Failed("Expected Car Key"); - end if; - end TC_Validate; - - procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.Truk then - Report.Failed("Expected Truk Key"); - end if; - end TC_Validate; -end C390003_2; -- Motivators; - ------------------------------------------------------------------ C390003_3 - -with Ada.Tags; -with Report; -package body C390003_3 is -- Special_Trucks - - function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; - function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; - - procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.Heavy then - Report.Failed("Expected Heavy Key"); - end if; - end TC_Validate; - - procedure Load ( The_Car : in Motivators.Car; - Onto : in out Auto_Carrier) is - begin - Onto.Load_Count := Onto.Load_Count +1; - Onto.Payload(Onto.Load_Count) := The_Car; - end Load; - procedure Unload( The_Car : out Motivators.Car; - Off_of : in out Auto_Carrier) is - begin - The_Car := Off_of.Payload(Off_of.Load_Count); - Off_of.Load_Count := Off_of.Load_Count -1; - end Unload; - -end C390003_3; - ------------------------------------------------------------------ C390003_4 - -with Report, Ada.Tags; -package body C390003_4 is -- James_Bond - - function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; - function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; - - procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is - begin - if Key /= Vehicle.Q then - Report.Failed("Expected Q Key"); - end if; - end TC_Validate; - -end C390003_4; - -------------------------------------------------------------------- C390003 - -with Report; -with C390003_1; -with C390003_2; -with C390003_3; -with C390003_4; -procedure C390003 is - - package Vehicle renames C390003_1; use Vehicle; - package Motivators renames C390003_2; - package Special_Trucks renames C390003_3; - package James_Bond renames C390003_4; - - -- The cast, in order of complexity: - - Pennys_Bike : Motivators.Bicycle; - Weekender : Motivators.Tandem; - Qs_Moped : Motivators.Motorcycle; - Ms_Limo : Motivators.Car; - Yard_Van : Motivators.Truck(8); - Specter_X : Special_Trucks.Auto_Carrier; - Gen_II : James_Bond.Q_Machine; - - - -- Check compatibility with the corresponding class wide type. - - procedure Vehicle_Shop( It : in out Vehicle.Object'Class; - Key : in Vehicle.TC_Keys ) is - - -- Check that Subtype'Class is defined for tagged subtypes. - procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is - begin - -- Dispatch to appropriate TC_Validate - Vehicle.TC_Validate( Bike, Key ); - end Bike_Shop; - - begin - Vehicle.TC_Validate( It, Key ); - if Vehicle.Wheels( It ) = 2 then - Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels - end if; - end Vehicle_Shop; - -begin -- Main test procedure. - - Report.Test ("C390003", "Check that for a subtype S of a tagged type " & - "T, S'Class denotes a class-wide subtype. Check that " & - "T'Tag denotes the tag of the type T, and that, for a " & - "class-wide tagged type X, X'Tag denotes the tag of X. " & - "Check that the tags of stand alone objects, record and " & - "array components, aggregates, and formal parameters " & - "identify their type. Check that the tag of a value of a " & - "formal parameter is that of the actual parameter, even " & - "if the actual is passed by a view conversion" ); - --- Check that the tags of stand alone objects, record and array --- components, aggregates, and formal parameters identify their type. --- Check that the tag of a value of a formal parameter is that of the --- actual parameter, even if the actual is passed by a view conversion. - - Vehicle_Shop( Pennys_Bike, Veh ); - Vehicle_Shop( Weekender, Tand ); - Vehicle_Shop( Qs_Moped, MC ); - Vehicle_Shop( Ms_Limo, Car ); - Vehicle_Shop( Yard_Van, Truk ); - Vehicle_Shop( Specter_X, Heavy ); - Vehicle_Shop( Specter_X.Payload(1), Car ); - Vehicle_Shop( Gen_II, Q ); - Vehicle_Shop( Gen_II.Car_Part, Car ); - Vehicle_Shop( Gen_II.Bike_Part, MC ); - - Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag ); - Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag ); - Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag ); - Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag ); - Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag ); - Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag ); - Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag ); - Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag ); - Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag ); - Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag ); - --- Check the tag generated for an aggregate. - - Rentals: declare - Mikes_Rental : Vehicle.Object'Class := - Vehicle.Object'( 3, (Good, Flat, Worn)); - Diannes_Car : Vehicle.Object'Class := - Motivators.Tandem'( Wheels => 2, - Wheel_State => (Good, Good) ); - Jims_Bike : Vehicle.Object'Class := - Motivators.Motorcycle'( Pennys_Bike - with Displacement => 350 ); - Bills_Limo : Vehicle.Object'Class := - Motivators.Car'( Wheels => 4, - Wheel_State => (others => Good), - Displacement => 282 ); - Alans_Car : Vehicle.Object'Class := - Motivators.Truck'( 18, (others => Worn), - Tare => 5_500 ); - Pats_Truck : Vehicle.Object'Class := Specter_X; - Keiths_Car : Vehicle.Object'Class := Gen_II; - Isaacs_Bus : Vehicle.Object'Class := Keiths_Car; - - begin - Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag ); - Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag ); - Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag ); - Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag ); - Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag ); - Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag ); - Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag ); - end Rentals; - --- Check the tag of parameters. --- Check that the tag is not affected by view conversion. - - Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag ); - Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag ); - Vehicle.TC_Validate( Motivators.Bicycle( Weekender ), - Motivators.Tandem'Tag ); - Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ), - Motivators.Motorcycle'Tag ); - - Report.Result; - -end C390003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390004.a b/gcc/testsuite/ada/acats/tests/c3/c390004.a deleted file mode 100644 index 2c120bab92b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390004.a +++ /dev/null @@ -1,404 +0,0 @@ --- C390004.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 tags of allocated objects correctly identify the --- type of the allocated object. Check that the tag corresponds --- correctly to the value resulting from both normal and view --- conversion. Check that the tags of accessed values designating --- aliased objects correctly identify the type of the object. Check --- that the tag of a function result correctly evaluates. Check this --- for class-wide functions. The tag of a class-wide function result --- should be the tag appropriate to the actual value returned, not the --- tag of the ancestor type. --- --- TEST DESCRIPTION: --- This test defines a class hierarchy of types, with reference --- semantics (an access type to the class-wide type). Similar in --- structure to C392005, this test checks that dynamic allocation does --- not adversely impact the tagging of types. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C390004_1 is -- DMV - type Equipment is ( T_Veh, T_Car, T_Con, T_Jep ); - - type Vehicle is tagged record - Wheels : Natural := 4; - Parked : Boolean := False; - end record; - - function Wheels ( It: Vehicle ) return Natural; - procedure Park ( It: in out Vehicle ); - procedure UnPark ( It: in out Vehicle ); - procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ); - procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ); - - type Car is new Vehicle with record - Passengers : Natural := 0; - end record; - - function Passengers ( It: Car ) return Natural; - procedure Load_Passengers( It: in out Car; To_Count: in Natural ); - procedure Park ( It: in out Car ); - procedure TC_Check ( It: in Car; To_Equip: in Equipment ); - - type Convertible is new Car with record - Top_Up : Boolean := True; - end record; - - function Top_Up ( It: Convertible ) return Boolean; - procedure Lower_Top( It: in out Convertible ); - procedure Park ( It: in out Convertible ); - procedure Raise_Top( It: in out Convertible ); - procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ); - - type Jeep is new Convertible with record - Windshield_Up : Boolean := True; - end record; - - function Windshield_Up ( It: Jeep ) return Boolean; - procedure Lower_Windshield( It: in out Jeep ); - procedure Park ( It: in out Jeep ); - procedure Raise_Windshield( It: in out Jeep ); - procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ); - -end C390004_1; - -with Report; -package body C390004_1 is - - procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is - begin - It.Wheels := To_Count; - end Set_Wheels; - - function Wheels( It: Vehicle ) return Natural is - begin - return It.Wheels; - end Wheels; - - procedure Park ( It: in out Vehicle ) is - begin - It.Parked := True; - end Park; - - procedure UnPark ( It: in out Vehicle ) is - begin - It.Parked := False; - end UnPark; - - procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Veh then - Report.Failed ("Failed, called Vehicle for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Car then - Report.Failed ("Failed, called Car for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Con then - Report.Failed ("Failed, called Convertible for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is - begin - if To_Equip /= T_Jep then - Report.Failed ("Failed, called Jeep for " - & Equipment'Image(To_Equip)); - end if; - end TC_Check; - - procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is - begin - It.Passengers := To_Count; - UnPark( It ); - end Load_Passengers; - - procedure Park( It: in out Car ) is - begin - It.Passengers := 0; - Park( Vehicle( It ) ); - end Park; - - function Passengers( It: Car ) return Natural is - begin - return It.Passengers; - end Passengers; - - procedure Raise_Top( It: in out Convertible ) is - begin - It.Top_Up := True; - end Raise_Top; - - procedure Lower_Top( It: in out Convertible ) is - begin - It.Top_Up := False; - end Lower_Top; - - function Top_Up ( It: Convertible ) return Boolean is - begin - return It.Top_Up; - end Top_Up; - - procedure Park ( It: in out Convertible ) is - begin - It.Top_Up := True; - Park( Car( It ) ); - end Park; - - procedure Raise_Windshield( It: in out Jeep ) is - begin - It.Windshield_Up := True; - end Raise_Windshield; - - procedure Lower_Windshield( It: in out Jeep ) is - begin - It.Windshield_Up := False; - end Lower_Windshield; - - function Windshield_Up( It: Jeep ) return Boolean is - begin - return It.Windshield_Up; - end Windshield_Up; - - procedure Park( It: in out Jeep ) is - begin - It.Windshield_Up := True; - Park( Convertible( It ) ); - end Park; -end C390004_1; - -with Report; -with Ada.Tags; -with C390004_1; -procedure C390004 is - package DMV renames C390004_1; - - The_Vehicle : aliased DMV.Vehicle; - The_Car : aliased DMV.Car; - The_Convertible : aliased DMV.Convertible; - The_Jeep : aliased DMV.Jeep; - - type C_Reference is access all DMV.Car'Class; - type V_Reference is access all DMV.Vehicle'Class; - - Designator : V_Reference; - Storage : Natural; - - procedure Valet( It: in out DMV.Vehicle'Class ) is - begin - DMV.Park( It ); - end Valet; - - procedure TC_Match( Object: DMV.Vehicle'Class; - Taglet: Ada.Tags.Tag; - Where : String ) is - use Ada.Tags; - begin - if Object'Tag /= Taglet then - Report.Failed("Tag mismatch: " & Where); - end if; - end TC_Match; - - procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 1 or not It.Parked then - Report.Failed ("Failed Vehicle " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0 - or not It.Parked then - Report.Failed ("Failed Car " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Convertible; - TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0 - or not DMV.Top_Up( It ) or not It.Parked then - Report.Failed ("Failed Convertible " & TC_Message); - end if; - end Parking_Validation; - - procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is - begin - if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0 - or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It ) - or not It.Parked then - Report.Failed ("Failed Jeep " & TC_Message); - end if; - end Parking_Validation; - - function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag ) - return DMV.Vehicle'Class is - This_Machine : DMV.Vehicle'Class := It.all; - begin - TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); - Storage := DMV.Wheels( This_Machine ); - return This_Machine; - end Wash; - - function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag ) - return DMV.Car'Class is - This_Machine : DMV.Car'Class := It.all; - begin - TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); - Storage := DMV.Wheels( This_Machine ); - return This_Machine; - end Wash; - -begin - - Report.Test( "C390004", "Check that the tags of allocated objects " - & "correctly identify the type of the allocated " - & "object. Check that tags resulting from " - & "normal and view conversions. Check tags of " - & "accessed values designating aliased objects. " - & "Check function result tags" ); - - DMV.Set_Wheels( The_Vehicle, 1 ); - DMV.Set_Wheels( The_Car, 2 ); - DMV.Set_Wheels( The_Convertible, 3 ); - DMV.Set_Wheels( The_Jeep, 4 ); - - Valet( The_Vehicle ); - Valet( The_Car ); - Valet( The_Convertible ); - Valet( The_Jeep ); - - Parking_Validation( The_Vehicle, "setup" ); - Parking_Validation( The_Car, "setup" ); - Parking_Validation( The_Convertible, "setup" ); - Parking_Validation( The_Jeep, "setup" ); - --- Check that the tags of allocated objects correctly identify the type --- of the allocated object. - - Designator := new DMV.Vehicle; - DMV.TC_Check( Designator.all, DMV.T_Veh ); - TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" ); - - Designator := new DMV.Car; - DMV.TC_Check( Designator.all, DMV.T_Car ); - TC_Match( Designator.all, DMV.Car'Tag, "allocated Car"); - - Designator := new DMV.Convertible; - DMV.TC_Check( Designator.all, DMV.T_Con ); - TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" ); - - Designator := new DMV.Jeep; - DMV.TC_Check( Designator.all, DMV.T_Jep ); - TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" ); - --- Check that view conversion causes the correct dispatch - DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh ); - DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car ); - DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con ); - --- And that view conversion does not change the tag - TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" ); - TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" ); - TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" ); - --- Check that the tags of accessed values designating aliased objects --- correctly identify the type of the object. - Designator := The_Vehicle'Access; - DMV.TC_Check( Designator.all, DMV.T_Veh ); - TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" ); - - Designator := The_Car'Access; - DMV.TC_Check( Designator.all, DMV.T_Car ); - TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" ); - - Designator := The_Convertible'Access; - DMV.TC_Check( Designator.all, DMV.T_Con ); - TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" ); - - Designator := The_Jeep'Access; - DMV.TC_Check( Designator.all, DMV.T_Jep ); - TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" ); - --- Check that the tag of a function result correctly evaluates. --- Check this for class-wide functions. The tag of a class-wide --- function result should be the tag appropriate to the actual value --- returned, not the tag of the ancestor type. - Function_Check: declare - A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle ); - A_Car : C_Reference := new DMV.Car'( The_Car ); - A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible ); - A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep ); - begin - DMV.Unpark( A_Vehicle.all ); - DMV.Load_Passengers( A_Car.all, 5 ); - DMV.Load_Passengers( A_Convertible.all, 6 ); - DMV.Load_Passengers( A_Jeep.all, 7 ); - DMV.Lower_Top( DMV.Convertible(A_Convertible.all) ); - DMV.Lower_Top( DMV.Jeep(A_Jeep.all) ); - DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) ); - - if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4 - or Storage /= 4 then - Report.Failed("Did not correctly wash Jeep"); - end if; - - if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3 - or Storage /= 3 then - Report.Failed("Did not correctly wash Convertible"); - end if; - - if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2 - or Storage /= 2 then - Report.Failed("Did not correctly wash Car"); - end if; - - if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1 - or Storage /= 1 then - Report.Failed("Did not correctly wash Vehicle"); - end if; - - end Function_Check; - - Report.Result; -end C390004; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900050.a b/gcc/testsuite/ada/acats/tests/c3/c3900050.a deleted file mode 100644 index 8a00b265654..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900050.a +++ /dev/null @@ -1,157 +0,0 @@ --- C3900050.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 C3900053.AM. --- --- TEST DESCRIPTION: --- See C3900053.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- => C3900050.A --- C3900051.A --- C3900052.A --- C3900053.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package C3900050 is -- Alert system abstraction. - - -- Declarations used by component Arrival_Time. - - Default_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1901, 1, 1); - Alert_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1991, 6, 15); - - - -- Declarations used by component Display_On and procedure Display. - - type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); - type Display_Counters is array (Device_Enum) of Natural; - - Display_Count_For : Display_Counters := (others => 0); - - - - type Alert_Type is tagged private; -- Root tagged type. - - procedure Set_Display (A : in out Alert_Type; -- To be inherited by - D : in Device_Enum); -- all derivatives. - - procedure Display (A : in Alert_Type); -- To be inherited by - -- all derivatives. - - procedure Handle (A : in out Alert_Type); -- To be overridden by - -- all derivatives. - - - -- The following functions are needed to verify the values of the - -- root tagged type's private components. - - function Get_Time (A: Alert_Type) return Ada.Calendar.Time; - - function Get_Display (A: Alert_Type) return Device_Enum; - - function Initial_Values_Okay (A : in Alert_Type) - return Boolean; - - function Bad_Final_Values (A : in Alert_Type) - return Boolean; - -private - - type Alert_Type is tagged record -- Root tagged type. - Arrival_Time : Ada.Calendar.Time := Default_Time; - Display_On : Device_Enum := Null_Device; - end record; - - -end C3900050; - - - --==================================================================-- - - -package body C3900050 is -- Alert system abstraction. - - - procedure Set_Display (A : in out Alert_Type; - D : in Device_Enum) is - begin - A.Display_On := D; - end Set_Display; - - - procedure Display (A : in Alert_Type) is - begin - Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; - end Display; - - - procedure Handle (A : in out Alert_Type) is - begin - A.Arrival_Time := Alert_Time; - Display (A); - end Handle; - - - function Get_Time (A: Alert_Type) return Ada.Calendar.Time is - begin - return A.Arrival_Time; - end Get_Time; - - - function Get_Display (A: Alert_Type) return Device_Enum is - begin - return A.Display_On; - end Get_Display; - - - function Initial_Values_Okay (A : in Alert_Type) return Boolean is - begin - return (A = (Arrival_Time => Default_Time, -- Check "=" operator - Display_On => Null_Device)); -- availability. - end Initial_Values_Okay; -- Aggregate with - -- named associations. - - function Bad_Final_Values (A : in Alert_Type) return Boolean is - begin - return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator - -- availability. - end Bad_Final_Values; -- Aggregate with - -- positional assoc. - -end C3900050; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900051.a b/gcc/testsuite/ada/acats/tests/c3/c3900051.a deleted file mode 100644 index d23a62bff45..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900051.a +++ /dev/null @@ -1,137 +0,0 @@ --- C3900051.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 C3900053.AM. --- --- TEST DESCRIPTION: --- See C3900053.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- C3900050.A --- => C3900051.A --- C3900052.A --- C3900053.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with C3900050; -- Alert system abstraction. -package C3900051 is -- Extended alert system abstraction. - - - type Low_Alert_Type is new C3900050.Alert_Type - with private; -- Private extension of - -- root tagged type. - - -- Inherits procedure Display from Alert_Type. - - procedure Handle (LA : in out Low_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by - L : in Integer); -- all derivatives. - - - -- The following functions are needed to verify the values of the - -- extension's private components. - - function Get_Level (LA: Low_Alert_Type) return Integer; - - function Initial_Values_Okay (LA : in Low_Alert_Type) - return Boolean; -- Override parent's - -- primitive subprog. - - function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's - return Boolean; -- primitive subprog. - - -private - - type Low_Alert_Type is new C3900050.Alert_Type with record - Level : Integer := 0; - end record; - -end C3900051; - - - --==================================================================-- - - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package body C3900051 is -- Extended alert system abstraction. - - use C3900050; -- Alert system abstraction. - - - procedure Set_Level (LA : in out Low_Alert_Type; - L : in Integer) is - begin - LA.Level := L; - end Set_Level; - - - procedure Handle (LA : in out Low_Alert_Type) is - begin - Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). - Set_Level (LA, 1); -- Call newly declared operation. - Set_Display (Alert_Type(LA), - Teletype); -- Call parent's operation (type conversion). - Display (LA); - end Handle; - - - function Get_Level (LA: Low_Alert_Type) return Integer is - begin - return LA.Level; - end Get_Level; - - - function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is - begin - -- Call parent's operation (type conversion). - return (Initial_Values_Okay (Alert_Type (LA)) and - LA.Level = 0); - end Initial_Values_Okay; - - - function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is - use type Ada.Calendar.Time; - begin - return (Get_Time(LA) /= Alert_Time or - Get_Display(LA) /= Teletype or - LA.Level /= 1); - end Bad_Final_Values; - - -end C3900051; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900052.a b/gcc/testsuite/ada/acats/tests/c3/c3900052.a deleted file mode 100644 index 11d26db4a2d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900052.a +++ /dev/null @@ -1,138 +0,0 @@ --- C3900052.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 C3900053.AM. --- --- TEST DESCRIPTION: --- See C3900053.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- C3900050.A --- C3900051.A --- => C3900052.A --- C3900053.AM --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with C3900051; -- Extended alert system abstraction. -package C3900052 is -- Further extended alert system abstraction. - - - -- Declarations used by component Action_Officer; - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - type Medium_Alert_Type is new C3900051.Low_Alert_Type - with private; -- Private extension of - -- private extension. - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - - -- The following functions are needed to verify the values of the - -- extension's private components. - - function Initial_Values_Okay (MA : in Medium_Alert_Type) - return Boolean; -- Override parent's - -- primitive subprog. - - function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's - return Boolean; -- primitive subprog. - -private - - type Medium_Alert_Type is new C3900051.Low_Alert_Type with record - Action_Officer : Person_Enum := Nobody; - end record; - -end C3900052; - - - --==================================================================-- - - -with C3900050; -- Basic alert abstraction. -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package body C3900052 is -- Further extended alert system abstraction. - - use C3900050; -- Enumeration values directly visible. - use C3900051; -- Extended alert system abstraction. - - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - - procedure Handle (MA : in out Medium_Alert_Type) is - begin - Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). - Set_Level (MA, 2); -- Call inherited operation. - Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. - Set_Display (MA, Console); -- Call inherited operation. - Display (MA); -- Call doubly inherited operation. - end Handle; - - - function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is - begin - -- Call parent's operation (type conversion). - return (Initial_Values_Okay (Low_Alert_Type (MA)) and - MA.Action_Officer = Nobody); - end Initial_Values_Okay; - - - function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is - use type Ada.Calendar.Time; - begin - return (Get_Time(MA) /= Alert_Time or - Get_Display(MA) /= Console or - Get_Level(MA) /= 2 or - MA.Action_Officer /= Duty_Officer); - end Bad_Final_Values; - - -end C3900052; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900060.a b/gcc/testsuite/ada/acats/tests/c3/c3900060.a deleted file mode 100644 index b77219c5758..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900060.a +++ /dev/null @@ -1,159 +0,0 @@ --- C3900060.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 C3900063.AM. --- --- TEST DESCRIPTION: --- See C3900063.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- => C3900060.A --- C3900061.A --- C3900062.A --- C3900063.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package C3900060 is -- Alert system abstraction. - - - -- Declarations used by component Arrival_Time. - - Default_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1901, 1, 1); - Alert_Time : constant Ada.Calendar.Time := - Ada.Calendar.Time_Of (1991, 6, 15); - - - -- Declarations used by component Display_On and procedure Display. - - type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); - type Display_Counters is array (Device_Enum) of Natural; - - Display_Count_For : Display_Counters := (others => 0); - - - - type Alert_Type is tagged private; -- Root tagged type. - - procedure Set_Display (A : in out Alert_Type; -- To be inherited by - D : in Device_Enum); -- all derivatives. - - procedure Display (A : in Alert_Type); -- To be inherited by - -- all derivatives. - - procedure Handle (A : in out Alert_Type); -- To be overridden by - -- all derivatives. - - - -- The following functions are needed to verify the values of the - -- root tagged type's private components. - - function Get_Time (A: Alert_Type) return Ada.Calendar.Time; - - function Get_Display (A: Alert_Type) return Device_Enum; - - function Initial_Values_Okay (A : in Alert_Type) - return Boolean; - - function Bad_Final_Values (A : in Alert_Type) - return Boolean; - -private - - type Alert_Type is tagged record -- Root tagged type. - Arrival_Time : Ada.Calendar.Time := Default_Time; - Display_On : Device_Enum := Null_Device; - end record; - - -end C3900060; - - - --==================================================================-- - - -package body C3900060 is - - - procedure Set_Display (A : in out Alert_Type; - D : in Device_Enum) is - begin - A.Display_On := D; - end Set_Display; - - - procedure Display (A : in Alert_Type) is - begin - Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; - end Display; - - - procedure Handle (A : in out Alert_Type) is - begin - A.Arrival_Time := Alert_Time; - Display (A); - end Handle; - - - function Get_Time (A: Alert_Type) return Ada.Calendar.Time is - begin - return A.Arrival_Time; - end Get_Time; - - - function Get_Display (A: Alert_Type) return Device_Enum is - begin - return A.Display_On; - end Get_Display; - - - function Initial_Values_Okay (A : in Alert_Type) return Boolean is - begin - return (A = (Arrival_Time => Default_Time, -- Check "=" operator - Display_On => Null_Device)); -- availability. - end Initial_Values_Okay; -- Aggregate with - -- named associations. - - function Bad_Final_Values (A : in Alert_Type) return Boolean is - begin - return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator - -- availability. - end Bad_Final_Values; -- Aggregate with - -- positional assoc. - -end C3900060; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900061.a b/gcc/testsuite/ada/acats/tests/c3/c3900061.a deleted file mode 100644 index f776dcdb8ac..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900061.a +++ /dev/null @@ -1,138 +0,0 @@ --- C3900061.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 C3900063.AM. --- --- TEST DESCRIPTION: --- See C3900063.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- C3900060.A --- => C3900061.A --- C3900062.A --- C3900063.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with C3900060; -- Alert system abstraction. -package C3900061 is -- Extended alert abstraction. - - - type Low_Alert_Type is new C3900060.Alert_Type - with private; -- Private extension of - -- root tagged type. - - -- Inherits procedure Display from Alert_Type. - - procedure Handle (LA : in out Low_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by - L : in Integer); -- all derivatives. - - - -- The following functions are needed to verify the values of the - -- extension's private components. - - function Get_Level (LA: Low_Alert_Type) return Integer; - - function Initial_Values_Okay (LA : in Low_Alert_Type) - return Boolean; -- Override parent's - -- primitive subprog. - - function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's - return Boolean; -- primitive subprog. - - -private - - type Low_Alert_Type is new C3900060.Alert_Type with record - Level : Integer := 0; - end record; - -end C3900061; - - - --==================================================================-- - - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package body C3900061 is - - use C3900060; -- Alert system abstraction. - - - procedure Set_Level (LA : in out Low_Alert_Type; - L : in Integer) is - begin - LA.Level := L; - end Set_Level; - - - procedure Handle (LA : in out Low_Alert_Type) is - begin - Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). - Set_Level (LA, 1); -- Call newly declared operation. - Set_Display (Alert_Type(LA), - Teletype); -- Call parent's operation (type conversion). - Display (LA); -- Call inherited operation. - end Handle; - - - function Get_Level (LA: Low_Alert_Type) return Integer is - begin - return LA.Level; - end Get_Level; - - - function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is - begin - -- Call parent's operation (type conversion). - return (Initial_Values_Okay (Alert_Type (LA)) and - LA.Level = 0); - end Initial_Values_Okay; - - - function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is - use type Ada.Calendar.Time; - begin - return (Get_Time(LA) /= Alert_Time or - Get_Display(LA) /= Teletype or - LA.Level /= 1); - end Bad_Final_Values; - - -end C3900061; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900062.a b/gcc/testsuite/ada/acats/tests/c3/c3900062.a deleted file mode 100644 index 87a1cd5a340..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3900062.a +++ /dev/null @@ -1,137 +0,0 @@ --- C3900062.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 C3900063.AM. --- --- TEST DESCRIPTION: --- See C3900063.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- C3900060.A --- C3900061.A --- => C3900062.A --- C3900063.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate --- for Ada.Calendar. --- ---! - -with C3900061; -- Extended alert system abstraction. -package C3900062 is -- Further extended alert system abstraction. - - - -- Declarations used by component Action_Officer; - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - type Medium_Alert_Type is new C3900061.Low_Alert_Type - with record -- Record extension of - Action_Officer : Person_Enum := Nobody; -- private extension. - end record; - - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - - -- The following functions are needed to verify the values of the - -- extension's private components. - - function Initial_Values_Okay (MA : in Medium_Alert_Type) - return Boolean; -- Override parent's - -- primitive subprog. - - function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's - return Boolean; -- primitive subprog. - - -end C3900062; - - - --==================================================================-- - - -with C3900060; -- Basic alert abstraction. - -with Ada.Calendar; -pragma Elaborate (Ada.Calendar); - -package body C3900062 is - - use C3900060; -- Enumeration values directly visible. - use C3900061; -- Extended alert system abstraction. - - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - - procedure Handle (MA : in out Medium_Alert_Type) is - begin - Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). - Set_Level (MA, 2); -- Call inherited operation. - Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. - Set_Display (MA, Console); -- Call inherited operation. - Display (MA); -- Call doubly inherited operation. - end Handle; - - - function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is - begin - -- Call parent's operation (type conversion). - return (Initial_Values_Okay (Low_Alert_Type (MA)) and - MA.Action_Officer = Nobody); - end Initial_Values_Okay; - - - function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is - use type Ada.Calendar.Time; - begin - return (Get_Time(MA) /= Alert_Time or - Get_Display(MA) /= Console or - Get_Level(MA) /= 2 or - MA.Action_Officer /= Duty_Officer); - end Bad_Final_Values; - - -end C3900062; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc/testsuite/ada/acats/tests/c3/c390007.a deleted file mode 100644 index 46f59f66c56..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390007.a +++ /dev/null @@ -1,374 +0,0 @@ --- C390007.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 tag of an object of a tagged type is preserved by --- type conversion and parameter passing. --- --- TEST DESCRIPTION: --- The fact that the tag of an object is not changed is verified by --- making dispatching calls to primitive operations, and confirming that --- the proper body is executed. Objects of both specific and class-wide --- types are checked. --- --- The dispatching calls are made in two contexts. The first is a --- straightforward dispatching call made from within a class-wide --- operation. The second is a redispatch from within a primitive --- operation. --- --- For the parameter passing case, the initial class-wide and specific --- objects are passed directly in calls to the class-wide and primitive --- operations. The redispatch is accomplished by initializing a local --- class-wide object in the primitive operation to the value of the --- formal parameter, and using the local object as the actual in the --- (re)dispatching call. --- --- For the type conversion case, the initial class-wide object is assigned --- a view conversion of an object of a specific type: --- --- type T is tagged ... --- type DT is new T with ... --- --- A : DT; --- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT. --- --- The class-wide object is then passed directly in calls to the --- class-wide and primitive operations. For the initial object of a --- specific type, however, a view conversion of the object is passed, --- forcing a non-dispatching call in the primitive operation case. Within --- the primitive operation, a view conversion of the formal parameter to --- a class-wide type is then used to force a (re)dispatching call. --- --- For the type conversion and parameter passing case, a combining of --- view conversion and parameter passing of initial specific objects are --- called directly to the class-wide and primitive operations. --- --- --- CHANGE HISTORY: --- 28 Jun 95 SAIC Initial prerelease version. --- 23 Apr 96 SAIC Added use C390007_0 in the main. --- ---! - -package C390007_0 is - - type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, - Derived_Outer, Derived_Inner); - - type Root_Type is abstract tagged null record; - - procedure Outer_Proc (X : in out Root_Type) is abstract; - procedure Inner_Proc (X : in out Root_Type) is abstract; - - procedure ClassWide_Proc (X : in out Root_Type'Class); - -end C390007_0; - - - --==================================================================-- - - -package body C390007_0 is - - procedure ClassWide_Proc (X : in out Root_Type'Class) is - begin - Inner_Proc (X); - end ClassWide_Proc; - -end C390007_0; - - - --==================================================================-- - - -package C390007_0.C390007_1 is - - type Param_Parent_Type is new Root_Type with record - Last_Call : Call_ID_Kind := None; - end record; - - procedure Outer_Proc (X : in out Param_Parent_Type); - procedure Inner_Proc (X : in out Param_Parent_Type); - -end C390007_0.C390007_1; - - - --==================================================================-- - - -package body C390007_0.C390007_1 is - - procedure Outer_Proc (X : in out Param_Parent_Type) is - begin - X.Last_Call := Parent_Outer; - end Outer_Proc; - - procedure Inner_Proc (X : in out Param_Parent_Type) is - begin - X.Last_Call := Parent_Inner; - end Inner_Proc; - -end C390007_0.C390007_1; - - - --==================================================================-- - - -package C390007_0.C390007_1.C390007_2 is - - type Param_Derived_Type is new Param_Parent_Type with null record; - - procedure Outer_Proc (X : in out Param_Derived_Type); - procedure Inner_Proc (X : in out Param_Derived_Type); - -end C390007_0.C390007_1.C390007_2; - - - --==================================================================-- - - -package body C390007_0.C390007_1.C390007_2 is - - procedure Outer_Proc (X : in out Param_Derived_Type) is - Y : Root_Type'Class := X; - begin - Inner_Proc (Y); -- Redispatch. - Root_Type'Class (X) := Y; - end Outer_Proc; - - procedure Inner_Proc (X : in out Param_Derived_Type) is - begin - X.Last_Call := Derived_Inner; - end Inner_Proc; - -end C390007_0.C390007_1.C390007_2; - - - --==================================================================-- - - -package C390007_0.C390007_3 is - - type Convert_Parent_Type is new Root_Type with record - First_Call : Call_ID_Kind := None; - Second_Call : Call_ID_Kind := None; - end record; - - procedure Outer_Proc (X : in out Convert_Parent_Type); - procedure Inner_Proc (X : in out Convert_Parent_Type); - -end C390007_0.C390007_3; - - - --==================================================================-- - - -package body C390007_0.C390007_3 is - - procedure Outer_Proc (X : in out Convert_Parent_Type) is - begin - X.First_Call := Parent_Outer; - Inner_Proc (Root_Type'Class(X)); -- Redispatch. - end Outer_Proc; - - procedure Inner_Proc (X : in out Convert_Parent_Type) is - begin - X.Second_Call := Parent_Inner; - end Inner_Proc; - -end C390007_0.C390007_3; - - - --==================================================================-- - - -package C390007_0.C390007_3.C390007_4 is - - type Convert_Derived_Type is new Convert_Parent_Type with null record; - - procedure Outer_Proc (X : in out Convert_Derived_Type); - procedure Inner_Proc (X : in out Convert_Derived_Type); - -end C390007_0.C390007_3.C390007_4; - - - --==================================================================-- - - -package body C390007_0.C390007_3.C390007_4 is - - procedure Outer_Proc (X : in out Convert_Derived_Type) is - begin - X.First_Call := Derived_Outer; - Inner_Proc (Root_Type'Class(X)); -- Redispatch. - end Outer_Proc; - - procedure Inner_Proc (X : in out Convert_Derived_Type) is - begin - X.Second_Call := Derived_Inner; - end Inner_Proc; - -end C390007_0.C390007_3.C390007_4; - - - --==================================================================-- - - -with C390007_0.C390007_1.C390007_2; -with C390007_0.C390007_3.C390007_4; -use C390007_0; - -with Report; -procedure C390007 is -begin - Report.Test ("C390007", "Check that the tag of an object of a tagged " & - "type is preserved by type conversion and parameter passing"); - - - -- - -- Check that tags are preserved by parameter passing: - -- - - Parameter_Passing_Subtest: - declare - Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; - Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; - - ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A; - ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B; - - use C390007_0.C390007_1; - use C390007_0.C390007_1.C390007_2; - begin - - Outer_Proc (Specific_A); - if Specific_A.Last_Call /= Derived_Inner then - Report.Failed ("Parameter passing: tag not preserved in call to " & - "primitive operation with specific operand"); - end if; - - C390007_0.ClassWide_Proc (Specific_B); - if Specific_B.Last_Call /= Derived_Inner then - Report.Failed ("Parameter passing: tag not preserved in call to " & - "class-wide operation with specific operand"); - end if; - - Outer_Proc (ClassWide_A); - if ClassWide_A.Last_Call /= Derived_Inner then - Report.Failed ("Parameter passing: tag not preserved in call to " & - "primitive operation with class-wide operand"); - end if; - - C390007_0.ClassWide_Proc (ClassWide_B); - if ClassWide_B.Last_Call /= Derived_Inner then - Report.Failed ("Parameter passing: tag not preserved in call to " & - "class-wide operation with class-wide operand"); - end if; - - end Parameter_Passing_Subtest; - - - -- - -- Check that tags are preserved by type conversion: - -- - - Type_Conversion_Subtest: - declare - Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; - Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; - - ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class := - C390007_0.C390007_3.Convert_Parent_Type(Specific_A); - ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class := - C390007_0.C390007_3.Convert_Parent_Type(Specific_B); - - use C390007_0.C390007_3; - use C390007_0.C390007_3.C390007_4; - begin - - Outer_Proc (Convert_Parent_Type(Specific_A)); - if (Specific_A.First_Call /= Parent_Outer) or - (Specific_A.Second_Call /= Derived_Inner) - then - Report.Failed ("Type conversion: tag not preserved in call to " & - "primitive operation with specific operand"); - end if; - - Outer_Proc (ClassWide_A); - if (ClassWide_A.First_Call /= Derived_Outer) or - (ClassWide_A.Second_Call /= Derived_Inner) - then - Report.Failed ("Type conversion: tag not preserved in call to " & - "primitive operation with class-wide operand"); - end if; - - C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B)); - if (Specific_B.Second_Call /= Derived_Inner) then - Report.Failed ("Type conversion: tag not preserved in call to " & - "class-wide operation with specific operand"); - end if; - - C390007_0.ClassWide_Proc (ClassWide_B); - if (ClassWide_A.Second_Call /= Derived_Inner) then - Report.Failed ("Type conversion: tag not preserved in call to " & - "class-wide operation with class-wide operand"); - end if; - - end Type_Conversion_Subtest; - - - -- - -- Check that tags are preserved by type conversion and parameter passing: - -- - - Type_Conversion_And_Parameter_Passing_Subtest: - declare - Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; - Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; - - use C390007_0.C390007_1; - use C390007_0.C390007_1.C390007_2; - begin - - Outer_Proc (Param_Parent_Type (Specific_A)); - if Specific_A.Last_Call /= Parent_Outer then - Report.Failed ("Type conversion and parameter passing: tag not " & - "preserved in call to primitive operation with " & - "specific operand"); - end if; - - C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B)); - if Specific_B.Last_Call /= Derived_Inner then - Report.Failed ("Type conversion and parameter passing: tag not " & - "preserved in call to class-wide operation with " & - "specific operand"); - end if; - - end Type_Conversion_And_Parameter_Passing_Subtest; - - - Report.Result; - -end C390007; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390010.a b/gcc/testsuite/ada/acats/tests/c3/c390010.a deleted file mode 100644 index 1590e5027ab..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390010.a +++ /dev/null @@ -1,216 +0,0 @@ --- C390010.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 if S is a subtype of a tagged type T, and if S is --- constrained, then the allowable values of S'Class are only those --- that, when converted to T, belong to S. --- --- TEST DESCRIPTION: --- This test defines a small tagged hierarchy of discriminated tagged --- records, and constrained subtypes of those tagged record types. --- It then uses access to the classwide of the constrained subtype --- to check the objective. --- --- --- CHANGE HISTORY: --- 09 APR 96 SAIC Initial version --- 03 NOV 96 SAIC Revised for 2.1 release --- 31 DEC 97 EDS Restored use of intermediate access variable --- to eliminate raising of Program_Error --- 13 SEP 99 RLB Repaired previous change to avoid premature --- subtype check. --- 28 JUN 02 RLB Added pragma Elaborate_All (Report);. ---! - ------------------------------------------------------------------ C390010_0 - -with Report; pragma Elaborate_All (Report); -package C390010_0 is - - -- the defined subprograms will allow checking the placement of - -- constraint_checks - - -- define a discriminated tagged type, and a constrained subtype of - -- that type: - - type Discr_Tag_Record( Disc: Boolean ) is tagged record - FieldA : Character := 'A'; - case Disc is - when True => FieldB : Character := 'B'; - when False => FieldC : Character := 'C'; - end case; - end record; - - procedure Dispatching_Op( DTO : in out Discr_Tag_Record ); - - Authentic : Boolean := Report.Ident_Bool( True ); - - subtype True_Record is Discr_Tag_Record( Authentic ); - - - -- derive a type, "passing through" one discriminant, adding one - -- discriminant, and a constrained subtype of THAT type: - - type Derived_Record( Disc1, Disc2: Boolean ) is - new Discr_Tag_Record( Disc1 ) with record - FieldD : Character := 'D'; - case Disc2 is - when True => FieldE : Character := 'E'; - when False => FieldF : Character := 'F'; - end case; - end record; - - procedure Dispatching_Op( DR : in out Derived_Record ); - - subtype True_True_Derived is Derived_Record( Authentic, Authentic ); - - - -- now, define an access to classwide type, using the classwide from the - -- constrained subtype of the root (or parent) type: - - type Subtype_Parent_Class_Access is access all True_Record'Class; - type Parent_Class_Access is access all Discr_Tag_Record'Class; - - procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ); - -end C390010_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0 - -with Report; -with TCTouch; -package body C390010_0 is - - procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is - begin - TCTouch.Touch('1'); --------------------------------------------------- 1 - if DTO.Disc then - TCTouch.Touch(DTO.FieldB); ------------------------------------------ B - else - TCTouch.Touch(DTO.FieldC); ------------------------------------------ C - end if; - end Dispatching_Op; - - - procedure Dispatching_Op( DR : in out Derived_Record ) is - begin - TCTouch.Touch('2'); --------------------------------------------------- 2 - if DR.Disc1 then - TCTouch.Touch(DR.FieldB); ------------------------------------------ B - else - TCTouch.Touch(DR.FieldC); ------------------------------------------ C - end if; - if DR.Disc2 then - TCTouch.Touch(DR.FieldE); ------------------------------------------ E - else - TCTouch.Touch(DR.FieldF); ------------------------------------------ F - end if; - end Dispatching_Op; - - procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is - begin - - -- the following line is the "heart" of this test, objects of all types - -- covered by the classwide type will be passed to this subprogram in - -- the execution of the test. - if SPCA.Disc then - TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B - else - TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C - end if; - - Dispatching_Op( SPCA.all ); -- check that this dispatches correctly, - -- with discriminants correctly represented - - end PCW_Op; - -end C390010_0; - -------------------------------------------------------------------- C390010 - -with Report; -with TCTouch; -with C390010_0; -procedure C390010 is - - package CP renames C390010_0; - - procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is - begin - - -- the implicit conversion from the general access parameter to the more - -- constrained subtype access type in the following call should cause - -- Constraint_Error in the cases where the object is not correctly - -- constrained - - CP.PCW_Op( Item.all'Access ); - - exception - when Constraint_Error => TCTouch.Touch('X'); -------------------------- X - when others => Report.Failed("Unanticipated exception in Check_Element"); - - end Check_Element; - - An_Item : CP.Parent_Class_Access; - -begin -- Main test procedure. - - Report.Test ("C390010", "Check that if S is a subtype of a tagged type " & - "T, and if S is constrained, then the allowable " & - "values of S'Class are only those that, when " & - "converted to T, belong to S" ); - - An_Item := new CP.Discr_Tag_Record(True); - Check_Element( An_Item ); - TCTouch.Validate("B1B","Case 1"); - - An_Item := new CP.Discr_Tag_Record(False); - Check_Element( An_Item ); - TCTouch.Validate("X","Case 2"); - - An_Item := new CP.True_Record; - Check_Element( An_Item ); - TCTouch.Validate("B1B","Case 3"); - - An_Item := new CP.Derived_Record(False, False); - Check_Element( An_Item ); - TCTouch.Validate("X","Case 4"); - - An_Item := new CP.Derived_Record(False, True); - Check_Element( An_Item ); - TCTouch.Validate("X","Case 5"); - - An_Item := new CP.Derived_Record(True, False); - Check_Element( An_Item ); - TCTouch.Validate("B2BF","Case 6"); - - An_Item := new CP.True_True_Derived; - Check_Element( An_Item ); - TCTouch.Validate("B2BE","Case 7"); - - Report.Result; - -end C390010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390011.a b/gcc/testsuite/ada/acats/tests/c3/c390011.a deleted file mode 100644 index 74cf0eb0468..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390011.a +++ /dev/null @@ -1,250 +0,0 @@ --- C390011.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 tagged types declared within generic package declarations --- generate distinct tags for each instance of the generic. --- --- TEST DESCRIPTION: --- This test defines a very simple generic package (with the expectation --- that it should be easily be shared), and a few instances of that --- package. In true user-like fashion, two of the instances are identical --- (to wit: IIO is new Integer_IO(Integer)). The tags generated for each --- of them are placed into a list. The last action of the test is to --- check that everything in the list is unique. --- --- Almost as an aside, this test defines functions that return T'Base and --- T'Class, and then exercises these functions. --- --- (JPR) persistent objects really need a function like: --- function Get_Object return T'class; --- --- --- CHANGE HISTORY: --- 20 OCT 95 SAIC Initial version --- 23 APR 96 SAIC Commentary Corrections 2.1 --- ---! - ------------------------------------------------------------------ C390011_0 - -with Ada.Tags; -package C390011_0 is - - procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String ); - - procedure Check_List_For_Duplicates; - -end C390011_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C390011_0 is - - use type Ada.Tags.Tag; - type SP is access String; - - type List_Item; - type List_P is access List_Item; - type List_Item is record - The_Tag : Ada.Tags.Tag; - Exp_Name : SP; - Ext_Tag : SP; - Next : List_P; - end record; - - The_List : List_P; - - procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is - begin -- prepend the tag information to the list - The_List := new List_Item'( The_Tag => T, - Exp_Name => new String'(X_Name), - Ext_Tag => new String'(X_Tag), - Next => The_List ); - end Add_Tag_To_List; - - procedure Check_List_For_Duplicates is - Finger : List_P; - Thumb : List_P := The_List; - begin -- - while Thumb /= null loop - Finger := Thumb.Next; - while Finger /= null loop - -- Check that the tag is unique - if Finger.The_Tag = Thumb.The_Tag then - Report.Failed("Duplicate Tag"); - end if; - - -- Check that the Expanded name is unique - if Finger.Exp_Name.all = Thumb.Exp_Name.all then - Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats"); - end if; - - -- Check that the External Tag is unique - - if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then - Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats"); - end if; - Finger := Finger.Next; - end loop; - Thumb := Thumb.Next; - end loop; - end Check_List_For_Duplicates; - -begin - -- some things I just don't trust... - if The_List /= null then - Report.Failed("Implicit default for The_List not null"); - end if; -end C390011_0; - ------------------------------------------------------------------ C390011_1 - -generic - type Index is (<>); - type Item is private; -package C390011_1 is - - type List is array(Index range <>) of Item; - type ListP is access all List; - - type Table is tagged record - Data: ListP; - end record; - - function Sort( T: in Table'Class ) return Table'Class; - - function Stable_Table return Table'Class; - - function Table_End( T: Table ) return Index'Base; - -end C390011_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C390011_1 is - - -- In a user program this package would DO something - - function Sort( T: in Table'Class ) return Table'Class is - begin - return T; - end Sort; - - Empty : Table'Class := Table'( Data => null ); - - function Stable_Table return Table'Class is - begin - return Empty; - end Stable_Table; - - function Table_End( T: Table ) return Index'Base is - begin - return Index'Base( T.Data.all'Last ); - end Table_End; - -end C390011_1; - ------------------------------------------------------------------ C390011_2 - -with C390011_1; -package C390011_2 is new C390011_1( Index => Character, Item => Float ); - ------------------------------------------------------------------ C390011_3 - -with C390011_1; -package C390011_3 is new C390011_1( Index => Character, Item => Float ); - ------------------------------------------------------------------ C390011_4 - -with C390011_1; -package C390011_4 is new C390011_1( Index => Integer, Item => Character ); - ------------------------------------------------------------------ C390011_5 - -with C390011_3; -with C390011_4; -package C390011_5 is - - type Table_3 is new C390011_3.Table with record - Serial_Number : Integer; - end record; - - type Table_4 is new C390011_4.Table with record - Serial_Number : Integer; - end record; - -end C390011_5; - --- no package body C390011_5 required - -------------------------------------------------------------------- C390011 - -with Report; -with C390011_0; -with C390011_2; -with C390011_3; -with C390011_4; -with C390011_5; -with Ada.Tags; -procedure C390011 is - -begin -- Main test procedure. - - Report.Test ("C390011", "Check that tagged types declared within " & - "generic package declarations generate distinct " & - "tags for each instance of the generic. " & - "Check that 'Base may be used as a subtype mark. " & - "Check that T'Base and T'Class are allowed as " & - "the subtype mark in a function result" ); - - -- build the tag information table - C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag, - X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag), - X_Tag => Ada.Tags.External_Tag(C390011_2.Table'Tag) ); - - C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag, - X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag), - X_Tag => Ada.Tags.External_Tag(C390011_3.Table'Tag) ); - - C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag, - X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag), - X_Tag => Ada.Tags.External_Tag(C390011_4.Table'Tag) ); - - C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag, - X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag), - X_Tag => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) ); - - C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag, - X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag), - X_Tag => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) ); - - -- preform the check for distinct tags - C390011_0.Check_List_For_Duplicates; - - Report.Result; - -end C390011; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a010.a b/gcc/testsuite/ada/acats/tests/c3/c390a010.a deleted file mode 100644 index 18016de0999..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390a010.a +++ /dev/null @@ -1,127 +0,0 @@ --- C390A010.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 C390A011.AM. --- --- TEST DESCRIPTION: --- See C390A011.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- F390A00.A --- => C390A010.A --- C390A011.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with F390A00; -- Alert system abstraction. -package C390A010 is - - - type Low_Alert_Type is new F390A00.Alert_Type with record - Level : Integer := 0; -- Record extension of - end record; -- root tagged type. - - -- Inherits procedure Display from Alert_Type. - - procedure Handle (LA : in out Low_Alert_Type); -- Override parent's - -- primitive subprog. - - function Level_Of (LA : in Low_Alert_Type) -- To be inherited by - return Integer; -- all derivatives. - - - - -- Declarations required for component Action_Officer; - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - type Medium_Alert_Type is new Low_Alert_Type with record - Action_Officer : Person_Enum := Nobody; -- Record extension of - end record; -- record extension. - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - -end C390A010; - - - --==================================================================-- - - -package body C390A010 is - - use F390A00; -- Alert system abstraction. - - - function Level_Of (LA : in Low_Alert_Type) return Integer is - begin - return (LA.Level + 1); - end Level_Of; - - - procedure Handle (LA : in out Low_Alert_Type) is - begin - Handle (Alert_Type (LA)); -- Call parent's op (type conversion). - LA.Level := Level_Of (LA); -- Call newly declared operation. - LA.Display_On := Teletype; - Display (LA); -- Call inherited operation. - end Handle; - - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - - procedure Handle (MA : in out Medium_Alert_Type) is - begin - Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). - MA.Level := Level_Of (MA); -- Call inherited operation. - Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. - MA.Display_On := Console; - Display (MA); -- Call twice-inherited operation. - end Handle; - - -end C390A010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a020.a b/gcc/testsuite/ada/acats/tests/c3/c390a020.a deleted file mode 100644 index 29cd3ca9786..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390a020.a +++ /dev/null @@ -1,90 +0,0 @@ --- C390A020.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 C390A022.AM. --- --- TEST DESCRIPTION: --- See C390A022.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- F390A00.A --- => C390A020.A --- C390A021.A --- C390A022.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with F390A00; -- Alert system abstraction. -package C390A020 is - - - type Low_Alert_Type is new F390A00.Alert_Type with record - Level : Integer := 0; -- Record extension of - end record; -- root tagged type. - - -- Inherits procedure Display from Alert_Type. - - procedure Handle (LA : in out Low_Alert_Type); -- Override parent's - -- primitive subprog. - - function Level_Of (LA : in Low_Alert_Type) -- To be inherited by - return Integer; -- all derivatives. - - -end C390A020; - - - --==================================================================-- - - -package body C390A020 is - - use F390A00; -- Alert system abstraction. - - - function Level_Of (LA : in Low_Alert_Type) return Integer is - begin - return (LA.Level + 1); - end Level_Of; - - - procedure Handle (LA : in out Low_Alert_Type) is - begin - Handle (Alert_Type (LA)); -- Call parent's oper. (type conversion). - LA.Level := Level_Of (LA); -- Call newly declared operation. - LA.Display_On := Teletype; - Display (LA); -- Call inherited operation. - end Handle; - - -end C390A020; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a021.a b/gcc/testsuite/ada/acats/tests/c3/c390a021.a deleted file mode 100644 index 5d099f3704c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390a021.a +++ /dev/null @@ -1,133 +0,0 @@ --- C390A021.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 C390A022.AM. --- --- TEST DESCRIPTION: --- See C390A022.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- F390A00.A --- C390A020.A --- => C390A021.A --- C390A022.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with C390A020; -- Extended alert abstraction. -package C390A021 is - - - -- Declarations used by component Action_Officer; - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - type Medium_Alert_Type is new C390A020.Low_Alert_Type - with private; -- Private extension of - -- record extension. - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - - -- The following two functions are needed to verify the values of the - -- extension's private components. - - function Initial_Values_Okay (MA : in Medium_Alert_Type) - return Boolean; - - function Bad_Final_Values (MA : in Medium_Alert_Type) - return Boolean; - - -private - - type Medium_Alert_Type is new C390A020.Low_Alert_Type with record - Action_Officer : Person_Enum := Nobody; - end record; - -end C390A021; - - - --==================================================================-- - - -with F390A00; -- Basic alert abstraction. -use F390A00; -package body C390A021 is - - use C390A020; -- Extended alert abstraction. - - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - - procedure Handle (MA : in out Medium_Alert_Type) is - begin - Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). - MA.Level := Level_Of (MA); -- Call inherited operation. - Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. - MA.Display_On := Console; - Display (MA); -- Call twice-inherited operation. - end Handle; - - - function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is - begin - return (MA = (Arrival_Time => Default_Time, -- Check "=" operator - Display_On => Null_Device, -- availability. - Level => 0, -- Aggregate with - Action_Officer => Nobody)); -- named associations. - end Initial_Values_Okay; - - - function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is - begin - return (MA /= (Alert_Time, Console, -- Check "/=" operator - 2 , Duty_Officer)); -- availability. - end Bad_Final_Values; -- Aggregate with - -- positional assoc. - -end C390A021; diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a030.a b/gcc/testsuite/ada/acats/tests/c3/c390a030.a deleted file mode 100644 index 51554a49adc..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390a030.a +++ /dev/null @@ -1,188 +0,0 @@ --- C390A030.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 C390A031.AM. --- --- TEST DESCRIPTION: --- See C390A031.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- F390A00.A --- => C390A030.A --- C390A031.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. --- ---! - -with F390A00; -- Alert system abstraction. -package C390A030 is - - - type Low_Alert_Type is new F390A00.Alert_Type -- Private extension of - with private; -- root tagged type. - - -- Inherits procedure Display from Alert_Type. - - procedure Handle (LA : in out Low_Alert_Type); -- Override parent's - -- primitive subprog. - - function Level_Of (LA : in Low_Alert_Type) -- To be inherited by - return Integer; -- all derivatives. - - - -- The following two functions are needed to verify the values of the - -- extension's private components. - - function Initial_Values_Okay (LA : in Low_Alert_Type) - return Boolean; - - function Bad_Final_Values (LA : in Low_Alert_Type) - return Boolean; - - - -- Declarations used by private extension component. - - type Person_Enum is (Nobody, Duty_Officer, - Watch_Commander, Commanding_Officer); - - - type Medium_Alert_Type is new Low_Alert_Type -- Private extension of - with private; -- private extension. - - -- Inherits (inherited) procedure Display from Low_Alert_Type. - -- Inherits function Level_Of from Low_Alert_Type. - - procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's - -- primitive subprog. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum); - - - -- The following two functions are needed to verify the values of the - -- extension's private components. - - function Initial_Values_Okay (MA : in Medium_Alert_Type) - return Boolean; -- Override parent's - -- operation. - - function Bad_Final_Values (MA : in Medium_Alert_Type) - return Boolean; -- Override parent's - -- operation. - -private - - type Low_Alert_Type is new F390A00.Alert_Type with record - Level : Integer := 0; - end record; - - - type Medium_Alert_Type is new Low_Alert_Type with record - Action_Officer : Person_Enum := Nobody; - end record; - -end C390A030; - - - --==================================================================-- - - -package body C390A030 is - - use F390A00; -- Alert system abstraction. - - - function Level_Of (LA : in Low_Alert_Type) return Integer is - begin - return (LA.Level + 1); - end Level_Of; - - - procedure Handle (LA : in out Low_Alert_Type) is - begin - Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). - LA.Level := Level_Of (LA); -- Call newly declared operation. - LA.Display_On := Teletype; - Display (LA); -- Call inherited operation. - end Handle; - - - function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is - begin - return (LA = (Arrival_Time => Default_Time, -- Check "=" operator - Display_On => Null_Device, -- availability. - Level => 0)); -- Aggregate with - end Initial_Values_Okay; -- named associations. - - - function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is - begin - return (LA /= (Alert_Time, Teletype, 1)); -- Check "/=" operator - -- availability. - end Bad_Final_Values; -- Aggregate with - -- positional assoc. - - procedure Assign_Officer (MA : in out Medium_Alert_Type; - To : in Person_Enum) is - begin - MA.Action_Officer := To; - end Assign_Officer; - - - procedure Handle (MA : in out Medium_Alert_Type) is - begin - Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). - MA.Level := Level_Of (MA); -- Call inherited operation. - Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. - MA.Display_On := Console; - Display (MA); -- Call twice-inherited operation. - end Handle; - - - function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is - begin - -- Call parent's operation (type conversion). - return (Initial_Values_Okay (Low_Alert_Type (MA)) and - MA.Action_Officer = Nobody); - end Initial_Values_Okay; - - - function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is - begin - return not (MA = (Arrival_Time => Alert_Time, -- Check "=" operator - Display_On => Console, -- availability. - Level => 2, -- Aggregate with - Action_Officer => Duty_Officer));-- named associations. - end Bad_Final_Values; - - -end C390A030; diff --git a/gcc/testsuite/ada/acats/tests/c3/c391001.a b/gcc/testsuite/ada/acats/tests/c3/c391001.a deleted file mode 100644 index bca7525765f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c391001.a +++ /dev/null @@ -1,329 +0,0 @@ --- C391001.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 structures nesting discriminated records as --- components in record extension are correctly supported. Check --- for this using limited private structures. --- Check that record extensions inherit all the visible components --- of their ancestor types. --- Check that discriminants are correctly inherited. --- --- TEST DESCRIPTION: --- This test defines a textbook object, a serial number plaque. --- This object is used in each of several other structures modeled --- after those used in an existing antenna modeling software system. --- Record types discriminated and undiscriminated are nested to --- produce a layered design. Some parametrization is programmatic; --- some parametrization is data-driven. --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 19 Apr 95 SAIC Added "limited" to full type def of "Object" --- ---! - - package C391001_1 is - type Object is tagged limited private; - -- Constructor operation - procedure Create( The_Plaque : in out Object ); - -- Selector operations - function "="( Left_Plaque,Right_Plaque : Object ) return Boolean; - function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) - return Boolean; - function Serial_Number( A_Plaque : Object ) return Natural; - Unserialized : exception; -- Serial_Number called before Create - Reserialized : exception; -- Create called twice - private - type Object is tagged limited record - Serial_Number : Natural := 0; - end record; - end C391001_1; - - package body C391001_1 is - Counter : Natural := 0; - procedure Create( The_Plaque : in out Object ) is - begin - if The_Plaque.Serial_Number = 0 then - Counter := Counter +1; - The_Plaque.Serial_Number := Counter; - else - raise Reserialized; - end if; - end Create; - - function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is - begin - return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number) - and then -- two uninitialized plates are unequal - (Left_Plaque.Serial_Number /= 0); - end "="; - - function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) - return Boolean is - begin - return (Left_Plaque.Serial_Number = Right_Natural); - end TC_Match; - - function Serial_Number( A_Plaque : Object ) return Natural is - begin - if A_Plaque.Serial_Number = 0 then - raise Unserialized; - end if; - return A_Plaque.Serial_Number; - end Serial_Number; - end C391001_1; - - with C391001_1; - package C391001_2 is -- package Boards is - - package Plaque renames C391001_1; - - type Modes is (Receiving, Transmitting, Standby); - type Link(Mode: Modes := Standby) is record - case Mode is - when Receiving => TC_R : Integer := 100; - when Transmitting => TC_T : Integer := 200; - when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA - end case; - end record; - - type Data_Formats is (S_Band, KU_Band, UHF); - - - type Transceiver(Band: Data_Formats) is tagged limited record - ID : Plaque.Object; - The_Link: Link; - case Band is - when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA - when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA - when UHF => TC_UHF_Data : Integer := 3; - end case; - end record; - end C391001_2; - - with C391001_1; - with C391001_2; - package C391001_3 is -- package Modules - package Plaque renames C391001_1; - package Boards renames C391001_2; - use type Boards.Modes; - use type Boards.Data_Formats; - - type Command_Formats is ( Set_Compression_Code, - Set_Data_Rate, - Set_Power_State ); - - type Electronics_Module(EBand : Boards.Data_Formats; - The_Command_Format: Command_Formats) - is new Boards.Transceiver(EBand) with record - case The_Command_Format is - when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA - when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA - when Set_Power_State => TC_SPS : Integer := 30; -- TSA - end case; - end record; - end C391001_3; - - with Report; - with C391001_1; - with C391001_2; - with C391001_3; - procedure C391001 is - package Plaque renames C391001_1; - package Boards renames C391001_2; - package Modules renames C391001_3; - use type Boards.Modes; - use type Boards.Data_Formats; - use type Modules.Command_Formats; - - type Azimuth is range 0..359; - - type Ground_Antenna(The_Band : Boards.Data_Formats; - The_Command_Format: Modules.Command_Formats) is - record - ID : Plaque.Object; - Electronics : Modules.Electronics_Module(The_Band,The_Command_Format); - Pointing : Azimuth; - end record; - - type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; - The_Command : Modules.Command_Formats - := Modules.Set_Power_State) - is - record - ID : Plaque.Object; - Electronics : Modules.Electronics_Module(The_Band,The_Command); - end record; - - The_Ground_Antenna : Ground_Antenna (Boards.S_Band, - Modules.Set_Data_Rate); - The_Space_Antenna : Space_Antenna; - Space_Station_Antenna : Space_Antenna (Boards.S_Band, - Modules.Set_Compression_Code); - - - procedure Validate( Condition : Boolean; Message: String ) is - begin - if not Condition then - Report.Failed("Failed " & Message ); - end if; - end Validate; - - begin - Report.Test("C391001", "Check nested tagged discriminated " - & "record structures"); - - Plaque.Create( The_Ground_Antenna.ID ); -- 1 - Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 - Plaque.Create( The_Space_Antenna.ID ); -- 3 - Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 - Plaque.Create( Space_Station_Antenna.ID ); -- 5 - Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 - - The_Ground_Antenna.Pointing := 180; - Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" ); - Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate, - "TGA discr 2" ); - Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" ); - Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, - "TGA comp 2.discr 1" ); - Validate( The_Ground_Antenna.Electronics.The_Command_Format - = Modules.Set_Data_Rate, "TGA comp 2.discr 2" ); - Validate( The_Ground_Antenna.Electronics.TC_SDR = 20, - "TGA comp 2.1" ); - Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), - "TGA comp 2.inher.1" ); - Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby, - "TGA comp 2.inher.2.discr" ); - Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300, - "TGA comp 2.inher.2.1" ); - Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1, - "TGA comp 2.inher.3" ); - Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" ); - - Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1"); - Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State, - "TSA discr 2"); - Validate( Plaque.TC_Match(The_Space_Antenna.ID,3), - "TSA comp 1"); - Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band, - "TSA comp 2.discr 1"); - Validate( The_Space_Antenna.Electronics.The_Command_Format - = Modules.Set_Power_State, "TSA comp 2.discr 2"); - Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), - "TSA comp 2.inher.1"); - Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby, - "TSA comp 2.inher.2.discr"); - Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300, - "TSA comp 2.inher.2.1"); - Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2, - "TSA comp 2.inher.3"); - Validate( The_Space_Antenna.Electronics.TC_SPS = 30, - "TSA comp 2.1"); - - Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1"); - Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, - "SSA discr 2"); - Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5), - "SSA comp 1"); - Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band, - "SSA comp 2.discr 1"); - Validate( Space_Station_Antenna.Electronics.The_Command_Format - = Modules.Set_Compression_Code, "SSA comp 2.discr 2"); - Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), - "SSA comp 2.inher.1"); - Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby, - "SSA comp 2.inher.2.discr"); - Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300, - "SSA comp 2.inher.2.1"); - Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1, - "SSA comp 2.inher.3"); - Validate( Space_Station_Antenna.Electronics.TC_SCC = 10, - "SSA comp 2.1"); - - The_Ground_Antenna.Electronics.TC_SDR := 1001; - The_Ground_Antenna.Electronics.The_Link := -(Boards.Transmitting,2001); - The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001; - The_Ground_Antenna.Pointing := 41; - - The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010); - The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020; - The_Space_Antenna.Electronics.TC_SPS := 3030; - - Space_Station_Antenna.Electronics.The_Link - := The_Space_Antenna.Electronics.The_Link; - Space_Station_Antenna.Electronics.The_Link.TC_R := 111; - Space_Station_Antenna.Electronics.TC_S_Band_Data := 222; - Space_Station_Antenna.Electronics.TC_SCC := 333; - - ---------------------------------------------------------------------- - begin -- should fail discriminant check - The_Ground_Antenna.Electronics.TC_SCC := 909; - Report.Failed("Discriminant check, no exception"); - exception - when Constraint_Error => null; - when others => - Report.Failed("Discriminant check, wrong exception"); - end; - - Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001, - "assigned value 1"); - Validate( The_Ground_Antenna.Electronics.The_Link.Mode - = Boards.Transmitting, - "assigned value 2.1"); - Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001, - "assigned value 2.2"); - Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001, - "assigned value 3"); - Validate( The_Ground_Antenna.Pointing = 41, - "assigned value 4"); - - Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving, - "assigned value 5.1"); - Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010, - "assigned value 5.2"); - Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020, - "assigned value 6"); - Validate( The_Space_Antenna.Electronics.TC_SPS = 3030, - "assigned value 7"); - - Validate( Space_Station_Antenna.Electronics.The_Link.Mode - = Boards.Receiving, - "assigned value 8.1"); - Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111, - "assigned value 8.2"); - Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222, - "assigned value 9"); - Validate( Space_Station_Antenna.Electronics.TC_SCC = 333, - "assigned value 10"); - - Report.Result; - -end C391001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c391002.a b/gcc/testsuite/ada/acats/tests/c3/c391002.a deleted file mode 100644 index 77fbfb32816..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c391002.a +++ /dev/null @@ -1,493 +0,0 @@ --- C391002.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 structures nesting discriminated records as --- components in record extension are correctly supported. --- Check that record extensions inherit all the visible components --- of their ancestor types. --- Check that discriminants are correctly inherited. --- --- TEST DESCRIPTION: --- This test defines a simple class hierarchy, where the final --- derivations exercise the different possible "permissions" available --- to a designer. Extension aggregates for discriminated types are used --- to set values of these final types. The key difference between --- this test and C391001 is that the types are visible, and allow the --- creation of complex discriminated extension aggregates. Another --- layer of derivation is present to more robustly check that the --- inheritance is correctly supported. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Dec 94 SAIC Removed offending parenthesis in aggregate --- extensions, corrected typo: TC_MC SB TC_PC, --- corrected visibility errors for literals, --- added qualification for aggregate expressions --- used in extension aggregates, corrected parameter --- order in call to Communications.Creator --- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm --- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1 --- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates --- 11 APR 96 SAIC Updated documentation for 2.1 --- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association ---! - ------------------------------------------------------------------ C391002_1 - -package C391002_1 is - - type Object is tagged private; - - -- Constructor operation - procedure Create( The_Plaque : in out Object ); - - -- Selector operations - function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) - return Boolean; - - function Serial_Number( A_Plaque : Object ) return Natural; - - Unserialized : exception; -- Serial_Number called before Create - Reserialized : exception; -- Create called twice - -private - type Object is tagged record - Serial_Number : Natural := 0; - end record; -end C391002_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C391002_1 is - - Counter : Natural := 0; - - procedure Create( The_Plaque : in out Object ) is - begin - if The_Plaque.Serial_Number = 0 then - Counter := Counter +1; - The_Plaque.Serial_Number := Counter; - else - raise Reserialized; - end if; - end Create; - - function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) - return Boolean is - begin - return (Left_Plaque.Serial_Number = Right_Natural); - end TC_Match; - - function Serial_Number( A_Plaque : Object ) return Natural is - begin - if A_Plaque.Serial_Number = 0 then - raise Unserialized; - end if; - return A_Plaque.Serial_Number; - end Serial_Number; -end C391002_1; - ------------------------------------------------------------------ C391002_2 - -with C391002_1; -package C391002_2 is -- package Boards is - - package Plaque renames C391002_1; - - type Modes is (Receiving, Transmitting, Standby); - type Link(Mode: Modes := Standby) is record - case Mode is - when Receiving => TC_R : Integer := 100; - when Transmitting => TC_T : Integer := 200; - when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA - end case; - end record; - - type Data_Formats is (S_Band, KU_Band, UHF); - - type Transceiver(Band: Data_Formats) is tagged record - ID : Plaque.Object; - The_Link: Link; - case Band is - when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet - when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet - when UHF => TC_UHF_Data : Integer := 3; -- Gossip - end case; - end record; -end C391002_2; - ------------------------------------------------------------------ C391002_3 - -with C391002_1; -with C391002_2; -package C391002_3 is -- package Modules - - package Plaque renames C391002_1; - package Boards renames C391002_2; - use type Boards.Modes; - use type Boards.Data_Formats; - - type Command_Formats is ( Set_Compression_Code, - Set_Data_Rate, - Set_Power_State ); - - type Electronics_Module(EBand : Boards.Data_Formats; - The_Command : Command_Formats) - is new Boards.Transceiver(EBand) with record - case The_Command is - when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip - when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet - when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet - end case; - end record; -end C391002_3; - ------------------------------------------------------------------ C391002_4 - -with C391002_3; -package C391002_4 is -- Communications - package Modules renames C391002_3; - - type Public_Comm is new Modules.Electronics_Module with - record - TC_VC : Integer; - end record; - - type Private_Comm is new Modules.Electronics_Module with private; - - type Mil_Comm is new Modules.Electronics_Module with private; - - procedure Creator( Plugs : in Modules.Electronics_Module; - Gives : out Mil_Comm); - - function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) - return Private_Comm; - - procedure Setup( It : in out Public_Comm; Value : in Integer ); - procedure Setup( It : in out Private_Comm; Value : in Integer ); - procedure Setup( It : in out Mil_Comm; Value : in Integer ); - - function Selector( It : Public_Comm ) return Integer; - function Selector( It : Private_Comm ) return Integer; - function Selector( It : Mil_Comm ) return Integer; - -private - type Private_Comm is new Modules.Electronics_Module with - record - TC_PC : Integer; - end record; - - type Mil_Comm is new Modules.Electronics_Module with - record - TC_MC : Integer; - end record; -end C391002_4; -- Communications - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -with TCTouch; -package body C391002_4 is -- Communications - - procedure Creator( Plugs : in Modules.Electronics_Module; - Gives : out Mil_Comm) is - begin - Gives := ( Plugs with TC_MC => -1 ); - end Creator; - - function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) - return Private_Comm is - begin - return ( Plugs with TC_PC => Key ); - end Creator; - - procedure Setup( It : in out Public_Comm; Value : in Integer ) is - begin - It.TC_VC := Value; - TCTouch.Assert( Value = 1, "Public_Comm"); - end Setup; - - procedure Setup( It : in out Private_Comm; Value : in Integer ) is - begin - It.TC_PC := Value; - TCTouch.Assert( Value = 2, "Private_Comm"); - end Setup; - - procedure Setup( It : in out Mil_Comm; Value : in Integer ) is - begin - It.TC_MC := Value; - TCTouch.Assert( Value = 3, "Private_Comm"); - end Setup; - - function Selector( It : Public_Comm ) return Integer is - begin - return It.TC_VC; - end Selector; - - function Selector( It : Private_Comm ) return Integer is - begin - return It.TC_PC; - end Selector; - - function Selector( It : Mil_Comm ) return Integer is - begin - return It.TC_MC; - end Selector; - -end C391002_4; -- Communications - -------------------------------------------------------------------- C391002 - -with Report; -with TCTouch; -with C391002_1; -with C391002_2; -with C391002_3; -with C391002_4; -procedure C391002 is - - package Plaque renames C391002_1; - package Boards renames C391002_2; - package Modules renames C391002_3; - package Communications renames C391002_4; - - procedure Assert( Condition: Boolean; Message: String ) - renames TCTouch.Assert; - - use type Boards.Modes; - use type Boards.Data_Formats; - use type Modules.Command_Formats; - - type Azimuth is range 0..359; - - type Ground_Antenna(The_Band : Boards.Data_Formats; - The_Command : Modules.Command_Formats) is - record - ID : Plaque.Object; - Electronics : Modules.Electronics_Module(The_Band,The_Command); - Pointing : Azimuth; - end record; - - type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; - The_Command : Modules.Command_Formats - := Modules.Set_Power_State) - is - record - ID : Plaque.Object; - Electronics : Modules.Electronics_Module(The_Band,The_Command); - end record; - - The_Ground_Antenna : Ground_Antenna (Boards.S_Band, - Modules.Set_Data_Rate); - The_Space_Antenna : Space_Antenna; - Space_Station_Antenna : Space_Antenna (Boards.UHF, - Modules.Set_Compression_Code); - - Gossip : Communications.Public_Comm (Boards.UHF, - Modules.Set_Compression_Code); - Usenet : Communications.Private_Comm (Boards.KU_Band, - Modules.Set_Data_Rate); - Milnet : Communications.Mil_Comm (Boards.S_Band, - Modules.Set_Power_State); - - -begin - - Report.Test("C391002", "Check nested tagged discriminated" - & " record structures"); - - Plaque.Create( The_Ground_Antenna.ID ); -- 1 - Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 - Plaque.Create( The_Space_Antenna.ID ); -- 3 - Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 - Plaque.Create( Space_Station_Antenna.ID ); -- 5 - Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 - - The_Ground_Antenna := ( The_Band => Boards.S_Band, - The_Command => Modules.Set_Data_Rate, - ID => The_Ground_Antenna.ID, - Electronics => - ( Boards.Transceiver'( - Band => Boards.S_Band, - ID => The_Ground_Antenna.Electronics.ID, - The_Link => ( Mode => Boards.Transmitting, - TC_T => 222 ), - TC_S_Band_Data => 8 ) - with EBand => Boards.S_Band, - The_Command => Modules.Set_Data_Rate, - TC_SDR => 11 ), - Pointing => 270 ); - - The_Space_Antenna := ( The_Band => Boards.S_Band, - The_Command => Modules.Set_Data_Rate, - ID => The_Space_Antenna.ID, - Electronics => - ( Boards.Transceiver'( - Band => Boards.S_Band, - ID => The_Space_Antenna.Electronics.ID, - The_Link => ( Mode => Boards.Transmitting, - TC_T => 456 ), - TC_S_Band_Data => 88 ) - with - EBand => Boards.S_Band, - The_Command => Modules.Set_Data_Rate, - TC_SDR => 42 - ) ); - - Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code, - Space_Station_Antenna.ID, - ( Boards.Transceiver'( - Boards.UHF, - Space_Station_Antenna.Electronics.ID, - ( Boards.Transmitting, 202 ), - 42 ) - with Boards.UHF, - Modules.Set_Compression_Code, - TC_SCC => 101 - ) ); - - Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" ); - Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate, - "TGA disc 2" ); - Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" ); - Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, - "TGA comp 2.disc 1" ); - Assert( The_Ground_Antenna.Electronics.The_Command - = Modules.Set_Data_Rate, - "TGA comp 2.disc 2" ); - Assert( The_Ground_Antenna.Electronics.TC_SDR = 11, - "TGA comp 2.1" ); - Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), - "TGA comp 2.inher.1" ); - Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, - "TGA comp 2.inher.2.disc" ); - Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222, - "TGA comp 2.inher.2.1" ); - Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8, - "TGA comp 2.inher.3" ); - Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" ); - - Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1"); - Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate, - "TSA disc 2"); - Assert( Plaque.TC_Match(The_Space_Antenna.ID,3), - "TSA comp 1"); - Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band, - "TSA comp 2.disc 1"); - Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate, - "TSA comp 2.disc 2"); - Assert( The_Space_Antenna.Electronics.TC_SDR = 42, - "TSA comp 2.1"); - Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), - "TSA comp 2.inher.1"); - Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, - "TSA comp 2.inher.2.disc"); - Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456, - "TSA comp 2.inher.2.1"); - Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88, - "TSA comp 2.inher.3"); - - Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1"); - Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, - "SSA disc 2"); - Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5), - "SSA comp 1"); - Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF, - "SSA comp 2.disc 1"); - Assert( Space_Station_Antenna.Electronics.The_Command - = Modules.Set_Compression_Code, - "SSA comp 2.disc 2"); - Assert( Space_Station_Antenna.Electronics.TC_SCC = 101, - "SSA comp 2.1"); - Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), - "SSA comp 2.inher.1"); - Assert( Space_Station_Antenna.Electronics.The_Link.Mode - = Boards.Transmitting, - "SSA comp 2.inher.2.disc"); - Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202, - "SSA comp 2.inher.2.1"); - Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42, - "SSA comp 2.inher.3"); - - - The_Space_Antenna := ( The_Band => Boards.S_Band, - The_Command => Modules.Set_Power_State, - ID => The_Space_Antenna.ID, - Electronics => - ( Boards.Transceiver'( - Band => Boards.S_Band, - ID => The_Space_Antenna.Electronics.ID, - The_Link => ( Mode => Boards.Transmitting, - TC_T => 1 ), - TC_S_Band_Data => 5 ) - with - EBand => Boards.S_Band, - The_Command => Modules.Set_Power_State, - TC_SPS => 101 - ) ); - - Communications.Creator( The_Space_Antenna.Electronics, Milnet ); - Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" ); - - Usenet := Communications.Creator( -2, - ( Boards.Transceiver'( - Band => Boards.KU_Band, - ID => The_Space_Antenna.Electronics.ID, - The_Link => ( Boards.Transmitting, TC_T => 101 ), - TC_KU_Band_Data => 395 ) - with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) ); - - Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" ); - - Gossip := ( - Modules.Electronics_Module'( - Boards.Transceiver'( - Band => Boards.UHF, - ID => The_Space_Antenna.Electronics.ID, - The_Link => ( Boards.Transmitting, TC_T => 101 ), - TC_UHF_Data => 395 ) - with - Boards.UHF, Modules.Set_Compression_Code, 66 ) - with - TC_VC => -3 ); - - Assert( Gossip.TC_VC = -3, "Gossip Aggregate" ); - - Communications.Setup( Gossip, 1 ); -- (Boards.UHF, - -- Modules.Set_Compression_Code) - Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band, - -- Modules.Set_Data_Rate) - Communications.Setup( Milnet, 3 ); -- (Boards.S_Band, - -- Modules.Set_Power_State) - - Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" ); - Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" ); - Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" ); - - Report.Result; - -end C391002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392002.a b/gcc/testsuite/ada/acats/tests/c3/c392002.a deleted file mode 100644 index 41493c22779..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392002.a +++ /dev/null @@ -1,349 +0,0 @@ --- C392002.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 use of a class-wide formal parameter allows for the --- proper dispatching of objects to the appropriate implementation of --- a primitive operation. Check this in the case where the root tagged --- type is defined in a generic package, and the type derived from it is --- defined in that same generic package. --- --- TEST DESCRIPTION: --- Declare a root tagged type, and some associated primitive operations. --- Extend the root type, and override one or more primitive operations, --- inheriting the other primitive operations from the root type. --- Derive from the extended type, again overriding some primitive --- operations and inheriting others (including some that the parent --- inherited). --- Define a subprogram with a class-wide parameter, inside of which is a --- call on a dispatching primitive operation. These primitive operations --- modify global variables (the class-wide parameter has mode IN). --- --- The following hierarchy of tagged types and primitive operations is --- utilized in this test: --- --- --- type Vehicle (root) --- | --- type Motorcycle --- | --- | Operations --- | Engine_Size --- | Catalytic_Converter --- | Emissions_Produced --- | --- type Automobile (extended from Motorcycle) --- | --- | Operations --- | (Engine_Size) (inherited) --- | Catalytic_Converter (overridden) --- | Emissions_Produced (overridden) --- | --- type Truck (extended from Automobile) --- | --- | Operations --- | (Engine_Size) (inherited twice - Motorcycle) --- | (Catalytic_Converter) (inherited - Automobile) --- | Emissions_Produced (overridden) --- --- --- In this test, we are concerned with the following selection of dispatching --- calls, accomplished with the use of a Vehicle'Class IN procedure --- parameter : --- --- \ Type --- Prim. Op \ Motorcycle Automobile Truck --- \------------------------------------------------ --- Engine_Size | X X X --- Catalytic_Converter | X X X --- Emissions_Produced | X X X --- --- --- --- The location of the declaration and derivation of the root and extended --- types will be varied over a series of tests. Locations of declaration --- and derivation for a particular test are marked with an asterisk (*). --- --- Root type: --- --- Declared in package. --- * Declared in generic package. --- --- Extended types: --- --- * Derived in parent location. --- Derived in a nested package. --- Derived in a nested subprogram. --- Derived in a nested generic package. --- Derived in a separate package. --- Derived in a separate visible child package. --- Derived in a separate private child package. --- --- Primitive Operations: --- --- * Procedures with same parameter profile. --- Procedures with different parameter profile. --- * Functions with same parameter profile. --- Functions with different parameter profile. --- * Mixture of Procedures and Functions. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 09 May 96 SAIC Made single-file for 2.1 --- ---! - -------------------------------------------------------------------- C392002_0 - --- Declare the root and extended types, along with their primitive --- operations in a generic package. - -generic - - type Cubic_Inches is range <>; - type Emission_Measure is digits <>; - Emissions_per_Engine_Cubic_Inch : Emission_Measure; - -package C392002_0 is -- package Vehicle_Simulation - - -- - -- Equipment types and their primitive operations. - -- - - -- Root type. - - type Vehicle is abstract tagged - record - Weight : Integer; - Wheels : Positive; - end record; - - -- Abstract operations of type Vehicle. - function Engine_Size (V : in Vehicle) return Cubic_Inches - is abstract; - function Catalytic_Converter (V : in Vehicle) return Boolean - is abstract; - function Emissions_Produced (V : in Vehicle) return Emission_Measure - is abstract; - - -- - - type Motorcycle is new Vehicle with - record - Size_Of_Engine : Cubic_Inches; - end record; - - -- Primitive operations of type Motorcycle. - function Engine_Size (V : in Motorcycle) return Cubic_Inches; - function Catalytic_Converter (V : in Motorcycle) return Boolean; - function Emissions_Produced (V : in Motorcycle) return Emission_Measure; - - -- - - type Automobile is new Motorcycle with - record - Passenger_Capacity : Integer; - end record; - - -- Function Engine_Size inherited from parent (Motorcycle). - -- Primitive operations (Overridden). - function Catalytic_Converter (V : in Automobile) return Boolean; - function Emissions_Produced (V : in Automobile) return Emission_Measure; - - -- - - type Truck is new Automobile with - record - Hauling_Capacity : Natural; - end record; - - -- Function Engine_Size inherited twice. - -- Function Catalytic_Converter inherited from parent (Automobile). - -- Primitive operation (Overridden). - function Emissions_Produced (V : in Truck) return Emission_Measure; - -end C392002_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body c392002_0 is - - -- - -- Primitive operations for Motorcycle. - -- - - function Engine_Size (V : in Motorcycle) return Cubic_Inches is - begin - return (V.Size_Of_Engine); - end Engine_Size; - - - function Catalytic_Converter (V : in Motorcycle) return Boolean is - begin - return (False); - end Catalytic_Converter; - - - function Emissions_Produced (V : in Motorcycle) return Emission_Measure is - begin - return 100.00; - end Emissions_Produced; - - -- - -- Overridden operations for Automobile type. - -- - - function Catalytic_Converter (V : in Automobile) return Boolean is - begin - return (True); - end Catalytic_Converter; - - - function Emissions_Produced (V : in Automobile) return Emission_Measure is - begin - return 200.00; - end Emissions_Produced; - - -- - -- Overridden operation for Truck type. - -- - - function Emissions_Produced (V : in Truck) return Emission_Measure is - begin - return 300.00; - end Emissions_Produced; - -end C392002_0; - ---------------------------------------------------------------------- C392002 - -with C392002_0; -- with Vehicle_Simulation; -with Report; - -procedure C392002 is - - type Decade is (c1970, c1980, c1990); - type Vehicle_Emissions is digits 6; - type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions; - subtype Engine_Size is Integer range 100 .. 1000; - - Five_Tons : constant Natural := 10000; - Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8; - Truck_Adjustment_Factor : constant Vehicle_Emissions := 1.2; - - - Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00, - c1980 => 8.00, - c1990 => 5.00); - - -- Instantiate generic package for 1970 simulation. - - package Sim_1970 is new C392002_0 - (Cubic_Inches => Engine_Size, - Emission_Measure => Vehicle_Emissions, - Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970)); - - - -- Declare and initialize vehicle objects. - - Cycle_1970 : Sim_1970.Motorcycle := (Weight => 400, - Wheels => 2, - Size_Of_Engine => 100); - - Auto_1970 : Sim_1970.Automobile := (2000, 4, 500, 5); - - Truck_1970 : Sim_1970.Truck := (Weight => 5000, - Wheels => 18, - Size_Of_Engine => 1000, - Passenger_Capacity => 2, - Hauling_Capacity => Five_Tons); - - -- Function Get_Engine_Size performs a dispatching call on a - -- primitive operation that has been defined for an ancestor type and - -- inherited by each type derived from the ancestor. - - function Get_Engine_Size (V : in Sim_1970.Vehicle'Class) - return Engine_Size is - begin - return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag. - end Get_Engine_Size; - - - -- Function Catalytic_Converter_Present performs a dispatching call on - -- a primitive operation that has been defined for an ancestor type, - -- overridden in the parent extended type, and inherited by the subsequent - -- extended type. - - function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class) - return Boolean is - begin - return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag. - end Catalytic_Converter_Present; - - - -- Function Air_Quality_Measure performs a dispatching call on - -- a primitive operation that has been defined for an ancestor type, and - -- overridden in each subsequent extended type. - - function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class) - return Vehicle_Emissions is - begin - return (Sim_1970.Emissions_Produced (V)); -- Dispatch according to tag. - end Air_Quality_Measure; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("C392002", "Check that the use of a class-wide parameter " - & "allows for proper dispatching where root type " - & "and extended types are declared in the same " - & "generic package" ); - - if (Get_Engine_Size (Cycle_1970) /= 100) or - (Get_Engine_Size (Auto_1970) /= 500) or - (Get_Engine_Size (Truck_1970) /= 1000) - then - Report.Failed ("Failed dispatch to Get_Engine_Size"); - end if; - - if Catalytic_Converter_Present (Cycle_1970) or - not Catalytic_Converter_Present (Auto_1970) or - not Catalytic_Converter_Present (Truck_1970) - then - Report.Failed ("Failed dispatch to Catalytic_Converter_Present"); - end if; - - if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or - (Air_Quality_Measure (Auto_1970) /= 200.00) or - (Air_Quality_Measure (Truck_1970) /= 300.00)) - then - Report.Failed ("Failed dispatch to Air_Quality_Measure"); - end if; - - Report.Result; - -end C392002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc/testsuite/ada/acats/tests/c3/c392003.a deleted file mode 100644 index d7c5be22867..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392003.a +++ /dev/null @@ -1,453 +0,0 @@ --- C392003.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 use of a class-wide formal parameter allows for the --- proper dispatching of objects to the appropriate implementation of --- a primitive operation. Check this where the root tagged type is --- defined in a package, and the extended type is defined in a nested --- package. --- --- TEST DESCRIPTION: --- Declare a root tagged type, and some associated primitive operations. --- Extend the root type, and override one or more primitive operations, --- inheriting the other primitive operations from the root type. --- Derive from the extended type, again overriding some primitive --- operations and inheriting others (including some that the parent --- inherited). --- Define a subprogram with a class-wide parameter, inside of which is a --- call on a dispatching primitive operation. These primitive operations --- modify global variables (the class-wide parameter has mode IN). --- --- --- --- The following hierarchy of tagged types and primitive operations is --- utilized in this test: --- --- type Bank_Account (root) --- | --- | Operations --- | Increment_Bank_Reserve --- | Assign_Representative --- | Increment_Counters --- | Open --- | --- type Savings_Account (extended from Bank_Account) --- | --- | Operations --- | (Increment_Bank_Reserve) (inherited) --- | Assign_Representative (overridden) --- | Increment_Counters (overridden) --- | Open (overridden) --- | --- type Preferred_Account (extended from Savings_Account) --- | --- | Operations --- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) --- | (Assign_Representative) (inherited - Savings_Acct.) --- | Increment_Counters (overridden) --- | Open (overridden) --- --- --- In this test, we are concerned with the following selection of dispatching --- calls, accomplished with the use of a Bank_Account'Class IN procedure --- parameter : --- --- \ Type --- Prim. Op \ Bank_Account Savings_Account Preferred_Account --- \------------------------------------------------ --- Increment_Bank_Reserve| X X --- Assign_Representative | X --- Increment_Counters | X X X --- --- --- --- The location of the declaration and derivation of the root and extended --- types will be varied over a series of tests. Locations of declaration --- and derivation for a particular test are marked with an asterisk (*). --- --- Root type: --- --- * Declared in package. --- Declared in generic package. --- --- Extended types: --- --- Derived in parent location. --- * Derived in a nested package. --- Derived in a nested subprogram. --- Derived in a nested generic package. --- Derived in a separate package. --- Derived in a separate visible child package. --- Derived in a separate private child package. --- --- Primitive Operations: --- --- * Procedures with same parameter profile. --- Procedures with different parameter profile. --- * Functions with same parameter profile. --- Functions with different parameter profile. --- * Mixture of Procedures and Functions. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - - with Report; - - procedure C392003 is - - -- - -- Types and subtypes. - -- - - type Dollar_Amount is new float; - type Interest_Rate is delta 0.001 range 0.000 .. 1.000; - type Account_Types is (Bank, Savings, Preferred, Total); - type Account_Counter is array (Account_Types) of integer; - type Account_Rep is (President, Manager, New_Account_Manager, Teller); - - -- - -- Constants. - -- - - Opening_Balance : constant Dollar_Amount := 100.00; - Current_Rate : constant Interest_Rate := 0.030; - Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00; - - -- - -- Global Variables - -- - - Bank_Reserve : Dollar_Amount := 0.00; - Daily_Representative : Account_Rep := New_Account_Manager; - Number_Of_Accounts : Account_Counter := (Bank => 0, - Savings => 0, - Preferred => 0, - Total => 0); - - -- Root tagged type and primitive operations declared in internal - -- package (Accounts). - -- Extended types (and primitive operations) derived in nested packages. - - --=================================================================-- - - package Accounts is - - -- - -- Root account type and primitive operations. - -- - - -- Root type. - - type Bank_Account is tagged - record - Balance : Dollar_Amount; - end record; - - -- Primitive operations of Bank_Account. - - function Increment_Bank_Reserve (Acct : in Bank_Account) - return Dollar_Amount; - function Assign_Representative (Acct : in Bank_Account) - return Account_Rep; - procedure Increment_Counters (Acct : in Bank_Account); - procedure Open (Acct : in out Bank_Account); - - --=================================================================-- - - package S_And_L is - - -- Declare extended type in a nested package. - - type Savings_Account is new Bank_Account with - record - Rate : Interest_Rate; - end record; - - -- Function Increment_Bank_Reserve inherited from - -- parent (Bank_Account). - - -- Primitive operations (Overridden). - function Assign_Representative (Acct : in Savings_Account) - return Account_Rep; - procedure Increment_Counters (Acct : in Savings_Account); - procedure Open (Acct : in out Savings_Account); - - - --=================================================================-- - - package Premium is - - -- Declare further extended type in a nested package. - - type Preferred_Account is new Savings_Account with - record - Minimum_Balance : Dollar_Amount; - end record; - - -- Function Increment_Bank_Reserve inherited twice. - -- Function Assign_Representative inherited from parent - -- (Savings_Account). - - -- Primitive operation (Overridden). - procedure Increment_Counters (Acct : in Preferred_Account); - procedure Open (Acct : in out Preferred_Account); - - -- Function used to verify Open operation for Preferred_Account - -- objects. - function Verify_Open (Acct : in Preferred_Account) return Boolean; - - end Premium; - - end S_And_L; - - end Accounts; - - --=================================================================-- - - package body Accounts is - - -- - -- Primitive operations for Bank_Account. - -- - - function Increment_Bank_Reserve (Acct : in Bank_Account) - return Dollar_Amount is - begin - return (Bank_Reserve + Acct.Balance); - end Increment_Bank_Reserve; - - function Assign_Representative (Acct : in Bank_Account) - return Account_Rep is - begin - return Account_Rep'(Teller); - end Assign_Representative; - - procedure Increment_Counters (Acct : in Bank_Account) is - begin - Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1; - Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; - end Increment_Counters; - - procedure Open (Acct : in out Bank_Account) is - begin - Acct.Balance := Opening_Balance; - end Open; - - --=================================================================-- - - package body S_And_L is - - -- - -- Overridden operations for Savings_Account type. - -- - - function Assign_Representative (Acct : in Savings_Account) - return Account_Rep is - begin - return (Manager); - end Assign_Representative; - - procedure Increment_Counters (Acct : in Savings_Account) is - begin - Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1; - Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; - end Increment_Counters; - - procedure Open (Acct : in out Savings_Account) is - begin - Open (Bank_Account(Acct)); - Acct.Rate := Current_Rate; - Acct.Balance := 2.0 * Opening_Balance; - end Open; - - --=================================================================-- - - package body Premium is - - -- - -- Overridden operations for Preferred_Account type. - -- - - procedure Increment_Counters (Acct : in Preferred_Account) is - begin - Number_Of_Accounts (Preferred) := - Number_Of_Accounts (Preferred) + 1; - Number_Of_Accounts (Total) := - Number_Of_Accounts (Total) + 1; - end Increment_Counters; - - procedure Open (Acct : in out Preferred_Account) is - begin - Open (Savings_Account(Acct)); - Acct.Minimum_Balance := Preferred_Minimum_Balance; - Acct.Balance := Acct.Minimum_Balance; - end Open; - - -- - -- Function used to verify Open operation for Preferred_Account - -- objects. - -- - - function Verify_Open (Acct : in Preferred_Account) - return Boolean is - begin - return (Acct.Balance = Preferred_Minimum_Balance and - Acct.Rate = Current_Rate and - Acct.Minimum_Balance = Preferred_Minimum_Balance); - end Verify_Open; - - end Premium; - - end S_And_L; - - end Accounts; - - --=================================================================-- - - -- Declare account objects. - - B_Account : Accounts.Bank_Account; - S_Account : Accounts.S_And_L.Savings_Account; - P_Account : Accounts.S_And_L.Premium.Preferred_Account; - - -- Procedures to operate on accounts. - -- Each uses a class-wide IN parameter, as well as a call to a - -- dispatching operation. - - -- Function Tabulate_Account performs a dispatching call on a primitive - -- operation that has been overridden for each of the extended types. - - procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is - begin - Accounts.Increment_Counters (Acct); -- Dispatch according to tag. - end Tabulate_Account; - - -- Function Accumulate_Reserve performs a dispatching call on a - -- primitive operation that has been defined for the root type and - -- inherited by each derived type. - - function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) - return Dollar_Amount is - begin - -- Dispatch according to tag. - return (Accounts.Increment_Bank_Reserve (Acct)); - end Accumulate_Reserve; - - -- Procedure Resolve_Dispute performs a dispatching call on a primitive - -- operation that has been defined in the root type, overridden in the - -- first derived extended type, and inherited by the subsequent extended - -- type. - - procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is - begin - -- Dispatch according to tag. - Daily_Representative := Accounts.Assign_Representative (Acct); - end Resolve_Dispute; - - --=================================================================-- - - begin -- Main test procedure. - - Report.Test ("C392003", "Check that the use of a class-wide parameter " & - "allows for proper dispatching where root type " & - "is declared in a nested package, and " & - "subsequent extended types are derived in " & - "further nested packages" ); - - Bank_Account_Subtest: - begin - Accounts.Open (B_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been defined for this specific type. - Bank_Reserve := Accumulate_Reserve (Acct => B_Account); - Tabulate_Account (B_Account); - - if (Bank_Reserve /= Opening_Balance) or - (Number_Of_Accounts (Bank) /= 1) or - (Number_Of_Accounts (Total) /= 1) - then - Report.Failed ("Failed in Bank_Account_Subtest"); - end if; - - end Bank_Account_Subtest; - - - Savings_Account_Subtest: - begin - Accounts.S_And_L.Open (Acct => S_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been overridden for this extended type. - Resolve_Dispute (Acct => S_Account); - Tabulate_Account (S_Account); - - if (Daily_Representative /= Manager) or - (Number_Of_Accounts (Savings) /= 1) or - (Number_Of_Accounts (Total) /= 2) - then - Report.Failed ("Failed in Savings_Account_Subtest"); - end if; - - end Savings_Account_Subtest; - - - - Preferred_Account_Subtest: - begin - Accounts.S_And_L.Premium.Open (P_Account); - - -- Verify that the correct implementation of Open (overridden) was - -- used for the Preferred_Account object. - if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then - Report.Failed ("Incorrect values for init. Preferred Acct object"); - end if; - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been twice inherited by this extended type. - Bank_Reserve := Accumulate_Reserve (Acct => P_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been overridden for this extended type (the - -- operation was overridden by its parent type as well). - Tabulate_Account (P_Account); - - if Bank_Reserve /= 1100.00 or - Number_Of_Accounts (Preferred) /= 1 or - Number_Of_Accounts (Total) /= 3 - then - Report.Failed ("Failed in Preferred_Account_Subtest"); - end if; - - end Preferred_Account_Subtest; - - Report.Result; - - end C392003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392004.a b/gcc/testsuite/ada/acats/tests/c3/c392004.a deleted file mode 100644 index 0851db1d287..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392004.a +++ /dev/null @@ -1,189 +0,0 @@ --- C392004.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 subprograms inherited from tagged derivations, which are --- subsequently redefined for the derived type, are available to the --- package defining the new class via view conversion. Check --- that operations performed on objects using view conversion do not --- affect the extended fields. Check that visible operations not masked --- by the deriving package remain available to the client, and do not --- affect the extended fields. --- --- TEST DESCRIPTION: --- This test declares a tagged type, with a constructor operation, --- derives a type from that tagged type, and declares a constructor --- operation which masks the inherited operation. It then tests --- that the correct constructor is called, and that the extended --- part of the derived type remains untouched as appropriate. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 04 Jan 94 SAIC Fixed objective typo, removed dead code. --- ---! - -with Report; - -package C392004_1 is - - type Vehicle is tagged private; - - procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ); - procedure Start ( The_Vehicle : in out Vehicle ); - -private - - type Vehicle is tagged record - Engine_On : Boolean; - end record; - -end C392004_1; - -package body C392004_1 is - procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is - begin - case TC_Flag is - when 1 => null; -- expected flag for this subprogram - when others => - Report.Failed ("Called Vehicle Create"); - end case; - The_Vehicle := (Engine_On => False); - end Create; - - procedure Start ( The_Vehicle : in out Vehicle ) is - begin - The_Vehicle.Engine_On := True; - end Start; - -end C392004_1; - ----------------------------------------------------------------------------- - -with C392004_1; -package C392004_2 is - - type Car is new C392004_1.Vehicle with record - Convertible : Boolean; - end record; - - -- masking definition - procedure Create( The_Car : out Car; TC_Flag : Natural ); - - type Limo is new Car with null record; - - procedure Create( The_Limo : out Limo; TC_Flag : Natural ); - -end C392004_2; - ----------------------------------------------------------------------------- - -with Report; -package body C392004_2 is - - procedure Create( The_Car : out Car; TC_Flag : Natural ) is - begin - case TC_Flag is - when 2 => null; -- expected flag for this subprogram - when others => Report.Failed ("Called Car Create"); - end case; - C392004_1.Create( C392004_1.Vehicle(The_Car), 1); - The_Car.Convertible := False; - end Create; - - procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is - begin - case TC_Flag is - when 3 => null; -- expected flag for this subprogram - when others => Report.Failed ("Called Limo Create"); - end case; - C392004_1.Create( C392004_1.Vehicle(The_Limo), 1); - The_Limo.Convertible := True; - end Create; - -end C392004_2; - ----------------------------------------------------------------------------- - -with Report; -with C392004_1; use C392004_1; -with C392004_2; use C392004_2; -procedure C392004 is - - My_Car : Car; - Your_Car : Limo; - - procedure TC_Assert( Is_True : Boolean; Message : String ) is - begin - if not Is_True then - Report.Failed (Message); - end if; - end TC_Assert; - -begin -- Main test procedure. - - Report.Test ("C392004", "Check subprogram inheritance & visibility " & - "for derived tagged types" ); - - My_Car.Convertible := False; - Create( Vehicle( My_Car ), 1 ); - TC_Assert( not My_Car.Convertible, "Altered descendent component 1"); - - Create( Your_Car, 3 ); - TC_Assert( Your_Car.Convertible, "Did not set inherited component 2"); - - My_Car.Convertible := True; - Create( Vehicle( My_Car ), 1 ); - TC_Assert( My_Car.Convertible, "Altered descendent component 3"); - - Create( My_Car, 2 ); - TC_Assert( not My_Car.Convertible, "Did not set extending component 4"); - - My_Car.Convertible := False; - Start( Vehicle( My_Car ) ); - TC_Assert( not My_Car.Convertible , "Altered descendent component 5"); - - Start( My_Car ); - TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6"); - - Your_Car.Convertible := False; - Start( Vehicle( Your_Car ) ); - TC_Assert( not Your_Car.Convertible , "Altered descendent component 7"); - - Start( Your_Car ); - TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8"); - - My_Car.Convertible := True; - Start( Vehicle( My_Car ) ); - TC_Assert( My_Car.Convertible, "Altered descendent component 9"); - - Start( My_Car ); - TC_Assert( My_Car.Convertible, "Altered unreferenced component 10"); - - Report.Result; - -end C392004; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392005.a b/gcc/testsuite/ada/acats/tests/c3/c392005.a deleted file mode 100644 index be49cd48b75..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392005.a +++ /dev/null @@ -1,367 +0,0 @@ --- C392005.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, for an implicitly declared dispatching operation that is --- overridden, the body executed is the body for the overriding --- subprogram, even if the overriding occurs in a private part. --- --- Check for the case where the overriding operations are declared in a --- public child unit of the package declaring the parent type, and the --- descendant type is a private extension. --- --- Check for both dispatching and nondispatching calls. --- --- --- TEST DESCRIPTION: --- Consider: --- --- package Parent is --- type Root is tagged ... --- procedure Vis_Op (P: Root); --- private --- procedure Pri_Op (P: Root); --- end Parent; --- --- package Parent.Child is --- type Derived is new Root with private; --- -- Implicit Vis_Op (P: Derived) declared here. --- --- procedure Pri_Op (P: Derived); -- (A) --- ... --- private --- type Derived is new Root with record... --- -- Implicit Pri_Op (P: Derived) declared here. - --- procedure Vis_Op (P: Derived); -- (B) --- ... --- end Parent.Child; --- --- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type --- Root. Note, however, that Vis_Op is implicitly declared in the visible --- part, whereas Pri_Op is implicitly declared in the private part --- (inherited subprograms for a private extension are implicitly declared --- after the private_extension_declaration if the corresponding --- declaration from the ancestor is visible at that place; otherwise the --- inherited subprogram is not declared for the private extension, --- although it might be for the full type). --- --- Even though Root's version of Pri_Op hasn't been implicitly declared --- for Derived at the time Derived's version of Pri_Op has been --- explicitly declared, the explicit Pri_Op still overrides the implicit --- version. --- Also, even though the explicit Vis_Op for Derived is declared in the --- private part it still overrides the implicit version declared in the --- visible part. Calls with tag Derived will execute (A) and (B). --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 26 Nov 96 SAIC Improved for ACVC 2.1 --- ---! - -package C392005_0 is - - type Remote_Camera is tagged private; - - type Depth_Of_Field is range 5 .. 100; - type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand); - type Aperture is (Eight, Sixteen, Thirty_Two); - - -- ...Other declarations. - - procedure Focus (Cam : in out Remote_Camera; - Depth : in Depth_Of_Field); - - procedure Self_Test (C: in out Remote_Camera'Class); - - -- ...Other operations. - - function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field; - function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed; - -private - - type Remote_Camera is tagged record - DOF : Depth_Of_Field := 10; - Shutter: Shutter_Speed := One; - FStop : Aperture := Eight; - end record; - - procedure Set_Shutter_Speed (C : in out Remote_Camera; - Speed : in Shutter_Speed); - - -- For the basic remote camera, shutter speed might be set as a function of - -- focus perhaps, thus it is declared as a private operation (usable - -- only internally within the abstraction). - - function Set_Aperture (C : Remote_Camera) return Aperture; - -end C392005_0; - - - --==================================================================-- - - -package body C392005_0 is - - procedure Focus (Cam : in out Remote_Camera; - Depth : in Depth_Of_Field) is - begin - -- Artificial for testing purposes. - Cam.DOF := 46; - end Focus; - - ----------------------------------------------------------- - procedure Set_Shutter_Speed (C : in out Remote_Camera; - Speed : in Shutter_Speed) is - begin - -- Artificial for testing purposes. - C.Shutter := Thousand; - end Set_Shutter_Speed; - - ----------------------------------------------------------- - function Set_Aperture (C : Remote_Camera) return Aperture is - begin - -- Artificial for testing purposes. - return Thirty_Two; - end Set_Aperture; - - ----------------------------------------------------------- - procedure Self_Test (C: in out Remote_Camera'Class) is - TC_Dummy_Depth : constant Depth_Of_Field := 23; - TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred; - begin - - -- Test focus at various depths: - Focus(C, TC_Dummy_Depth); - -- ...Additional calls to Focus. - - -- Test various shutter speeds: - Set_Shutter_Speed(C, TC_Dummy_Speed); - -- ...Additional calls to Set_Shutter_Speed. - - end Self_Test; - - ----------------------------------------------------------- - function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is - begin - return C.DOF; - end TC_Get_Depth; - - ----------------------------------------------------------- - function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is - begin - return C.Shutter; - end TC_Get_Speed; - -end C392005_0; - - --==================================================================-- - - -package C392005_0.C392005_1 is - - type Auto_Speed is new Remote_Camera with private; - - - -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared - -- Depth : in Depth_Of_Field) -- here. - - -- For the improved remote camera, shutter speed can be set manually, - -- so it is declared as a public operation. - - -- The order of declarations for Set_Aperture and Set_Shutter_Speed are - -- reversed from the original declarations to trap potential compiler - -- problems related to subprogram ordering. - - function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides - -- inherited op. - - procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides - Speed : in Shutter_Speed);-- inherited op. - - -- Set_Shutter_Speed and Set_Aperture override the operations inherited - -- from the parent, even though the inherited operations are not implicitly - -- declared until the private part below. - - type New_Camera is private; - - function TC_Get_Aper (C: New_Camera) return Aperture; - - -- ...Other operations. - -private - type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); - - type Auto_Speed is new Remote_Camera with record - ASA : Film_Speed; - end record; - - -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly - -- Speed : in Shutter_Speed) -- declared - -- here. - - -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly - -- declared. - - procedure Focus (C : in out Auto_Speed; -- Overrides - Depth : in Depth_Of_Field); -- inherited op. - - -- For the improved remote camera, perhaps the focusing algorithm is - -- different, so the original Focus operation is overridden here. - - Auto_Camera : Auto_Speed; - - type New_Camera is record - Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden, - end record; -- not the inherited op. - -end C392005_0.C392005_1; - - - --==================================================================-- - - -package body C392005_0.C392005_1 is - - procedure Focus (C : in out Auto_Speed; - Depth : in Depth_Of_Field) is - begin - -- Artificial for testing purposes. - C.DOF := 57; - end Focus; - - --------------------------------------------------------------- - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in Shutter_Speed) is - begin - -- Artificial for testing purposes. - C.Shutter := Two_Fifty; - end Set_Shutter_Speed; - - ----------------------------------------------------------- - function Set_Aperture (C : Auto_Speed) return Aperture is - begin - -- Artificial for testing purposes. - return Sixteen; - end Set_Aperture; - - ----------------------------------------------------------- - function TC_Get_Aper (C: New_Camera) return Aperture is - begin - return C.Aper; - end TC_Get_Aper; - -end C392005_0.C392005_1; - - - --==================================================================-- - - -with C392005_0.C392005_1; - -with Report; - -procedure C392005 is - Basic_Camera : C392005_0.Remote_Camera; - Auto_Camera1 : C392005_0.C392005_1.Auto_Speed; - Auto_Camera2 : C392005_0.C392005_1.Auto_Speed; - Auto_Depth : C392005_0.Depth_Of_Field := 67; - New_Camera1 : C392005_0.C392005_1.New_Camera; - TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46; - TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57; - TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed - := C392005_0.Thousand; - TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed - := C392005_0.Two_Fifty; - TC_Expected_New_Aper : constant C392005_0.Aperture - := C392005_0.Sixteen; - - use type C392005_0.Depth_Of_Field; - use type C392005_0.Shutter_Speed; - use type C392005_0.Aperture; - -begin - Report.Test ("C392005", "Dispatching for overridden primitive " & - "subprograms: private extension declared in child unit, " & - "parent is tagged private whose full view is tagged record"); - --- Call the class-wide operation for Remote_Camera'Class, which itself makes --- dispatching calls to Focus and Set_Shutter_Speed: - - - -- For an object of type Remote_Camera, the dispatching calls should - -- dispatch to the bodies declared for the root type: - - C392005_0.Self_Test(Basic_Camera); - - if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth - or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed - then - Report.Failed ("Calls dispatched incorrectly for root type"); - end if; - - - -- For an object of type Auto_Speed, the dispatching calls should - -- dispatch to the bodies declared for the derived type: - - C392005_0.Self_Test(Auto_Camera1); - - if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth - - or - C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed - then - Report.Failed ("Calls dispatched incorrectly for derived type"); - end if; - - -- For an object of type Auto_Speed, a non-dispatching call to Focus should - - -- execute the body declared for the derived type (even through it is - -- declared in the private part). - - C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth); - - if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth - - then - Report.Failed ("Non-dispatching call to privately overriding " & - "subprogram executed the wrong body"); - end if; - - -- For an object of type New_Camera, the initialization using Set_Ap - -- should execute the overridden body, not the inherited one. - - if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper - then - Report.Failed ("Non-dispatching call to visible overriding " & - "subprogram executed the wrong body"); - end if; - - Report.Result; - -end C392005; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392008.a b/gcc/testsuite/ada/acats/tests/c3/c392008.a deleted file mode 100644 index 27b4e2a8644..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392008.a +++ /dev/null @@ -1,401 +0,0 @@ --- C392008.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 use of a class-wide formal parameter allows for the --- proper dispatching of objects to the appropriate implementation of --- a primitive operation. Check this for the case where the root tagged --- type is defined in a package and the extended type is defined in a --- dependent package. --- --- TEST DESCRIPTION: --- Declare a root tagged type, and some associated primitive operations, --- in a visible library package. --- Extend the root type in another visible library package, and override --- one or more primitive operations, inheriting the other primitive --- operations from the root type. --- Derive from the extended type in yet another visible library package, --- again overriding some primitive operations and inheriting others --- (including some that the parent inherited). --- Define subprograms with class-wide parameters, inside of which is a --- call on a dispatching primitive operation. These primitive --- operations modify the objects of the specific class passed as actuals --- to the class-wide formal parameter (class-wide formal parameter has --- mode IN OUT). --- --- The following hierarchy of tagged types and primitive operations is --- utilized in this test: --- --- package Bank --- type Account (root) --- | --- | Operations --- | proc Deposit --- | proc Withdrawal --- | func Balance --- | proc Service_Charge --- | proc Add_Interest --- | proc Open --- | --- package Checking --- type Account (extended from Bank.Account) --- | --- | Operations --- | proc Deposit (inherited) --- | proc Withdrawal (inherited) --- | func Balance (inherited) --- | proc Service_Charge (inherited) --- | proc Add_Interest (inherited) --- | proc Open (overridden) --- | --- package Interest_Checking --- type Account (extended from Checking.Account) --- | --- | Operations --- | proc Deposit (inherited twice - Bank.Acct.) --- | proc Withdrawal (inherited twice - Bank.Acct.) --- | func Balance (inherited twice - Bank.Acct.) --- | proc Service_Charge (inherited twice - Bank.Acct.) --- | proc Add_Interest (overridden) --- | proc Open (overridden) --- | --- --- In this test, we are concerned with the following selection of dispatching --- calls, accomplished with the use of a Bank.Account'Class IN OUT formal --- parameter : --- --- \ Type --- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account --- \--------------------------------------------------------- - --- Service_Charge | X X X --- Add_Interest | X X X --- Open | X X X --- --- --- --- The location of the declaration of the root and derivation of extended --- types will be varied over a series of tests. Locations of declaration --- and derivation for a particular test are marked with an asterisk (*). --- --- Root type: --- --- * Declared in package. --- Declared in generic package. --- --- Extended types: --- --- Derived in parent location. --- Derived in a nested package. --- Derived in a nested subprogram. --- Derived in a nested generic package. --- * Derived in a separate package. --- Derived in a separate visible child package. --- Derived in a separate private child package. --- --- Primitive Operations: --- --- * Procedures with same parameter profile. --- Procedures with different parameter profile. --- Functions with same parameter profile. --- Functions with different parameter profile. --- Mixture of Procedures and Functions. --- --- --- TEST FILES: --- This test depends on the following foundation code: --- --- C392008_0.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1 --- ---! - ------------------------------------------------------------------ C392008_0 - -package C392008_0 is -- package Bank - - type Dollar_Amount is range -30_000..30_000; - - type Account is tagged - record - Current_Balance: Dollar_Amount; - end record; - - -- Primitive operations. - - procedure Deposit (A : in out Account; - X : in Dollar_Amount); - procedure Withdrawal (A : in out Account; - X : in Dollar_Amount); - function Balance (A : in Account) return Dollar_Amount; - procedure Service_Charge (A : in out Account); - procedure Add_Interest (A : in out Account); - procedure Open (A : in out Account); - -end C392008_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C392008_0 is - - -- Primitive operations for type Account. - - procedure Deposit (A : in out Account; - X : in Dollar_Amount) is - begin - A.Current_Balance := A.Current_Balance + X; - end Deposit; - - procedure Withdrawal(A : in out Account; - X : in Dollar_Amount) is - begin - A.Current_Balance := A.Current_Balance - X; - end Withdrawal; - - function Balance (A : in Account) return Dollar_Amount is - begin - return (A.Current_Balance); - end Balance; - - procedure Service_Charge (A : in out Account) is - begin - A.Current_Balance := A.Current_Balance - 5_00; - end Service_Charge; - - procedure Add_Interest (A : in out Account) is - Interest_On_Account : Dollar_Amount := 0_00; - begin - A.Current_Balance := A.Current_Balance + Interest_On_Account; - end Add_Interest; - - procedure Open (A : in out Account) is - Initial_Deposit : Dollar_Amount := 10_00; - begin - A.Current_Balance := Initial_Deposit; - end Open; - -end C392008_0; - ------------------------------------------------------------------ C392008_1 - -with C392008_0; -- package Bank - -package C392008_1 is -- package Checking - - package Bank renames C392008_0; - - type Account is new Bank.Account with - record - Overdraft_Fee : Bank.Dollar_Amount; - end record; - - -- Overridden primitive operation. - - procedure Open (A : in out Account); - - -- Inherited primitive operations. - -- procedure Deposit (A : in out Account; - -- X : in Bank.Dollar_Amount); - -- procedure Withdrawal (A : in out Account; - -- X : in Bank.Dollar_Amount); - -- function Balance (A : in Account) return Bank.Dollar_Amount; - -- procedure Service_Charge (A : in out Account); - -- procedure Add_Interest (A : in out Account); - -end C392008_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C392008_1 is - - -- Overridden primitive operation. - - procedure Open (A : in out Account) is - Check_Guarantee : Bank.Dollar_Amount := 10_00; - Initial_Deposit : Bank.Dollar_Amount := 20_00; - begin - A.Current_Balance := Initial_Deposit; - A.Overdraft_Fee := Check_Guarantee; - end Open; - -end C392008_1; - ------------------------------------------------------------------ C392008_2 - -with C392008_0; -- with Bank; -with C392008_1; -- with Checking; - -package C392008_2 is -- package Interest_Checking - - package Bank renames C392008_0; - package Checking renames C392008_1; - - subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4; - - Current_Rate : Interest_Rate := 0_02; - - type Account is new Checking.Account with - record - Rate : Interest_Rate; - end record; - - -- Overridden primitive operations. - - procedure Add_Interest (A : in out Account); - procedure Open (A : in out Account); - - -- "Twice" inherited primitive operations (from Bank.Account) - -- procedure Deposit (A : in out Account; - -- X : in Bank.Dollar_Amount); - -- procedure Withdrawal (A : in out Account; - -- X : in Bank.Dollar_Amount); - -- function Balance (A : in Account) return Bank.Dollar_Amount; - -- procedure Service_Charge (A : in out Account); - -end C392008_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C392008_2 is - - -- Overridden primitive operations. - - procedure Add_Interest (A : in out Account) is - Interest_On_Account : Bank.Dollar_Amount - := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate )); - begin - A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account); - end Add_Interest; - - procedure Open (A : in out Account) is - Initial_Deposit : Bank.Dollar_Amount := 30_00; - begin - Checking.Open (Checking.Account (A)); - A.Current_Balance := Initial_Deposit; - A.Rate := Current_Rate; - end Open; - -end C392008_2; - -------------------------------------------------------------------- C392008 - -with C392008_0; use C392008_0; -- package Bank -with C392008_1; use C392008_1; -- package Checking; -with C392008_2; use C392008_2; -- package Interest_Checking; -with Report; - -procedure C392008 is - - package Bank renames C392008_0; - package Checking renames C392008_1; - package Interest_Checking renames C392008_2; - - B_Acct : Bank.Account; - C_Acct : Checking.Account; - IC_Acct : Interest_Checking.Account; - - -- - -- Define procedures with class-wide formal parameters of mode IN OUT. - -- - - -- This procedure will perform a dispatching call on the - -- overridden primitive operation Open. - - procedure New_Account (Acct : in out Bank.Account'Class) is - begin - Open (Acct); -- Dispatch according to tag of class-wide parameter. - end New_Account; - - -- This procedure will perform a dispatching call on the inherited - -- primitive operation (for all types derived from the root Bank.Account) - -- Service_Charge. - - procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is - begin - Service_Charge (Acct); -- Dispatch according to tag of class-wide parm. - end Apply_Service_Charge; - - -- This procedure will perform a dispatching call on the - -- inherited/overridden primitive operation Add_Interest. - - procedure Annual_Interest (Acct: in out Bank.Account'Class) is - begin - Add_Interest (Acct); -- Dispatch according to tag of class-wide parm. - end Annual_Interest; - -begin - - Report.Test ("C392008", "Check that the use of a class-wide formal " & - "parameter allows for the proper dispatching " & - "of objects to the appropriate implementation " & - "of a primitive operation"); - - -- Check the dispatch to primitive operations overridden for each - -- extended type. - New_Account (B_Acct); - New_Account (C_Acct); - New_Account (IC_Acct); - - if (B_Acct.Current_Balance /= 10_00) or - (C_Acct.Current_Balance /= 20_00) or - (IC_Acct.Current_Balance /= 30_00) - then - Report.Failed ("Failed dispatch to multiply overridden prim. oper."); - end if; - - - Annual_Interest (B_Acct); - Annual_Interest (C_Acct); - Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation - -- overridden from a parent type which inherited - -- the operation from the root type. - if (B_Acct.Current_Balance /= 10_00) or - (C_Acct.Current_Balance /= 20_00) or - (IC_Acct.Current_Balance /= 90_00) - then - Report.Failed ("Failed dispatch to overridden primitive operation"); - end if; - - - Apply_Service_Charge (Acct => B_Acct); - Apply_Service_Charge (Acct => C_Acct); - Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a - -- primitive operation twice - -- inherited from the root - -- tagged type. - if (B_Acct.Current_Balance /= 5_00) or - (C_Acct.Current_Balance /= 15_00) or - (IC_Acct.Current_Balance /= 85_00) - then - Report.Failed ("Failed dispatch to Apply_Service_Charge"); - end if; - - Report.Result; - -end C392008; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392010.a b/gcc/testsuite/ada/acats/tests/c3/c392010.a deleted file mode 100644 index ec168780cbf..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392010.a +++ /dev/null @@ -1,512 +0,0 @@ --- C392010.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 subprogram dispatches correctly with a controlling --- access parameter. Check that a subprogram dispatches correctly --- when it has access parameters that are not controlling. --- Check with and without default expressions. --- --- TEST DESCRIPTION: --- The three packages define layers of tagged types. The root tagged --- type contains a character value used to check that the right object --- got passed to the right routine. Each subprogram has a unique --- TCTouch tag, upper case values are used for subprograms, lower case --- values are used for object values. --- --- Notes on style: the "tagged" comment lines --I and --A represent --- commentary about what gets inherited and what becomes abstract, --- respectively. The author felt these to be necessary with this test --- to reduce some of the additional complexities. --- ---3.9.2(16,17,18,20);6.0 --- --- CHANGE HISTORY: --- 22 SEP 95 SAIC Initial version --- 22 APR 96 SAIC Revised for 2.1 --- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make --- it override. --- 21 JUN 00 RLB Changed expected result to reflect the appropriate --- value of the default expression. --- 20 JUL 00 RLB Removed entire call pending resolution by the ARG. - ---! - ------------------------------------------------------------------ C392010_0 - -package C392010_0 is - - -- define a root tagged type - type Tagtype_Level_0 is tagged record - Ch_Item : Character; - end record; - - type Access_Procedure is access procedure( P: Tagtype_Level_0 ); - - procedure Proc_1( P: Tagtype_Level_0 ); - - procedure Proc_2( P: Tagtype_Level_0 ); - - function A_Default_Value return Tagtype_Level_0; - - procedure Proc_w_Ap_and_Cp( AP : Access_Procedure; - Cp : Tagtype_Level_0 ); - -- has both access procedure and controlling parameter - - procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; - Cp : Tagtype_Level_0 - := A_Default_Value ); ------------ z - -- has both access procedure and controlling parameter with defaults - - -- for the objective: --- Check that access parameters may be controlling. - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ); - -- has access parameter that is controlling - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) - return Tagtype_Level_0; - -- has access parameter that is controlling, and controlling result - - Level_0_Global_Object : aliased Tagtype_Level_0 - := ( Ch_Item => 'a' ); ---------------------------- a - -end C392010_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392010_0 is - - procedure Proc_1( P: Tagtype_Level_0 ) is - begin - TCTouch.Touch('A'); --------------------------------------------------- A - TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? - end Proc_1; - - procedure Proc_2( P: Tagtype_Level_0 ) is - begin - TCTouch.Touch('B'); --------------------------------------------------- B - TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? - end Proc_2; - - function A_Default_Value return Tagtype_Level_0 is - begin - return (Ch_Item => 'z'); ---------------------------------------------- z - end A_Default_Value; - - procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure; - Cp : Tagtype_Level_0 ) is - begin - TCTouch.Touch('C'); --------------------------------------------------- C - Ap.all( Cp ); - end Proc_w_Ap_and_Cp; - - procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; - Cp : Tagtype_Level_0 - := A_Default_Value ) is - begin - TCTouch.Touch('D'); --------------------------------------------------- D - Ap.all( Cp ); - end Proc_w_Ap_and_Cp_w_Def; - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is - begin - TCTouch.Touch('E'); --------------------------------------------------- E - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - end Proc_w_Cp_Ap; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) - return Tagtype_Level_0 is - begin - TCTouch.Touch('F'); --------------------------------------------------- F - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - return ( Ch_Item => 'b' ); -------------------------------------------- b - end Func_w_Cp_Ap_and_Cr; - -end C392010_0; - ------------------------------------------------------------------ C392010_1 - -with C392010_0; -package C392010_1 is - - type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record - Int_Item : Integer; - end record; - - type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class; - - -- the following procedures are inherited by the above declaration: - --I procedure Proc_1( P: Tagtype_Level_1 ); - --I - --I procedure Proc_2( P: Tagtype_Level_1 ); - --I - --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - --I Cp : Tagtype_Level_1 ); - --I - --I procedure Proc_w_Ap_and_Cp_w_Def - --I ( AP : C392010_0.Access_Procedure := Proc_2'Access; - --I Cp : Tagtype_Level_1 := A_Default_Value ); - --I - --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); - --I - - -- the following functions become abstract due to the above declaration: - --A function A_Default_Value return Tagtype_Level_1; - --A - --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - --A return Tagtype_Level_1; - - -- so, in the interest of testing dispatching, we override them all: - -- except Proc_1 and Proc_2 - - procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - Cp : Tagtype_Level_1 ); - - function A_Default_Value return Tagtype_Level_1; - - procedure Proc_w_Ap_and_Cp_w_Def( - AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; - Cp : Tagtype_Level_1 := A_Default_Value ); - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - return Tagtype_Level_1; - - -- to test the objective: --- Check that a subprogram dispatches correctly when it has --- access parameters that are not controlling. - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) - return Access_Tagtype_Level_1; - - Level_1_Global_Object : aliased Tagtype_Level_1 - := ( Int_Item => 0, - Ch_Item => 'c' ); --------------------------- c - -end C392010_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392010_1 is - - procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - Cp : Tagtype_Level_1 ) is - begin - TCTouch.Touch('G'); --------------------------------------------------- G - Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); - end Proc_w_Ap_and_Cp; - - procedure Proc_w_Ap_and_Cp_w_Def( - AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; - Cp : Tagtype_Level_1 := A_Default_Value ) - is - begin - TCTouch.Touch('H'); --------------------------------------------------- H - Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); - end Proc_w_Ap_and_Cp_w_Def; - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is - begin - TCTouch.Touch('I'); --------------------------------------------------- I - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - end Proc_w_Cp_Ap; - - function A_Default_Value return Tagtype_Level_1 is - begin - return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y - end A_Default_Value; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - return Tagtype_Level_1 is - begin - TCTouch.Touch('J'); --------------------------------------------------- J - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d - end Func_w_Cp_Ap_and_Cr; - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) is - begin - TCTouch.Touch('K'); --------------------------------------------------- K - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - end Proc_w_Non; - - Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) - return Access_Tagtype_Level_1 is - begin - TCTouch.Touch('L'); --------------------------------------------------- L - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - return Own_Item'Access; ----------------------------------------------- e - end Func_w_Non; - -end C392010_1; - - - ------------------------------------------------------------------ C392010_2 - -with C392010_0; -with C392010_1; -package C392010_2 is - - Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0 - := ( Ch_Item => 'f' ); ---------------------------- f - - type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record - Another_Int_Item : Integer; - end record; - - type Access_Tagtype_Level_2 is access all Tagtype_Level_2; - - -- the following procedures are inherited by the above declaration: - --I procedure Proc_1( P: Tagtype_Level_2 ); - --I - --I procedure Proc_2( P: Tagtype_Level_2 ); - --I - --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - --I Cp : Tagtype_Level_2 ); - --I - --I procedure Proc_w_Ap_and_Cp_w_Def - --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access; - --I CP: Tagtype_Level_2 := A_Default_Value ); - --I - --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 ); - --I - --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - --I NonCp_Ap : access C392010_0.Tagtype_Level_0 - --I := C392010_0.Level_0_Global_Object'Access ); - - -- the following functions become abstract due to the above declaration: - --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - --A return Tagtype_Level_2; - --A - --A function A_Default_Value - --A return Access_Tagtype_Level_2; - - -- so we override the interesting ones to check the objective: --- Check that a subprogram with parameters of distinct tagged types may --- be primitive for only one type (i.e. the other tagged types must be --- declared in other packages). Check that the subprogram does not --- dispatch for the other type(s). - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) - return C392010_1.Access_Tagtype_Level_1; - - -- and override the other abstract functions - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - return Tagtype_Level_2; - - function A_Default_Value return Tagtype_Level_2; - -end C392010_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -with Report; -package body C392010_2 is - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) is - begin - TCTouch.Touch('M'); --------------------------------------------------- M - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - end Proc_w_Non; - - function A_Default_Value return Tagtype_Level_2 is - begin - return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x - end A_Default_Value; - - Own : aliased Tagtype_Level_2 - := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) - return C392010_1.Access_Tagtype_Level_1 is - begin - TCTouch.Touch('N'); --------------------------------------------------- N - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - return Own'Access; ---------------------------------------------------- g - end Func_w_Non; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - return Tagtype_Level_2 is - begin - TCTouch.Touch('P'); --------------------------------------------------- P - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h - end Func_w_Cp_Ap_and_Cr; - -end C392010_2; - - - -------------------------------------------------------------------- C392010 - -with Report; -with TCTouch; -with C392010_0, C392010_1, C392010_2; - -procedure C392010 is - - type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class; - - -- define an array of class-wide pointers: - type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0; - - Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k - Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m - Int_Item => 1 ); - Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n - Int_Item => 1, - Another_Int_Item => 1 ); - - Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access); - - procedure Subtest_1( Items: Zero_Dispatch_List ) is - -- there is little difference between the actions for _1 and _2 in - -- this subtest due to the nature of _2 inheriting most operations - -- - -- this subtest checks operations available to Level_0'Class - begin - for I in Items'Range loop - - C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all ); - -- CAk, GAm, GAn - -- actual is class-wide, operation should dispatch - - case I is -- use defaults - when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def; - -- DBz - when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def; - -- HBy - when 3 => null; -- Removed following pending resolution by ARG - -- (see AI-00239): - -- C392010_2.Proc_w_Ap_and_Cp_w_Def; - -- HBx - when others => Report.Failed("Unexpected loop value"); - end case; - - C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults - ( C392010_0.Proc_1'Access, Items(I).all ); - -- DAk, HAm, HAn - - C392010_0.Proc_w_Cp_Ap( Items(I) ); - -- Ek, Im, In - - -- function return value is controlling for procedure call - C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access, - C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) ); - -- FkDAb, JmHAd, PnHAh - -- note that the function evaluates first - - end loop; - end Subtest_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class; - - type One_Dispatch_List is array(Natural range <>) of Access_Class_1; - - Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p - Int_Item => 1 ); - Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q - Int_Item => 1, - Another_Int_Item => 1 ); - - D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access); - - procedure Subtest_2( Items: One_Dispatch_List ) is - -- this subtest checks operations available to Level_1'Class, - -- specifically those operations that are not testable in subtest_1, - -- the operations with parameters of the two tagged type objects. - begin - for I in Items'Range loop - - C392010_1.Proc_w_Non( -- t_1, t_2 - C392010_1.Func_w_Non( Items(I), - C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm - C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn - - end loop; - end Subtest_2; - -begin -- Main test procedure. - - Report.Test ("C392010", "Check that a subprogram dispatches correctly " & - "with a controlling access parameter. " & - "Check that a subprogram dispatches correctly " & - "when it has access parameters that are not " & - "controlling. Check with and without default " & - "expressions" ); - - Subtest_1( Z ); - - -- Original result: - --TCTouch.Validate( "CAkDBzDAkEkFkDAb" - -- & "GAmHByHAmImJmHAd" - -- & "GAnHBxHAnInPnHAh", "Subtest 1" ); - - -- Result pending resultion of AI-239: - TCTouch.Validate( "CAkDBzDAkEkFkDAb" - & "GAmHByHAmImJmHAd" - & "GAnHAnInPnHAh", "Subtest 1" ); - - Subtest_2( D ); - - TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" ); - - Report.Result; - -end C392010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392011.a b/gcc/testsuite/ada/acats/tests/c3/c392011.a deleted file mode 100644 index c32ec77c0d0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392011.a +++ /dev/null @@ -1,299 +0,0 @@ --- C392011.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 if a function call with a controlling result is itself --- a controlling operand of an enclosing call on a dispatching operation, --- then its controlling tag value is determined by the controlling tag --- value of the enclosing call. --- --- TEST DESCRIPTION: --- The test builds and traverses a "ragged" list; a linked list which --- contains data elements of three different types (all rooted at --- Level_0'Class). The traversal of this list checks the objective --- by calling the dispatching operation "Check" using an item from the --- list, and calling the function create; thus causing the controlling --- result of the function to be determined by evaluating the value of --- the other controlling parameter to the two-parameter Check. --- --- --- CHANGE HISTORY: --- 22 SEP 95 SAIC Initial version --- 23 APR 96 SAIC Corrected commentary, differentiated integer. --- ---! - ------------------------------------------------------------------ C392011_0 - -package C392011_0 is - - type Level_0 is tagged record - Ch_Item : Character; - end record; - - function Create return Level_0; - -- primitive dispatching function - - procedure Check( Left, Right: in Level_0 ); - -- has controlling parameters - -end C392011_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -with TCTouch; -package body C392011_0 is - - The_Character : Character := 'A'; - - function Create return Level_0 is - Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character ); - begin - The_Character := Character'Succ(The_Character); - TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A - return Created_Item_0; - end Create; - - procedure Check( Left, Right: in Level_0 ) is - begin - TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B - end Check; - -end C392011_0; - ------------------------------------------------------------------ C392011_1 - -with C392011_0; -package C392011_1 is - - type Level_1 is new C392011_0.Level_0 with record - Int_Item : Integer; - end record; - - -- note that Create becomes abstract upon this derivation hence: - - function Create return Level_1; - - procedure Check( Left, Right: in Level_1 ); - -end C392011_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392011_1 is - - Integer_1 : Integer := 0; - - function Create return Level_1 is - Created_Item_1 : constant Level_1 - := ( C392011_0.Create with Int_Item => Integer_1 ); - -- note call to ^--------------^ -- A - begin - Integer_1 := Integer'Succ(Integer_1); - TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C - return Created_Item_1; - end Create; - - procedure Check( Left, Right: in Level_1 ) is - begin - TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D - end Check; - -end C392011_1; - ------------------------------------------------------------------ C392011_2 - -with C392011_1; -package C392011_2 is - - type Level_2 is new C392011_1.Level_1 with record - Another_Int_Item : Integer; - end record; - - -- note that Create becomes abstract upon this derivation hence: - - function Create return Level_2; - - procedure Check( Left, Right: in Level_2 ); - -end C392011_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392011_2 is - - Integer_2 : Integer := 100; - - function Create return Level_2 is - Created_Item_2 : constant Level_2 - := ( C392011_1.Create with Another_Int_Item => Integer_2 ); - -- note call to ^--------------^ -- AC - begin - Integer_2 := Integer'Succ(Integer_2); - TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E - return Created_Item_2; - end Create; - - procedure Check( Left, Right: in Level_2 ) is - begin - TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F - end Check; - -end C392011_2; - -------------------------------------------------------- C392011_2.C392011_3 - -with C392011_0; -package C392011_2.C392011_3 is - - type Wide_Reference is access all C392011_0.Level_0'Class; - - type Ragged_Element; - - type List_Pointer is access Ragged_Element; - - type Ragged_Element is record - Data : Wide_Reference; - Next : List_Pointer; - end record; - - procedure Build_List; - - procedure Traverse_List; - -end C392011_2.C392011_3; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C392011_2.C392011_3 is - - The_List : List_Pointer; - - procedure Build_List is - begin - - -- build a list that looks like: - -- Level_2, Level_1, Level_2, Level_1, Level_0 - -- - -- the mechanism is to create each object, "pushing" the existing list - -- onto the end: cons( new_item, car, cdr ) - - The_List := - new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null ); - -- Level_0 >> A - - The_List := - new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); - -- Level_1 -> Level_0 >> AC - - The_List := - new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); - -- Level_2 -> Level_1 -> Level_0 >> ACE - - The_List := - new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); - -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC - - The_List := - new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); - -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE - - end Build_List; - - procedure Traverse_List is - - Next_Item : List_Pointer := The_List; - - -- Check that if a function call with a controlling result is itself - -- a controlling operand of an enclosing call on a dispatching operation, - -- then its controlling tag value is determined by the controlling tag - -- value of the enclosing call. - - -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 - - begin - - while Next_Item /= null loop -- here we go! - -- these calls better dispatch according to the value in the particular - -- list item; causing the call to create to dispatch accordingly. - -- why do it twice? To make sure order makes no difference - - C392011_0.Check(Next_Item.Data.all, C392011_0.Create); - -- Create will touch first, then Check touches - - C392011_0.Check(C392011_0.Create, Next_Item.Data.all); - - -- Here's what's s'pos'd to 'appen: - -- Check( Lev_2, Create ) >> ACEF - -- Check( Create, Lev_2 ) >> ACEF - -- Check( Lev_1, Create ) >> ACD - -- Check( Create, Lev_1 ) >> ACD - -- Check( Lev_2, Create ) >> ACEF - -- Check( Create, Lev_2 ) >> ACEF - -- Check( Lev_1, Create ) >> ACD - -- Check( Create, Lev_1 ) >> ACD - -- Check( Lev_0, Create ) >> AB - -- Check( Create, Lev_0 ) >> AB - - Next_Item := Next_Item.Next; - end loop; - end Traverse_List; - -end C392011_2.C392011_3; - -------------------------------------------------------------------- C392011 - -with Report; -with TCTouch; -with C392011_2.C392011_3; - -procedure C392011 is - -begin -- Main test procedure. - - Report.Test ("C392011", "Check that if a function call with a " & - "controlling result is itself a controlling " & - "operand of an enclosing call on a dispatching " & - "operation, then its controlling tag value is " & - "determined by the controlling tag value of " & - "the enclosing call" ); - - C392011_2.C392011_3.Build_List; - TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" ); - - C392011_2.C392011_3.Traverse_List; - TCTouch.Validate( "ACEFACEF" & - "ACDACD" & - "ACEFACEF" & - "ACDACD" & - "ABAB", - "Traverse List" ); - - Report.Result; - -end C392011; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392013.a b/gcc/testsuite/ada/acats/tests/c3/c392013.a deleted file mode 100644 index 3873d9e62d5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392013.a +++ /dev/null @@ -1,179 +0,0 @@ --- C392013.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 "/=" implicitly declared with the declaration of "=" for --- a tagged type is legal and can be used in a dispatching call. --- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1). --- --- CHANGE HISTORY: --- 23 JAN 2001 PHL Initial version. --- 16 MAR 2001 RLB Readied for release; added identity and negative --- result cases. --- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case. ---! -with Report; -use Report; -procedure C392013 is - - package P1 is - type T is tagged - record - C1 : Integer; - end record; - function "=" (L, R : T) return Boolean; - end P1; - - package P2 is - type T is new P1.T with private; - function Make (Ancestor : P1.T; X : Float) return T; - private - type T is new P1.T with - record - C2 : Float; - end record; - function "=" (L, R : T) return Boolean; - end P2; - - package P3 is - type T is new P2.T with - record - C3 : Character; - end record; - private - function "=" (L, R : T) return Boolean; - function Make (Ancestor : P1.T; X : Float) return T; - end P3; - - - package body P1 is separate; - package body P2 is separate; - package body P3 is separate; - - - type Cwat is access P1.T'Class; - type Cwat_Array is array (Positive range <>) of Cwat; - - A : constant Cwat_Array := - (1 => new P1.T'(C1 => Ident_Int (3)), - 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)), - 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)), - 4 => new P1.T'(C1 => Ident_Int (-3)), - 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)), - 6 => new P1.T'(C1 => Ident_Int (4)), - 7 => new P3.T'(P2.Make - (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with - Ident_Char ('a')), - 8 => new P3.T'(P2.Make - (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with - Ident_Char ('A')), - 9 => new P3.T'(P2.Make - (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with - Ident_Char ('B'))); - - type Truth is ('F', 'T'); - type Truth_Table is array (Positive range <>, Positive range <>) of Truth; - - Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF", - "FTTFTFFFF", - "FTTFFFFFF", - "TFFTFFFFF", - "FTFFTFFFF", - "FFFFFTFFF", - "FFFFFFTTF", - "FFFFFFTTF", - "FFFFFFFFT"); - -begin - Test ("C392013", "Check that the ""/="" implicitly declared " & - "with the declaration of ""="" for a tagged " & - "type is legal and can be used in a dispatching call"); - - for I in A'Range loop - for J in A'Range loop - -- Test identity: - if P1."=" (A (I).all, A (J).all) /= - (not P1."/=" (A (I).all, A (J).all)) then - Failed ("Incorrect identity comparing objects" & - Positive'Image (I) & " and" & Positive'Image (J)); - end if; - -- Test the result of "/=": - if Equality (I, J) = 'T' then - if P1."/=" (A (I).all, A (J).all) then - Failed ("Incorrect result comparing objects" & - Positive'Image (I) & " and" & Positive'Image (J) & " - T"); - end if; - else - if not P1."/=" (A (I).all, A (J).all) then - Failed ("Incorrect result comparing objects" & - Positive'Image (I) & " and" & Positive'Image (J) & " - F"); - end if; - end if; - end loop; - end loop; - - Result; -end C392013; -separate (C392013) -package body P1 is - - function "=" (L, R : T) return Boolean is - begin - return abs L.C1 = abs R.C1; - end "="; - -end P1; -separate (C392013) -package body P2 is - - function "=" (L, R : T) return Boolean is - begin - return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5; - end "="; - - - function Make (Ancestor : P1.T; X : Float) return T is - begin - return (Ancestor with X); - end Make; - -end P2; -with Ada.Characters.Handling; -separate (C392013) -package body P3 is - - function "=" (L, R : T) return Boolean is - begin - return P2."=" (P2.T (L), P2.T (R)) and then - Ada.Characters.Handling.To_Upper (L.C3) = - Ada.Characters.Handling.To_Upper (R.C3); - end "="; - - function Make (Ancestor : P1.T; X : Float) return T is - begin - return (P2.Make (Ancestor, X) with ' '); - end Make; - -end P3; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392014.a b/gcc/testsuite/ada/acats/tests/c3/c392014.a deleted file mode 100644 index 89d403eaad3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392014.a +++ /dev/null @@ -1,225 +0,0 @@ --- C392014.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 objects designated by X'Access (where X is of a class-wide --- type) and new T'Class'(...) are dynamically tagged and can be used in --- dispatching calls. (Defect Report 8652/0010). --- --- CHANGE HISTORY: --- 18 JAN 2001 PHL Initial version --- 15 MAR 2001 RLB Readied for release. - ---! -package C392014_0 is - - type T (D : Integer) is abstract tagged private; - - procedure P (X : access T) is abstract; - function Create (X : Integer) return T'Class; - - Result : Natural := 0; - -private - type T (D : Integer) is abstract tagged null record; -end C392014_0; - -with C392014_0; -package C392014_1 is - type T is new C392014_0.T with private; - function Create (X : Integer) return T'Class; -private - type T is new C392014_0.T with - record - C1 : Integer; - end record; - procedure P (X : access T); -end C392014_1; - -package C392014_1.Child is - type T is new C392014_1.T with private; - procedure P (X : access T); - function Create (X : Integer) return T'Class; -private - type T is new C392014_1.T with - record - C1C : Integer; - end record; -end C392014_1.Child; - -with Report; -use Report; -with C392014_1.Child; -package body C392014_1 is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C1; - end P; - - function Create (X : Integer) return T'Class is - begin - case X mod Ident_Int (2) is - when 0 => - return C392014_1.Child.Create (X / Ident_Int (2)); - when 1 => - declare - Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20)); - begin - Y.C1 := X / Ident_Int (40); - return T'Class (Y); - end; - when others => - null; - end case; - end Create; - -end C392014_1; - -with C392014_0; -with C392014_1; -package C392014_2 is - type T is new C392014_0.T with private; - function Create (X : Integer) return T'Class; -private - type T is new C392014_1.T with - record - C2 : Integer; - end record; - procedure P (X : access T); -end C392014_2; - -with Report; -use Report; -with C392014_1.Child; -with C392014_2; -package body C392014_0 is - - function Create (X : Integer) return T'Class is - begin - case X mod 3 is - when 0 => - return C392014_1.Create (X / Ident_Int (3)); - when 1 => - return C392014_1.Child.Create (X / Ident_Int (3)); - when 2 => - return C392014_2.Create (X / Ident_Int (3)); - when others => - null; - end case; - end Create; - -end C392014_0; - -with Report; -use Report; -with C392014_0; -package body C392014_1.Child is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C; - end P; - - function Create (X : Integer) return T'Class is - Y : T (D => X mod Ident_Int (20)); - begin - Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20); - Y.C1C := X / Ident_Int (400); - return T'Class (Y); - end Create; - -end C392014_1.Child; - -with Report; -use Report; -package body C392014_2 is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C2; - end P; - - function Create (X : Integer) return T'Class is - Y : T (D => X mod Ident_Int (20)); - begin - Y.C2 := X / Ident_Int (600); - return T'Class (Y); - end Create; - -end C392014_2; - -with Report; -use Report; -with C392014_0; -with C392014_1.Child; -with C392014_2; -procedure C392014 is - - subtype S0 is C392014_0.T'Class (D => Ident_Int (17)); - subtype S1 is C392014_1.T'Class; - - X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218)); - X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253)); - - Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693)); - Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622)); - - procedure TC_Check (Subtest : String; Expected : Integer) is - begin - if C392014_0.Result = Expected then - Comment ("Subtest " & Subtest & " Passed"); - else - Failed ("Subtest " & Subtest & " Failed"); - end if; - C392014_0.Result := Ident_Int (0); - end TC_Check; - -begin - Test ("C392014", - "Check that objects designated by X'Access " & - "(where X is of a class-wide type) and New T'Class'(...) " & - "are dynamically tagged and can be used in dispatching " & - "calls"); - - C392014_0.P (X0'Access); - TC_Check ("X0'Access", Ident_Int (29)); - C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850)))); - TC_Check ("New C392014_0.T'Class", Ident_Int (27)); - C392014_1.P (X1'Access); - TC_Check ("X1'Access", Ident_Int (212)); - C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031)))); - TC_Check ("New C392014_1.T'Class", Ident_Int (65)); - C392014_0.P (Y0'Access); - TC_Check ("Y0'Access", Ident_Int (18)); - C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893)))); - TC_Check ("New S0", Ident_Int (20)); - C392014_1.P (Y1'Access); - TC_Check ("Y1'Access", Ident_Int (18)); - C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861)))); - TC_Check ("New S1", Ident_Int (56)); - - Result; -end C392014; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392a01.a b/gcc/testsuite/ada/acats/tests/c3/c392a01.a deleted file mode 100644 index 8ad78914231..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392a01.a +++ /dev/null @@ -1,265 +0,0 @@ --- C392A01.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 use of a class-wide formal parameter allows for the - -- proper dispatching of objects to the appropriate implementation of - -- a primitive operation. Check this for the root tagged type defined - -- in a package, and the extended type is defined in that same package. - -- - -- TEST DESCRIPTION: - -- Declare a root tagged type, and some associated primitive operations. - -- Extend the root type, and override one or more primitive operations, - -- inheriting the other primitive operations from the root type. - -- Derive from the extended type, again overriding some primitive - -- operations and inheriting others (including some that the parent - -- inherited). - -- Define a subprogram with a class-wide parameter, inside of which is a - -- call on a dispatching primitive operation. These primitive operations - -- modify global variables (the class-wide parameter has mode IN). - -- - -- - -- - -- The following hierarchy of tagged types and primitive operations is - -- utilized in this test: - -- - -- type Bank_Account (root) - -- | - -- | Operations - -- | Increment_Bank_Reserve - -- | Assign_Representative - -- | Increment_Counters - -- | Open - -- | - -- type Savings_Account (extended from Bank_Account) - -- | - -- | Operations - -- | (Increment_Bank_Reserve) (inherited) - -- | Assign_Representative (overridden) - -- | Increment_Counters (overridden) - -- | Open (overridden) - -- | - -- type Preferred_Account (extended from Savings_Account) - -- | - -- | Operations - -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) - -- | (Assign_Representative) (inherited - Savings_Acct.) - -- | Increment_Counters (overridden) - -- | Open (overridden) - -- - -- - -- In this test, we are concerned with the following selection of dispatching - -- calls, accomplished with the use of a Bank_Account'Class IN procedure - -- parameter : - -- - -- \ Type - -- Prim. Op \ Bank_Account Savings_Account Preferred_Account - -- \------------------------------------------------ - -- Increment_Bank_Reserve| X X X - -- Assign_Representative | X - -- Increment_Counters | X X X - -- - -- - -- - -- The location of the declaration and derivation of the root and extended - -- types will be varied over a series of tests. Locations of declaration - -- and derivation for a particular test are marked with an asterisk (*). - -- - -- Root type: - -- - -- * Declared in package. - -- Declared in generic package. - -- - -- Extended types: - -- - -- * Derived in parent location. - -- Derived in a nested package. - -- Derived in a nested subprogram. - -- Derived in a nested generic package. - -- Derived in a separate package. - -- Derived in a separate visible child package. - -- Derived in a separate private child package. - -- - -- Primitive Operations: - -- - -- * Procedures with same parameter profile. - -- Procedures with different parameter profile. - -- Functions with same parameter profile. - -- Functions with different parameter profile. - -- Mixture of Procedures and Functions. - -- - -- - -- TEST FILES: - -- This test depends on the following foundation code: - -- - -- F392A00.A - -- - -- The following files comprise this test: - -- - -- => C392A01.A - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - with F392A00; -- package Accounts - with Report; - - procedure C392A01 is - - package Accounts renames F392A00; - - -- Declare account objects. - - B_Account : Accounts.Bank_Account; - S_Account : Accounts.Savings_Account; - P_Account : Accounts.Preferred_Account; - - -- Procedures to operate on accounts. - -- Each uses a class-wide IN parameter, as well as a call to a - -- dispatching operation. - - -- Procedure Tabulate_Account performs a dispatching call on a primitive - -- operation that has been overridden for each of the extended types. - - procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is - begin - Accounts.Increment_Counters (Acct); -- Dispatch according to tag. - end Tabulate_Account; - - - -- Procedure Accumulate_Reserve performs a dispatching call on a - -- primitive operation that has been defined for the root type and - -- inherited by each derived type. - - procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is - begin - Accounts.Increment_Bank_Reserve (Acct); -- Dispatch according to tag. - end Accumulate_Reserve; - - - -- Procedure Resolve_Dispute performs a dispatching call on a primitive - -- operation that has been defined in the root type, overridden in the - -- first derived extended type, and inherited by the subsequent extended - -- type. - - procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is - begin - Accounts.Assign_Representative (Acct); -- Dispatch according to tag. - end Resolve_Dispute; - - - - begin -- Main test procedure. - - Report.Test ("C392A01", "Check that the use of a class-wide parameter " & - "allows for proper dispatching where root type " & - "and extended types are declared in the same " & - "package" ); - - Bank_Account_Subtest: - declare - use Accounts; - begin - Accounts.Open (B_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been defined for this specific type. - Accumulate_Reserve (Acct => B_Account); - Tabulate_Account (B_Account); - - if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or - (Accounts.Number_Of_Accounts (Bank) /= 1) or - (Accounts.Number_Of_Accounts (Total) /= 1) - then - Report.Failed ("Failed in Bank_Account_Subtest"); - end if; - - end Bank_Account_Subtest; - - - Savings_Account_Subtest: - declare - use Accounts; - begin - Accounts.Open (Acct => S_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been inherited by this extended type. - Accumulate_Reserve (Acct => S_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been overridden for this extended type. - Resolve_Dispute (Acct => S_Account); - Tabulate_Account (S_Account); - - if Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or - Accounts.Daily_Representative /= Accounts.Manager or - Accounts.Number_Of_Accounts (Savings) /= 1 or - Accounts.Number_Of_Accounts (Total) /= 2 - then - Report.Failed ("Failed in Savings_Account_Subtest"); - end if; - - end Savings_Account_Subtest; - - - Preferred_Account_Subtest: - declare - use Accounts; - begin - Accounts.Open (P_Account); - - -- Verify that the correct implementation of Open (overridden) was - -- used for the Preferred_Account object. - if not Accounts.Verify_Open (P_Account) then - Report.Failed ("Incorrect values for init. Preferred Acct object"); - end if; - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been twice inherited by this extended type. - Accumulate_Reserve (Acct => P_Account); - - -- Demonstrate class-wide parameter allowing dispatch by a primitive - -- operation that has been overridden for this extended type (the - -- operation was overridden by its parent type as well). - Tabulate_Account (P_Account); - - if Accounts.Bank_Reserve /= 1300.00 or - Accounts.Number_Of_Accounts (Preferred) /= 1 or - Accounts.Number_Of_Accounts (Total) /= 3 - then - Report.Failed ("Failed in Preferred_Account_Subtest"); - end if; - - end Preferred_Account_Subtest; - - - Report.Result; - - end C392A01; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c05.a b/gcc/testsuite/ada/acats/tests/c3/c392c05.a deleted file mode 100644 index 6bd3cece77e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392c05.a +++ /dev/null @@ -1,164 +0,0 @@ --- C392C05.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 for a call to a dispatching subprogram the subprogram --- body which is executed is determined by the controlling tag for --- the case where the call has statically tagged controlling operands --- of the type T. Check this for various operands of tagged types: --- objects (declared or allocated), formal parameters, view conversions, --- function calls (both primitive and non-primitive). --- --- TEST DESCRIPTION: --- This test uses foundation F392C00 to test the usages of statically --- tagged objects and values. The calls to Validate indicate the --- expected sequence of procedure calls since the previous call to --- Validate. Static tags can be determined at compile time, and --- hence this is a test of correct overload resolution for tagged types. --- A clever compiler which unrolls loops and does path analysis on --- access values will be able to perform the same kind of determination --- for all of the code in this test. --- --- TEST FILES: --- The following files comprise this test: --- --- F392C00.A (foundation code) --- C392C05.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 24 Oct 95 SAIC Updated for ACVC 2.0.1 --- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are --- evaluated in textual order. ---! - -with Report; -with TCTouch; -with F392C00_1; -procedure C392C05 is -- Hardware_Store - - package Switch renames F392C00_1; - - subtype Switch_Class is Switch.Toggle'Class; - - type Reference is access all Switch_Class; - - A_Switch : aliased Switch.Toggle; - A_Dimmer : aliased Switch.Dimmer; - An_Autodim : aliased Switch.Auto_Dimmer; - - type Light_Bank is array(Positive range <>) of Reference; - - Lamps : Light_Bank(1..3); - -begin -- Main test procedure. - - Report.Test ("C392C05", "Check that a dispatching subprogram call is " - & "determined by the controlling tag for statically " - & "tagged controlling operands" ); - --- Check use of static tagged declared objects, --- and static tagged formal parameters --- Must call correct version of flip based on type of controlling op. - --- Turn on the lights! - - Switch.Flip( A_Switch ); - TCTouch.Validate( "A", "Declared Toggle" ); - - Switch.Flip( A_Dimmer ); - TCTouch.Validate( "GBA", "Declared Dimmer" ); - - Switch.Flip( An_Autodim ); - TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" ); - - Lamps(1) := new Switch.Toggle; - Lamps(2) := new Switch.Dimmer; - Lamps(3) := new Switch.Auto_Dimmer; - --- Check use of static tagged allocated objects, --- and static tagged formal parameters in a loop which may dynamically --- dispatch. If an optimizer unrolls the loop, it may then be statically --- determined, and no dispatching will occur. Either interpretation is --- correct. - for Knob in Lamps'Range loop - Switch.Flip( Lamps(Knob).all ); - end loop; - TCTouch.Validate( "AGBAKGBA", "Allocated Objects" ); - --- Check use of static tagged declared objects, --- calling non-primitive functions. - if not Switch.TC_Non_Disp( A_Switch ) then - Report.Failed( "Bad Value 1" ); - end if; - TCTouch.Validate( "X", "Nonprimitive Function" ); - - if not Switch.TC_Non_Disp( A_Dimmer ) then - Report.Failed( "Bad Value 2" ); - end if; - TCTouch.Validate( "Y", "Nonprimitive Function" ); - - if not Switch.TC_Non_Disp( An_Autodim ) then - Report.Failed( "Bad Value 3" ); - end if; - TCTouch.Validate( "Z", "Nonprimitive Function" ); - - A_Switch := Switch.Create; - A_Dimmer := Switch.Create; - An_Autodim := Switch.Create; - TCTouch.Validate( "123", "Primitive Function" ); - --- View conversions - Switch.Brighten( An_Autodim, 50 ); - - Switch.Flip( Switch.Toggle( A_Switch ) ); - Switch.Flip( Switch.Toggle( A_Dimmer ) ); - Switch.Flip( Switch.Dimmer( An_Autodim ) ); - TCTouch.Validate( "DAAGBA", "View Conversions" ); - --- statically tagged controlling operands (specific types) provided to --- class-wide functions - if Switch.On( A_Switch ) - or Switch.On( A_Dimmer ) - or Switch.On( An_Autodim ) then - Report.Failed( "Bad Value 4" ); - end if; - TCTouch.Validate( "BBB", "Class-wide" ); - --- statically tagged controlling operands qualified expressions provided to --- primitive functions, also using context to determine call to a --- class-wide function. - if Switch.Off( Switch.Toggle'( Switch.Create ) ) - or else Switch.Off( Switch.Dimmer'( Switch.Create ) ) - or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then - Report.Failed( "Bad Value 5" ); - end if; - TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" ); - - Report.Result; - -end C392C05; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c07.a b/gcc/testsuite/ada/acats/tests/c3/c392c07.a deleted file mode 100644 index f13cc0b01a0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392c07.a +++ /dev/null @@ -1,190 +0,0 @@ --- C392C07.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 for a call to a dispatching subprogram the subprogram --- body which is executed is determined by the controlling tag for --- the case where the call has dynamic tagged controlling operands --- of the type T. Check for calls to these same subprograms where --- the operands are of specific statically tagged types: --- objects (declared or allocated), formal parameters, view --- conversions, and function calls (both primitive and non-primitive). --- --- TEST DESCRIPTION: --- This test uses foundation F392C00 to test the usages of statically --- tagged objects and values. This test is derived in part from --- C392C05. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 24 Oct 95 SAIC Updated for ACVC 2.0.1 --- ---! - -with Report; -with TCTouch; -with F392C00_1; -procedure C392C07 is -- Hardware_Store - package Switch renames F392C00_1; - - subtype Switch_Class is Switch.Toggle'Class; - - type Reference is access all Switch_Class; - - A_Switch : aliased Switch.Toggle; - A_Dimmer : aliased Switch.Dimmer; - An_Autodim : aliased Switch.Auto_Dimmer; - - type Light_Bank is array(Positive range <>) of Reference; - - Lamps : Light_Bank(1..3); - --- dynamically tagged controlling operands : class wide formal parameters - procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is - begin - if Switch.On( Device ) /= On then - Switch.Flip( Device ); - end if; - end Clamp; - function Class_Item(Bank_Pos: Positive) return Switch_Class is - begin - return Lamps(Bank_Pos).all; - end Class_Item; - -begin -- Main test procedure. - Report.Test ("C392C07", "Check that a dispatching subprogram call is " - & "determined by the controlling tag for " - & "dynamically tagged controlling operands" ); - - Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access ); - --- dynamically tagged operands referring to --- statically tagged declared objects - for Knob in Lamps'Range loop - Clamp( Lamps(Knob).all, On => True ); - end loop; - TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" ); - - Lamps(1) := new Switch.Toggle; - Lamps(2) := new Switch.Dimmer; - Lamps(3) := new Switch.Auto_Dimmer; - --- turn the full bank of switches ON --- dynamically tagged allocated objects - for Knob in Lamps'Range loop - Clamp( Lamps(Knob).all, On => True ); - end loop; - TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated"); - --- Double check execution correctness - if Switch.Off( Lamps(1).all ) - or Switch.Off( Lamps(2).all ) - or Switch.Off( Lamps(3).all ) then - Report.Failed( "Bad Value" ); - end if; - TCTouch.Validate( "CCC", "Class-wide"); - --- turn the full bank of switches OFF - for Knob in Lamps'Range loop - Switch.Flip( Lamps(Knob).all ); - end loop; - TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops"); - --- check switches for OFF --- a few function calls as operands - for Knob in Lamps'Range loop - if not Switch.Off( Class_Item(Knob) ) then - Report.Failed("At function tests, Switch not OFF"); - end if; - end loop; - TCTouch.Validate( "CCC", - "Using function returning class-wide type"); - --- Switches are all OFF now. --- dynamically tagged view conversion - Clamp( Switch_Class( A_Switch ) ); - Clamp( Switch_Class( A_Dimmer ) ); - Clamp( Switch_Class( An_Autodim ) ); - TCTouch.Validate( "BABGBABKGBA", "View Conversions" ); - --- dynamically tagged controlling operands : declared class wide objects --- calling primitive functions - declare - Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' ); - begin - Switch.Flip( Dine_O_Might ); - if Switch.On( Dine_O_Might ) then - Report.Failed( "Exploded at Dine_O_Might" ); - end if; - TCTouch.Validate( "WAB", "Dispatching function 1" ); - end; - - declare - Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' ); - begin - Switch.Flip( Dyne_A_Mite ); - if Switch.On( Dyne_A_Mite ) then - Report.Failed( "Exploded at Dyne_A_Mite" ); - end if; - TCTouch.Validate( "WGBAB", "Dispatching function 2" ); - end; - - declare - Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' ); - begin - Switch.Flip( Din_Um_Out ); - if Switch.Off( Din_Um_Out ) then - Report.Failed( "Exploded at Din_Um_Out" ); - end if; - TCTouch.Validate( "WKCC", "Dispatching function 3" ); - --- Non-dispatching function calls. - if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then - Report.Failed( "Non primitive, via view conversion" ); - end if; - TCTouch.Validate( "X", "View Conversion 1" ); - - if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then - Report.Failed( "Non primitive, via view conversion" ); - end if; - TCTouch.Validate( "Y", "View Conversion 2" ); - end; - - -- a few more function calls as operands (oops) - if not Switch.On( Switch.Toggle'( Switch.Create ) ) then - Report.Failed("Toggle did not create ""On"""); - end if; - - if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then - Report.Failed("Dimmer created ""Off"""); - end if; - - if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then - Report.Failed("Auto_Dimmer created ""Off"""); - end if; - - Report.Result; -end C392C07; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc/testsuite/ada/acats/tests/c3/c392d01.a deleted file mode 100644 index bb6e192028c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392d01.a +++ /dev/null @@ -1,324 +0,0 @@ --- C392D01.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, for an implicitly declared dispatching operation that is --- overridden, the body executed is the body for the overriding --- subprogram, even if the overriding occurs in a private part. --- Check that, for an implicitly declared dispatching operation that is --- NOT overridden, the body executed is the body of the corresponding --- subprogram of the parent type. --- --- Check for the case where the overriding (and non-overriding) operations --- are declared for a private extension (and its full type) in a public --- child unit of the package declaring the ancestor type, and the ancestor --- type is a tagged private type whose full view is itself a derived type. --- --- TEST DESCRIPTION: --- Consider: --- --- package Parent is --- type Root is tagged ... --- procedure Vis_Op (P: Root); --- private --- procedure Pri_Op (P: Root); -- (A) --- end Parent; --- --- package Intermediate is --- type Mid is tagged private; --- private --- type Mid is new Parent.Root with record ... --- -- Implicit Vis_Op (P: Mid) declared here. --- --- procedure Vis_Op (P: Mid); -- (B) --- end Intermediate; --- --- package Intermediate.Child is --- type Derived is new Mid with private; --- --- procedure Pri_Op (P: Derived); -- (C) --- ... --- --- private --- type Derived is new Mid with record... --- -- Implicit Vis_Op (P: Derived) declared here. --- ... --- end Intermediate.Child; --- --- Type Derived inherits Vis_Op from the parent type Mid. Note, however, --- that it is implicitly declared in the private part (inherited --- subprograms for a derived_type_definition -- in this case, the full --- type -- are implicitly declared at the earliest place within the --- immediate scope of the type_declaration where the corresponding --- declaration from the parent is visible). --- --- Because Parent.Pri_Op is never visible within the immediate scope --- of Mid, it is not implicitly declared for Mid. Thus, it is also not --- implicitly declared for Derived. As a result, the version of Pri_Op --- declared at (C) above does not override an inherited version of --- Parent.Pri_Op and is totally unrelated to it. --- --- Dispatching calls with tag Mid will execute (A) and (B). Dispatching --- calls with tag Derived from Parent will execute the bodies of (B) --- and (A). Dispatching calls with tag Derived from Parent.Child --- will execute the bodies of (B) and (C). --- --- TEST FILES: --- The following files comprise this test: --- --- F392D00.A --- C392D01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with F392D00; -package C392D01_0 is - - type Zoom_Camera is tagged private; - - procedure Self_Test (C : in out Zoom_Camera'Class); - - -- ...Additional operations. - - - function TC_Correct_Result (C : Zoom_Camera; - D : F392D00.Depth_Of_Field; - S : F392D00.Shutter_Speed) return Boolean; - -private - - type Magnification is (Low, Medium, High); - - type Zoom_Camera is new F392D00.Remote_Camera with record - Mag : Magnification; - end record; - - -- procedure Focus (C : in out Zoom_Camera; -- Implicitly - -- Depth : in Depth_Of_Field) -- declared - -- here. - - procedure Focus (C : in out Zoom_Camera; -- Overrides - Depth : in F392D00.Depth_Of_Field); -- inherited op. - - -- For the remote zoom camera, perhaps the focusing algorithm is different - -- in some way, so the original Focus operation is overridden here. - - -- Since the partial view is not an extension, the overriding operation - -- must be declared after the full type. This version of Focus, although - -- not visible for type Zoom_Camera from outside the package, can still be - -- dispatched to. - - - -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from - -- F392D00.Remote_Camera, but since the operation never becomes visible - -- within the immediate scope of Zoom_Camera, it is never implicitly - -- declared. - -end C392D01_0; - - - --==================================================================-- - - -package body C392D01_0 is - - procedure Focus (C : in out Zoom_Camera; - Depth : in F392D00.Depth_Of_Field) is - begin - -- Artificial for testing purposes. - C.DOF := 83; - end Focus; - - ----------------------------------------------------------- - -- Indirect call to F392D00.Self_Test since the main does not know - -- that Zoom_Camera is a private extension of F392D00.Basic_Camera. - procedure Self_Test (C : in out Zoom_Camera'Class) is - begin - F392D00.Self_Test (C); - -- ...Additional self-testing. - end Self_Test; - - ----------------------------------------------------------- - function TC_Correct_Result (C : Zoom_Camera; - D : F392D00.Depth_Of_Field; - S : F392D00.Shutter_Speed) return Boolean is - use type F392D00.Depth_Of_Field; - use type F392D00.Shutter_Speed; - begin - return (C.DOF = D and C.Shutter = S); - end TC_Correct_Result; - -end C392D01_0; - - - --==================================================================-- - - -with F392D00; -package C392D01_0.C392D01_1 is - - type Film_Speed is private; - - type Auto_Speed is new Zoom_Camera with private; - - -- Implicit function TC_Correct_Result (Auto_Speed) declared here. - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed); - - -- This version of Set_Shutter_Speed does NOT override the operation - -- inherited from Zoom_Camera, because the inherited operation is never - -- visible (and thus, is never implicitly declared) within the immediate - -- scope of type Auto_Speed. - - procedure Self_Test (C : in out Auto_Speed'Class); - - -- ...Other operations. - -private - type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); - - type Auto_Speed is new Zoom_Camera with record - ASA : Film_Speed; - end record; - - -- procedure Focus (C : in out Auto_Speed; -- Implicitly - -- Depth : in F392D00.Depth_Of_Field); -- declared - -- here. - -end C392D01_0.C392D01_1; - - - --==================================================================-- - - -package body C392D01_0.C392D01_1 is - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed) is - begin - -- Artificial for testing purposes. - C.Shutter := F392D00.Two_Fifty; - end Set_Shutter_Speed; - - ------------------------------------------------------- - procedure Self_Test (C : in out Auto_Speed'Class) is - begin - -- Artificial for testing purposes. - Set_Shutter_Speed (C, F392D00.Thousand); - Focus (C, 27); - end Self_Test; - -end C392D01_0.C392D01_1; - - - --==================================================================-- - - -with F392D00; -with C392D01_0.C392D01_1; - -with Report; - -procedure C392D01 is - Zooming_Camera : C392D01_0.Zoom_Camera; - Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed; - Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed; - - TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed - := F392D00.Thousand; - TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed - := F392D00.Thousand; - TC_Expected_Speed : constant F392D00.Shutter_Speed - := F392D00.Two_Fifty; - - use type F392D00.Depth_Of_Field; - use type F392D00.Shutter_Speed; - -begin - Report.Test ("C392D01", "Dispatching for overridden and non-overridden " & - "primitive subprograms: private extension declared in child " & - "unit, parent is tagged private whose full view is derived " & - "type"); - - - --- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which --- itself calls the class-wide operation for Remote_Camera'Class, which --- in turn makes dispatching calls to Focus and Set_Shutter_Speed: - - - -- For an object of type Zoom_Camera, the dispatching call to Focus should - -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching - -- to Set_Shutter_Speed should dispatch to the body declared for - -- Remote_Camera: - - C392D01_0.Self_Test(Zooming_Camera); - - if not C392D01_0.TC_Correct_Result (Zooming_Camera, - TC_Expected_Zoom_Depth, - TC_Expected_Zoom_Speed) - then - Report.Failed ("Calls dispatched incorrectly for tagged private type"); - end if; - - -- For an object of type Auto_Speed, the dispatching call to Focus should - -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching - -- call to Set_Shutter_Speed should dispatch to the body explicitly declared - -- for Remote_Camera: - - C392D01_0.Self_Test(Auto_Camera1); - - if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1, - TC_Expected_Auto_Depth, - TC_Expected_Auto_Speed) - then - Report.Failed ("Calls dispatched incorrectly for private extension"); - end if; - - -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call - -- to Focus which should dispatch to the body explicitly declared for - -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch - -- to the body explicitly declared for Auto_Speed: - - C392D01_0.C392D01_1.Self_Test(Auto_Camera2); - - if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2, - TC_Expected_Depth, - TC_Expected_Speed) - then - Report.Failed ("Call to explicit subprogram executed the wrong body"); - end if; - - Report.Result; - -end C392D01; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d02.a b/gcc/testsuite/ada/acats/tests/c3/c392d02.a deleted file mode 100644 index d8e012cbe2d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392d02.a +++ /dev/null @@ -1,185 +0,0 @@ --- C392D02.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 primitive procedure declared in a private part is not --- overridden by a procedure explicitly declared at a place where the --- primitive procedure in question is not visible. --- --- Check for the case where the non-overriding operation is declared in a --- separate (non-child) package from that declaring the parent type, and --- the descendant type is a record extension. --- --- TEST DESCRIPTION: --- Consider: --- --- package P is --- type Root is tagged ... --- private --- procedure Pri_Op (A: Root); --- end P; --- --- with P; --- package Q is --- type Derived is new P.Root with record... --- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op. --- ... --- end Q; --- --- Type Derived inherits Pri_Op from the parent type Root. However, --- because P.Pri_Op is never visible within the immediate scope of --- Derived, it is not implicitly declared for Derived. As a result, --- the explicit Q.Pri_Op does not override P.Pri_Op and is totally --- unrelated to it. --- --- Dispatching calls to P.Pri_Op with operands of tag Derived will --- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op. --- --- TEST FILES: --- The following files comprise this test: --- --- F392D00.A --- C392D02.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with F392D00; -package C392D02_0 is - - type Aperture is (Eight, Sixteen); - - type Auto_Speed is new F392D00.Remote_Camera with record - -- ... - FStop : Aperture; - end record; - - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed); - -- Does NOT override. - - -- This version of Set_Shutter_Speed does NOT override the operation - -- inherited from the parent, because the inherited operation is never - -- visible (and thus, is never implicitly declared) within the immediate - -- scope of type Auto_Speed. - - procedure Self_Test (C : in out Auto_Speed'Class); - - -- ...Other operations. - -end C392D02_0; - - - --==================================================================-- - - -package body C392D02_0 is - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed) is - begin - -- Artificial for testing purposes. - C.Shutter := F392D00.Four_Hundred; - end Set_Shutter_Speed; - - ---------------------------------------------------- - procedure Self_Test (C : in out Auto_Speed'Class) is - begin - -- Should dispatch to the Set_Shutter_Speed explicitly declared - -- for Auto_Speed. - Set_Shutter_Speed (C, F392D00.Two_Fifty); - end Self_Test; - -end C392D02_0; - - - --==================================================================-- - - -with F392D00; -with C392D02_0; - -with Report; - -procedure C392D02 is - Basic_Camera : F392D00.Remote_Camera; - Auto_Camera1 : C392D02_0.Auto_Speed; - Auto_Camera2 : C392D02_0.Auto_Speed; - - TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed - := F392D00.Thousand; - TC_Expected_Speed : constant F392D00.Shutter_Speed - := F392D00.Four_Hundred; - - use type F392D00.Shutter_Speed; - -begin - Report.Test ("C392D02", "Dispatching for non-overridden primitive " & - "subprograms: record extension declared in non-child " & - "package, parent is tagged record"); - --- Call the class-wide operation for Remote_Camera'Class, which dispatches --- to Set_Shutter_Speed: - - -- For an object of type Remote_Camera, the dispatching call should - -- dispatch to the body declared for the root type: - - F392D00.Self_Test(Basic_Camera); - - if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then - Report.Failed ("Call dispatched incorrectly for root type"); - end if; - - - -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test, - -- since C392D02_0.Set_Shutter_Speed does not override - -- F392D00.Set_Shutter_Speed. - - -- For an object of type Auto_Speed, the dispatching call should - -- also dispatch to the body declared for the root type: - - F392D00.Self_Test(Auto_Camera1); - - if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then - Report.Failed ("Call dispatched incorrectly for derived type"); - end if; - - -- Call to Self_Test from C392D02_0 invokes the dispatching call to - -- Set_Shutter_Speed which should dispatch to the body explicitly declared - -- for Auto_Speed: - - C392D02_0.Self_Test(Auto_Camera2); - - if Auto_Camera2.Shutter /= TC_Expected_Speed then - Report.Failed ("Call to explicit subprogram executed the wrong body"); - end if; - - Report.Result; - -end C392D02; diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d03.a b/gcc/testsuite/ada/acats/tests/c3/c392d03.a deleted file mode 100644 index 3a488952e96..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392d03.a +++ /dev/null @@ -1,248 +0,0 @@ --- C392D03.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, for an inherited dispatching operation that is overridden, --- the body executed is the body of the overriding subprogram, even if --- the overriding occurs in a private part. --- --- Check for the case where the overriding operation is declared in a --- separate (non-child) package from that declaring the parent type, and --- the descendant type is a record extension. --- --- Check for both dispatching and nondispatching calls. --- --- TEST DESCRIPTION: --- Consider: --- --- package P is --- type Root is tagged ... --- procedure Op (A: Root); --- end P; --- --- with P; --- package Q is --- type Derived1 is new P.Root with record... --- -- Implicit procedure Op (A: Derived1) declared here. --- type Derived2 is new P.Root with private... --- -- Implicit procedure Op (A: Derived2) declared here. --- type New_Derived is new Derived1 with private... --- -- Implicit procedure Op (A: New_Derived) declared here. --- private --- procedure Op (A: Derived1); -- Overrides parent's Op. --- type Derived2 is new P.Root with record... --- procedure Op (A: Derived2); -- Overrides parent's Op. --- type New_Derived is new Derived1 with record... --- ... --- end Q; --- --- Both type Derived1 and Derived2 inherit Op from the parent type Root. --- Type New_Derived inherits (inherited) Op from Derived1. The inherited --- operation is implicitly declared immediately after the type extension. --- The inherited operation is overridden by an explicit declaration in --- the private part. Even though the overriding operation is private, --- calls to Op with an operand of tag Derived1, Derived2, or New_Derived --- will execute the body of the overriding operation. --- --- TEST FILES: --- The following files comprise this test: --- --- F392D00.A --- C392D03.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with F392D00; -package C392D03_0 is - - type Aperture is (Eight, Sixteen); - - type Auto_Focus is new F392D00.Remote_Camera with record - -- ... - FStop : Aperture; - end record; - - -- Implicit procedure Focus (C : in out Auto_Focus; - -- Depth : in Depth_Of_Field) declared here. - - type Auto_Flashing is new F392D00.Remote_Camera with private; - - -- Implicit procedure Focus (C : in out Auto_Flashing; - -- Depth : in Depth_Of_Field) declared here. - - type Special_Focus is new Auto_Focus with private; - - -- Implicit procedure Focus (C : in out Special_Focus; - -- Depth : in Depth_Of_Field) declared here. - - -- ...Other operations. - -private - - procedure Focus (C : in out Auto_Focus; -- Overrides - Depth : in F392D00.Depth_Of_Field); -- parent's op. - - -- For the improved remote camera, focus is set automatically, so it is - -- declared as a private operation. - - type Auto_Flashing is new F392D00.Remote_Camera with null record; - - procedure Focus (C : in out Auto_Flashing; -- Overrides - Depth : in F392D00.Depth_Of_Field); -- parent's op. - - type Special_Focus is new Auto_Focus with null record; - -end C392D03_0; - - - --==================================================================-- - - -package body C392D03_0 is - - procedure Focus (C : in out Auto_Focus; - Depth : in F392D00.Depth_Of_Field) is - begin - -- Artificial for testing purposes. - C.DOF := 52; - end Focus; - - ----------------------------------------------------------- - procedure Focus (C : in out Auto_Flashing; - Depth : in F392D00.Depth_Of_Field) is - begin - -- Artificial for testing purposes. - C.DOF := 91; - end Focus; - -end C392D03_0; - - - --==================================================================-- - - -with F392D00; -with C392D03_0; - -with Report; - -procedure C392D03 is - - type Focus_Ptr is access procedure - (P1 : in out C392D03_0.Auto_Focus; - P2 : in F392D00.Depth_Of_Field); - - Basic_Camera : F392D00.Remote_Camera; - Auto_Camera1 : C392D03_0.Auto_Focus; - Auto_Camera2 : C392D03_0.Auto_Focus; - Flash_Camera1 : C392D03_0.Auto_Flashing; - Flash_Camera2 : C392D03_0.Auto_Flashing; - Special_Camera : C392D03_0.Special_Focus; - Auto_Depth : F392D00.Depth_Of_Field := 78; - - TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46; - TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52; - TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91; - - FP : Focus_Ptr := C392D03_0.Focus'Access; - - use type F392D00.Depth_Of_Field; - -begin - Report.Test ("C392D03", "Dispatching for overridden primitive " & - "subprograms: record extension declared in non-child " & - "package, parent is tagged record"); - - --- Call the class-wide operation for Remote_Camera'Class, which itself makes --- a dispatching call to Focus: - - -- For an object of type Remote_Camera, the dispatching call should - -- dispatch to the body declared for the root type: - - F392D00.Self_Test(Basic_Camera); - - if Basic_Camera.DOF /= TC_Expected_Basic_Depth then - Report.Failed ("Call dispatched incorrectly for root type"); - end if; - - - -- For an object of type Auto_Focus, the dispatching call should - -- dispatch to the body declared for the derived type: - - F392D00.Self_Test(Auto_Camera1); - - if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then - Report.Failed ("Call dispatched incorrectly for Auto_Focus type"); - end if; - - - -- For an object of type Auto_Flash, the dispatching call should - -- also dispatch to the body declared for the derived type: - - F392D00.Self_Test(Flash_Camera1); - - if Flash_Camera1.DOF /= TC_Expected_Depth then - Report.Failed ("Call dispatched incorrectly for Auto_Flash type"); - end if; - - -- For an object of Auto_Flash type, a non-dispatching call to Focus should - -- execute the body declared for the derived type (even through it is - -- declared in the private part). - - C392D03_0.Focus (Flash_Camera2, Auto_Depth); - - if Flash_Camera2.DOF /= TC_Expected_Depth then - Report.Failed ("Non-dispatching call to privately overriding " & - "subprogram executed the wrong body"); - end if; - - -- For an object of Auto_Focus type, a non-dispatching call to Focus should - -- execute the body declared for the derived type (even through it is - -- declared in the private part). - - FP.all (Auto_Camera2, Auto_Depth); - - if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then - Report.Failed ("Non-dispatching call by using access to overriding " & - "subprogram executed the wrong body"); - end if; - - -- For an object of type Special_Camera, the dispatching call should - -- also dispatch to the body declared for the derived type: - - F392D00.Self_Test(Special_Camera); - - if Special_Camera.DOF /= TC_Expected_Auto_Depth then - Report.Failed ("Call dispatched incorrectly for Special_Camera type"); - end if; - - Report.Result; - -end C392D03; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393001.a b/gcc/testsuite/ada/acats/tests/c3/c393001.a deleted file mode 100644 index 9d6f85c6392..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393001.a +++ /dev/null @@ -1,407 +0,0 @@ --- C393001.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 abstract type can be declared, and in turn concrete --- types can be derived from it. Check that the definition of --- actual subprograms associated with the derived types dispatch --- correctly. --- --- TEST DESCRIPTION: --- This test declares an abstract type Breaker in a package, and --- then derives from it. The type Basic_Breaker defines the least --- possible in order to not be abstract. The type Ground_Fault is --- defined to inherit as much as possible, whereas type Special_Breaker --- overrides everything it can. The type Special_Breaker also includes --- an embedded Basic_Breaker object. The main program then utilizes --- each of the three types of breaker, and to ascertain that the --- overloading and tagging resolution are correct, each "Create" --- procedure is called with a unique value. The diagram below --- illustrates the relationships. This test is derived from C3A2001. --- --- Abstract type: Breaker --- | --- Basic_Breaker (Short) --- / \ --- (Sharp) Ground_Fault Special_Breaker (Shock) --- --- Test structure is an array of class-wide objects, modeling a circuit --- as a list of components. The test then creates some values, and --- traverses the list to determine correct operation. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 13 Nov 95 SAIC Revised for 2.0.1 --- ---! - ------------------------------------------------------------------ C393001_1 - -with Report; -package C393001_1 is - - type Breaker is abstract tagged private; - type Status is ( Power_Off, Power_On, Tripped, Failed ); - - procedure Flip ( The_Breaker : in out Breaker ) is abstract; - procedure Trip ( The_Breaker : in out Breaker ) is abstract; - procedure Reset( The_Breaker : in out Breaker ) is abstract; - procedure Fail ( The_Breaker : in out Breaker ); - - procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); - - function Status_Of( The_Breaker : Breaker ) return Status; - -private - type Breaker is abstract tagged record - State : Status := Power_Off; - end record; -end C393001_1; - -with TCTouch; -package body C393001_1 is - procedure Fail( The_Breaker : in out Breaker ) is ------------------- a - begin - TCTouch.Touch( 'a' ); - The_Breaker.State := Failed; - end Fail; - - procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is - begin - The_Breaker.State := To_State; - end Set; - - function Status_Of( The_Breaker : Breaker ) return Status is ------- b - begin - TCTouch.Touch( 'b' ); - return The_Breaker.State; - end Status_Of; -end C393001_1; - ------------------------------------------------------------------ C393001_2 - -with C393001_1; -package C393001_2 is - - type Basic_Breaker is new C393001_1.Breaker with private; - - type Voltages is ( V12, V110, V220, V440 ); - type Amps is ( A1, A5, A10, A25, A100 ); - - function Construct( Voltage : Voltages; Amperage : Amps ) - return Basic_Breaker; - - procedure Flip ( The_Breaker : in out Basic_Breaker ); - procedure Trip ( The_Breaker : in out Basic_Breaker ); - procedure Reset( The_Breaker : in out Basic_Breaker ); -private - type Basic_Breaker is new C393001_1.Breaker with record - Voltage_Level : Voltages := V110; - Amperage : Amps; - end record; -end C393001_2; - -with TCTouch; -package body C393001_2 is - function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c - return Basic_Breaker is - It : Basic_Breaker; - begin - TCTouch.Touch( 'c' ); - It.Amperage := Amperage; - It.Voltage_Level := Voltage; - C393001_1.Set( It, C393001_1.Power_Off ); - return It; - end Construct; - - procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d - begin - TCTouch.Touch( 'd' ); - case Status_Of( The_Breaker ) is - when C393001_1.Power_Off => - C393001_1.Set( The_Breaker, C393001_1.Power_On ); - when C393001_1.Power_On => - C393001_1.Set( The_Breaker, C393001_1.Power_Off ); - when C393001_1.Tripped | C393001_1.Failed => null; - end case; - end Flip; - - procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e - begin - TCTouch.Touch( 'e' ); - C393001_1.Set( The_Breaker, C393001_1.Tripped ); - end Trip; - - procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f - begin - TCTouch.Touch( 'f' ); - case Status_Of( The_Breaker ) is - when C393001_1.Power_Off | C393001_1.Tripped => - C393001_1.Set( The_Breaker, C393001_1.Power_On ); - when C393001_1.Power_On | C393001_1.Failed => null; - end case; - end Reset; - -end C393001_2; - -with C393001_1,C393001_2; -package C393001_3 is - - type Ground_Fault is new C393001_2.Basic_Breaker with private; - - function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps -) - return Ground_Fault; - - procedure Set_Trip( The_Breaker : in out Ground_Fault; - Capacitance : in Integer ); - -private - type Ground_Fault is new C393001_2.Basic_Breaker with record - Capacitance : Integer; - end record; -end C393001_3; - ------------------------------------------------------------------ C393001_3 - -with TCTouch; -package body C393001_3 is - - function Construct( Voltage : C393001_2.Voltages; ------------------ g - Amperage : C393001_2.Amps ) - return Ground_Fault is - - It : Ground_Fault; - - procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is - begin - It := C393001_2.Construct( Voltage, Amperage ); - end Set_Root; - - begin - TCTouch.Touch( 'g' ); - Set_Root( C393001_2.Basic_Breaker( It ) ); - It.Capacitance := 0; - return It; - end Construct; - - procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h - Capacitance : in Integer ) is - begin - TCTouch.Touch( 'h' ); - The_Breaker.Capacitance := Capacitance; - end Set_Trip; - -end C393001_3; - ------------------------------------------------------------------ C393001_4 - -with C393001_1, C393001_2; -package C393001_4 is - - type Special_Breaker is new C393001_2.Basic_Breaker with private; - - function Construct( Voltage : C393001_2.Voltages; - Amperage : C393001_2.Amps ) - return Special_Breaker; - - procedure Flip ( The_Breaker : in out Special_Breaker ); - procedure Trip ( The_Breaker : in out Special_Breaker ); - procedure Reset( The_Breaker : in out Special_Breaker ); - procedure Fail ( The_Breaker : in out Special_Breaker ); - - function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status; - function On_Backup( The_Breaker : Special_Breaker ) return Boolean; - -private - type Special_Breaker is new C393001_2.Basic_Breaker with record - Backup : C393001_2.Basic_Breaker; - end record; -end C393001_4; - -with TCTouch; -package body C393001_4 is - - function Construct( Voltage : C393001_2.Voltages; --------------- i - Amperage : C393001_2.Amps ) - return Special_Breaker is - It: Special_Breaker; - procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is - begin - It := C393001_2.Construct( Voltage, Amperage ); - end Set_Root; - begin - TCTouch.Touch( 'i' ); - Set_Root( C393001_2.Basic_Breaker( It ) ); - Set_Root( It.Backup ); - return It; - end Construct; - - function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status - renames C393001_1.Status_Of; - - procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j - begin - TCTouch.Touch( 'j' ); - case Status_Of( C393001_1.Breaker( The_Breaker )) is - when C393001_1.Power_Off | C393001_1.Power_On => - C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) ); - when others => - C393001_2.Flip( The_Breaker.Backup ); - end case; - end Flip; - - procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k - begin - TCTouch.Touch( 'k' ); - case Status_Of( C393001_1.Breaker( The_Breaker )) is - when C393001_1.Power_Off => null; - when C393001_1.Power_On => - C393001_2.Reset( The_Breaker.Backup ); - C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) ); - when others => - C393001_2.Trip( The_Breaker.Backup ); - end case; - end Trip; - - procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l - begin - TCTouch.Touch( 'l' ); - case Status_Of( C393001_1.Breaker( The_Breaker )) is - when C393001_1.Tripped => - C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker )); - when C393001_1.Failed => - C393001_2.Reset( The_Breaker.Backup ); - when C393001_1.Power_On | C393001_1.Power_Off => - null; - end case; - end Reset; - - procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m - begin - TCTouch.Touch( 'm' ); - case Status_Of( C393001_1.Breaker( The_Breaker )) is - when C393001_1.Failed => - C393001_2.Fail( The_Breaker.Backup ); - when others => - C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker )); - C393001_2.Reset( The_Breaker.Backup ); - end case; - end Fail; - - function Status_Of( The_Breaker : Special_Breaker ) ----------------- n - return C393001_1.Status is - begin - TCTouch.Touch( 'n' ); - case Status_Of( C393001_1.Breaker( The_Breaker )) is - when C393001_1.Power_On => return C393001_1.Power_On; - when C393001_1.Power_Off => return C393001_1.Power_Off; - when others => - return C393001_2.Status_Of( The_Breaker.Backup ); - end case; - end Status_Of; - - function On_Backup( The_Breaker : Special_Breaker ) return Boolean is - use C393001_2; - use type C393001_1.Status; - begin - return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped - or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed; - end On_Backup; - -end C393001_4; - -------------------------------------------------------------------- C393001 - -with Report, TCTouch; -with C393001_1, C393001_2, C393001_3, C393001_4; -procedure C393001 is - - procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is - begin - C393001_1.Flip( The_Circuit ); - end Flipper; - - procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is - begin - C393001_1.Trip( The_Circuit ); - end Tripper; - - procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is - begin - C393001_1.Reset( The_Circuit ); - end Restore; - - procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is - begin - C393001_1.Fail( The_Circuit ); - end Failure; - - Short : C393001_1.Breaker'Class -- Basic_Breaker - := C393001_2.Construct( C393001_2.V440, C393001_2.A5 ); - Sharp : C393001_1.Breaker'Class -- Ground_Fault - := C393001_3.Construct( C393001_2.V110, C393001_2.A1 ); - Shock : C393001_1.Breaker'Class -- Special_Breaker - := C393001_4.Construct( C393001_2.V12, C393001_2.A100 ); - -begin -- Main test procedure. - - Report.Test ("C393001", "Check that an abstract type can be declared " & - "and used. Check actual subprograms dispatch correctly" ); - - TCTouch.Validate( "cgcicc", "Declaration" ); - - Flipper( Short ); - TCTouch.Validate( "db", "Flipping Short" ); - Flipper( Sharp ); - TCTouch.Validate( "db", "Flipping Sharp" ); - Flipper( Shock ); - TCTouch.Validate( "jbdb", "Flipping Shock" ); - - Tripper( Short ); - TCTouch.Validate( "e", "Tripping Short" ); - Tripper( Sharp ); - TCTouch.Validate( "e", "Tripping Sharp" ); - Tripper( Shock ); - TCTouch.Validate( "kbfbe", "Tripping Shock" ); - - Restore( Short ); - TCTouch.Validate( "fb", "Restoring Short" ); - Restore( Sharp ); - TCTouch.Validate( "fb", "Restoring Sharp" ); - Restore( Shock ); - TCTouch.Validate( "lbfb", "Restoring Shock" ); - - Failure( Short ); - TCTouch.Validate( "a", "Shock Failing" ); - Failure( Sharp ); - TCTouch.Validate( "a", "Shock Failing" ); - Failure( Shock ); - TCTouch.Validate( "mbafb", "Shock Failing" ); - - Report.Result; - -end C393001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393007.a b/gcc/testsuite/ada/acats/tests/c3/c393007.a deleted file mode 100644 index 93458eeffb8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393007.a +++ /dev/null @@ -1,157 +0,0 @@ --- C393007.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived from an abstract type, --- where the abstract type is defined in a package, and the type derived --- from it is defined in a distinct library package. --- --- TEST DESCRIPTION: --- Declare an private (abstract) type; declare two primitive operations --- of the type that are explicitly abstract. --- Derive an extended type from the (private) abstract type, overriding --- both of the primitive operations. --- This test also checks to see that name overloading between abstract --- and non-abstract functions is resolved correctly. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - package C393007_0 is - -- Alert_System - - type DT_Type is new Integer; - - type Alert_Type is abstract tagged record - Time_Of_Arrival : DT_Type; - end record; - - type Log_File_Type is range 0 .. 100; - - Procedure Handle (A : in out Alert_type) is abstract; - - procedure Log (A : Alert_Type; - L : in out Log_File_Type) is abstract; - - procedure Set_Time (A : in out Alert_Type); - - function Correct_Time_Stamp (A : Alert_Type) return Boolean; - - Day_Time : DT_Type := 100; - - end C393007_0; - -- Alert_System; - - --=======================================================================-- - - package body C393007_0 is - -- Alert_System - - function Time_Stamp return DT_Type is - begin - Day_Time := Day_Time + 1; - return Day_Time; - end Time_Stamp; - - procedure Set_Time (A : in out Alert_Type) is - begin - A.Time_Of_Arrival := Time_Stamp; - end Set_time; - - function Correct_Time_Stamp ( A : Alert_Type) return Boolean is - begin - return (A.Time_Of_Arrival = Day_Time); - end Correct_Time_Stamp; - - end C393007_0; - -- Alert_System; - - --=======================================================================-- - - with Report; - with C393007_0; - -- Alert_system; - - package C393007_1 is - - type Normal_Alert_Type is - new C393007_0.Alert_Type - with null record; - - Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First; - - procedure Handle (A : in out Normal_Alert_Type); -- Override is required - - procedure Log (A : Normal_Alert_Type; -- Override is required - L : in out C393007_0.Log_File_Type); - end C393007_1; - - package body C393007_1 is - use type C393007_0.Log_File_Type; - - procedure Handle (A : in out Normal_Alert_Type) is - begin - Set_Time (A); - Log (A, Log_File); - end Handle; - - procedure Log (A : Normal_Alert_Type; - L : in out C393007_0.Log_File_Type) is - begin - L := C393007_0."+"(L, 1); - end Log; - - end C393007_1; - - with Report; - with C393007_0; - with C393007_1; - -- Alert_system; - - procedure C393007 is - use C393007_0; - use C393007_1; - - Alert_One : C393007_1.Normal_Alert_Type; - - begin - Report.Test ("C393007", "Check that an extended type can be derived " & - "from an abstract type"); - - Handle (Alert_One); - if not Correct_Time_Stamp (Alert_One) then - Report.Failed ("Wrong results from procedure Handle"); - end if; - - if Log_File /=1 then - Report.Failed ("Wrong results"); - end if; - - Report.Result; - - end C393007; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393008.a b/gcc/testsuite/ada/acats/tests/c3/c393008.a deleted file mode 100644 index d2d2aefed92..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393008.a +++ /dev/null @@ -1,204 +0,0 @@ --- C393008.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived from an abstract type. --- --- TEST DESCRIPTION: --- Declare a tagged record; declare an abstract --- primitive operation and a non-abstract primitive operation of the --- type. Derive an extended type from it, including a new component. --- Use the derived type, the overriding operation and the inherited --- operation to instantiate a generic package. The overriding operation --- calls a new primitive operation and an inherited operation [so the --- instantiation must get this sorted out correctly]. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; -with TCTouch; -procedure C393008 is - -package C393008_0 is - - type Status_Enum is (No_Status, Handled, Unhandled, Pending); - - type Alert_Type is abstract tagged record - Status : Status_Enum; - Reply : Boolean; - Urgent : Boolean; - end record; - - subtype Serial_Number is Integer range 0..Integer'last; - Serial_Num : Serial_Number := 0; - - procedure Handle (A : in out Alert_Type) is abstract; - -- abstract primitive operation - - -- the procedure Init would be _nice_ have this procedure be non_abstract - -- and create a "base" object with a "null" constraint. The language - -- will not allow this due to the restriction that an object of an - -- abstract type cannot be created. Hence Init must be abstract, - -- requiring any type derived directly from Alert_Type to declare - -- an Init. - -- - -- In light of this, I have changed init to a function to more closely - -- model the typical usage of OO features... - - function Init return Alert_Type is abstract; - - procedure No_Reply (A : in out Alert_Type); - -end C393008_0; - ---=======================================================================-- - -package body C393008_0 is - - procedure No_Reply (A : in out Alert_Type) is - begin -- primitive operation, not abstract - TCTouch.Touch('A'); ------------------------------------------------- A - if A.Status = Handled then - A.Reply := False; - end if; - end No_Reply; - -end C393008_0; - ---=======================================================================-- - - generic - -- pass in the Alert_Type object, including its - -- operations - type Data_Type is new C393008_0.Alert_Type with private; - -- note that Alert_Type is abstract, so it may not be - -- used as an actual parameter - with procedure Update (P : in out Data_Type) is <>; -- generic formal - with function Initialize return Data_Type is <>; -- generic formal - - package C393008_1 is - -- Utilities - - procedure Modify (Item : in out Data_Type); - - end C393008_1; - -- Utilities - ---=======================================================================-- - - package body C393008_1 is - -- Utilities - - procedure Modify (Item : in out Data_Type) is - begin - TCTouch.Touch('B'); --------------------------------------------- B - Item := Initialize; - Update (Item); - end Modify; - - end C393008_1; - ---=======================================================================-- - - package C393008_2 is - - type Low_Alert_Type is new C393008_0.Alert_Type with record - Serial : C393008_0.Serial_Number; - end record; - - procedure Serialize (LA : in out Low_Alert_Type); - - -- inherit No_Reply - - procedure Handle (LA : in out Low_Alert_Type); - - function Init return Low_Alert_Type; - end C393008_2; - - package body C393008_2 is - procedure Serialize (LA : in out Low_Alert_Type) is - begin -- new primitive operation - TCTouch.Touch('C'); ------------------------------------------------- C - C393008_0.Serial_Num := C393008_0.Serial_Num + 1; - LA.Serial := C393008_0.Serial_Num; - end Serialize; - - -- inherit No_Reply - - function Init return Low_Alert_Type is - TA: Low_Alert_Type; - begin - TCTouch.Touch('D'); ------------------------------------------------- D - Serialize( TA ); - TA.Status := C393008_0.No_Status; - return TA; - end Init; - - procedure Handle (LA : in out Low_Alert_Type) is - begin -- overrides abstract inherited Handle - TCTouch.Touch('E'); ------------------------------------------------- E - Serialize (LA); - LA.Reply := False; - LA.Status := C393008_0.Handled; - No_Reply (LA); - end Handle; - - end C393008_2; - - use C393008_2; - - package Alert_Utilities is new - C393008_1 (Data_Type => Low_Alert_Type, - Update => Handle, -- Low_Alert's Handle - Initialize => Init); -- inherited from Alert - - Item : Low_Alert_Type; - - use type C393008_0.Status_Enum; - -begin - - Report.Test ("C393008", "Check that an extended type can be derived "& - "from an abstract type"); - - Item := Init; - if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1) then - Report.Failed ("Wrong initialization"); - end if; - TCTouch.Validate("DC", "Initialization Call"); - - Alert_Utilities.Modify (Item); - if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then - Report.Failed ("Wrong results from Modify"); - end if; - TCTouch.Validate("BDCECA", "Generic Instance Call"); - - Report.Result; - -end C393008; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393009.a b/gcc/testsuite/ada/acats/tests/c3/c393009.a deleted file mode 100644 index 1353f9c37d4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393009.a +++ /dev/null @@ -1,170 +0,0 @@ --- C393009.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived from an abstract type. --- --- TEST DESCRIPTION: --- Declare an abstract type in the specification of a generic package. --- Instantiate the package and derive an extended type from the abstract --- (instantiated) type; override all abstract operations; use all --- inherited operations; --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Oct 95 SAIC Fixed for ACVC 2.0.1 --- ---! - -with Report; -procedure C393009 is - - package Display_Devices is - - type Display_Device_Enum is (None, TTY, Console, Big_Screen); - Display : Display_Device_Enum := None; - - end Display_Devices; - ---=======================================================================-- - - generic - - type Generic_Status is (<>); - - type Serial_Type is (<>); - - package Alert_System is - - type Alert_Type (Serial : Serial_Type) is abstract tagged record - Status : Generic_Status; - end record; - - Next_Serial_Number : Serial_Type := Serial_Type'First; - - procedure Handle (A : in out Alert_Type) is abstract; - -- abstract operation - must be overridden after instantiation - - procedure Display ( A : Alert_Type; - On : Display_Devices.Display_Device_Enum); - -- primitive operation of Alert_Type - -- not required to be overridden - - function Get_Serial_Number (A : Alert_Type) return Serial_Type; - -- primitive operation of Alert_Type - -- not required to be overridden - - end Alert_System; - ---=======================================================================-- - - package body Alert_System is - - procedure Display ( A : in Alert_Type; - On : Display_Devices.Display_Device_Enum) is - begin - Display_Devices.Display := On; - end Display; - - function Get_Serial_Number (A : Alert_Type) - return Serial_Type is - begin - return A.Serial; - end Get_Serial_Number; - - end Alert_System; - ---=======================================================================-- - - package NCC_1701 is - - type Status_Kind is (Green, Yellow, Red); - type Serial_Number_Type is new Integer range 1..Integer'Last; - - subtype Msg_Str is String (1..16); - Alert_Msg : Msg_Str := "C393009 passed."; - -- 123456789A123456 - - package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type); - - type New_Alert_Type(Serial : Serial_Number_Type) is - new Alert_Pkg.Alert_Type(Serial) with record - Message : Msg_Str; - end record; - - -- procedure Display is inherited by New_Alert_Type - - -- function Get_Serial_Number is inherited by New_Alert_Type - procedure Handle (NA : in out New_Alert_Type); -- must be overridden - procedure Init (NA : in out New_Alert_Type); -- new primitive - - NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number); - -- New_Alert_Type is not abstract, so an object of that - -- type may be declared - - end NCC_1701; - - package body NCC_1701 is - - procedure Handle (NA : in out New_Alert_Type) is - begin - NA.Message := Alert_Msg; - Display (NA, On => Display_Devices.TTY); - end Handle; - - procedure Init (NA : in out New_Alert_Type) is -- new primitive operation - begin -- for New_Alert_Type - NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' ')); - end Init; - - end NCC_1701; - - use NCC_1701; - use type Display_Devices.Display_Device_Enum; - -begin - - Report.Test ("C393009", "Check that an extended type can be derived " & - "from an abstract type"); - - Init (NA); - if (Get_Serial_Number (NA) /= 1) - or (NA.Status /= Green) - or (Display_Devices.Display /= Display_Devices.None) then - Report.Failed ("Wrong Initialization"); - end if; - - Handle (NA); - if (Get_Serial_Number (NA) /= 1) - or (NA.Status /= Green) - or (NA.Message /= Alert_Msg) - or (Display_Devices.Display /= Display_Devices.TTY) then - Report.Failed ("Wrong results from Handle"); - end if; - - Report.Result; - -end C393009; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393010.a b/gcc/testsuite/ada/acats/tests/c3/c393010.a deleted file mode 100644 index 6a52cf889a2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393010.a +++ /dev/null @@ -1,306 +0,0 @@ --- C393010.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived from an abstract type and --- that a call on an abstract operation is a dispatching operation. --- Check that such a call can dispatch to an overriding operation --- declared in the private part of a package. --- --- TEST DESCRIPTION: --- Taking from a classroom example of a typical usage: declare a basic --- abstract type containing data germane to the entire class structure, --- derive from that a type with specific data, and derive from that --- another type merely providing a "secret" override. The abstract type --- provides a concrete procedure that itself "redispatches" to an --- abstract procedure; the abstract procedure must be provided by one or --- more of the concrete types derived from the abstract type, and hence --- upon re-evaluating the actual type of the operand should dispatch --- accordingly. --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Mar 96 SAIC ACVC 2.1 --- ---! - ------------------------------------------------------------------ C393010_0 - -package C393010_0 is - - type Ticket is abstract tagged record - Flight : Natural; - Serial_Number : Natural; - end record; - - function Issue return Ticket is abstract; - procedure Label( T: Ticket ) is abstract; - - procedure Print( T: Ticket ); - -end C393010_0; - -with TCTouch; -package body C393010_0 is - - procedure Print( T: Ticket ) is - begin - -- Check that a call on an abstract operation is a dispatching operation - Label( Ticket'Class( T ) ); - -- Appropriate_IO.Put( T.Flight & T.Serial_Number ); - TCTouch.Touch('P'); -------------------------------------------------- P - end Print; - -end C393010_0; - ------------------------------------------------------------------ C393010_1 - -with C393010_0; -package C393010_1 is - - type Service_Classes is (First, Business, Coach); - - type Menu is (Steak, Lobster, Fowl, Vegan); - - -- Check that an extended type can be derived from an abstract type. - type Passenger_Ticket(Service : Service_Classes) is - new C393010_0.Ticket with record - Row_Seat : String(1..3); - case Service is - when First | Business => Meal : Menu; - when Coach => null; - end case; - end record; - - function Issue return Passenger_Ticket; - function Issue( Service : Service_Classes; - Flight : Natural; - Seat : String; - Meal : Menu := Fowl ) return Passenger_Ticket; - - procedure Label( T: Passenger_Ticket ); - - procedure Print( T: Passenger_Ticket ); - -end C393010_1; - -with TCTouch; -package body C393010_1 is - - procedure Label( T: Passenger_Ticket ) is - begin - -- Appropriate_IO.Put( T.Service ); - TCTouch.Touch('L'); -------------------------------------------------- L - end Label; - - procedure Print( T: Passenger_Ticket ) is - begin - -- call parent print: - C393010_0.Print( C393010_0.Ticket( T ) ); - case T.Service is - when First => -- Appropriate_IO.Put( Meal ); - TCTouch.Touch('F'); ---------------------------------------------- F - when Business => -- Appropriate_IO.Put( Meal ); - TCTouch.Touch('B'); ---------------------------------------------- B - when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" ); - TCTouch.Touch('C'); ---------------------------------------------- C - end case; - end Print; - - Num : Natural := 1000; - - function Issue( Service : Service_Classes; - Flight : Natural; - Seat : String; - Meal : Menu := Fowl ) return Passenger_Ticket is - begin - Num := Num +1; - case Service is - when First => - return Passenger_Ticket'(Service => First, Flight => Flight, - Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); - when Business => - return Passenger_Ticket'(Service => Business, Flight => Flight, - Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); - when Coach => - return Passenger_Ticket'(Service => Coach, Flight => Flight, - Row_Seat => Seat, Serial_Number => Num ); - end case; - end Issue; - - function Issue return Passenger_Ticket is - begin - return Issue( Coach, 0, "non" ); - end Issue; - -end C393010_1; - ------------------------------------------------------------------ C393010_1 - -with C393010_1; -package C393010_2 is - - type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) - with private; - - function Issue return Charter; - - -- procedure Print( T: Passenger_Ticket ); - -private - type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) - with null record; - - -- Check that the dispatching call to the abstract operation will dispatch - -- to a procedure defined in the private part of a package. - procedure Label( T: Charter ); - - -- an example of a required function the users shouldn't see: - function Issue( Service : C393010_1.Service_Classes; - Flight : Natural; - Seat : String; - Meal : C393010_1.Menu ) return Charter; - -end C393010_2; - -with TCTouch; -package body C393010_2 is - - procedure Label( T: Charter ) is - begin - -- Appropriate_IO.Put( "Excursion Fare" ); - TCTouch.Touch('X'); -------------------------------------------------- X - end Label; - - Num : Natural := 4000; - - function Issue return Charter is - begin - Num := Num +1; - return Charter'(Service => C393010_1.Coach, Flight => 1001, - Row_Seat => "OPN", Serial_Number => Num ); - end Issue; - - function Issue( Service : C393010_1.Service_Classes; - Flight : Natural; - Seat : String; - Meal : C393010_1.Menu ) return Charter is - begin - return Issue; - end Issue; - -end C393010_2; - ------------------------------------------------------------------ C393010_1 - -with Report; -with TCTouch; -with C393010_0; -with C393010_1; -with C393010_2; -- Charter Tours - -procedure C393010 is - - type Agents_Handle is access all C393010_0.Ticket'Class; - - type Itinerary; - - type Next_Leg is access Itinerary; - - type Itinerary is record - Leg : Agents_Handle; - Next : Next_Leg; - end record; - - function Travel_Agent_1 return Next_Leg is - begin - -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL - return new Itinerary'( - -- ORL -> JFK 01 12 2A First, Lobster - new C393010_1.Passenger_Ticket'( - C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )), - new Itinerary'( - -- JFK -> LAX 02 18 2B First, Steak - new C393010_1.Passenger_Ticket'( - C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )), - new Itinerary'( - -- LAX -> SAN 03 5225 34H Coach - new C393010_1.Passenger_Ticket'( - C393010_1.Issue(C393010_1.Coach, 5225, "34H")), - new Itinerary'( - -- SAN -> DFW 04 25 13A Business, Fowl - new C393010_1.Passenger_Ticket'( - C393010_1.Issue(C393010_1.Business, 25, "13A")), - new Itinerary'( - -- DFW -> ORL 05 15 1D First, Lobster - new C393010_1.Passenger_Ticket'( - C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )), - null ))))); - end Travel_Agent_1; - - function Travel_Agent_2 return Next_Leg is - begin - -- LAX -> NRT -> SYD -> LAX - return new Itinerary'( - new C393010_2.Charter'( C393010_2.Issue ), - new Itinerary'( - new C393010_2.Charter'( C393010_2.Issue ), - new Itinerary'( - new C393010_2.Charter'( C393010_2.Issue ), - new Itinerary'( - new C393010_2.Charter'( C393010_2.Issue ), - null )))); - end Travel_Agent_2; - - procedure Traveler( Pax_Tix : in Next_Leg ) is - Fly_Me : Next_Leg := Pax_Tix; - begin - -- a particularly consumptive process... - while Fly_Me /= null loop - C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test. - Fly_Me := Fly_Me.Next; - end loop; - end Traveler; - -begin - - Report.Test ("C393010", "Check that an extended type can be derived from " - & "an abstract type and that a call on an abstract " - & "operation is a dispatching operation. Check " - & "that such a call can dispatch to an overriding " - & "operation declared in the private part of a " - & "package" ); - - Traveler( Travel_Agent_1 ); - TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip"); - - Traveler( Travel_Agent_2 ); - TCTouch.Validate("XPCXPCXPCXPC","Second Trip"); - - Report.Result; - -end C393010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393011.a b/gcc/testsuite/ada/acats/tests/c3/c393011.a deleted file mode 100644 index 8741e87c1c4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393011.a +++ /dev/null @@ -1,220 +0,0 @@ --- C393011.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. ---* --- --- TEST OBJECTIVE: --- Check that an abstract extended type can be derived from an abstract --- type, and that a a non-abstract type may then be derived from the --- second abstract type. --- --- TEST DESCRIPTION: --- Define an abstract type with three primitive operations, two of them --- abstract. Derive an extended type from it, inheriting the non- --- abstract operation, overriding one of the abstract operations with --- a non-abstract operation, and overriding the other abstract operation --- with an abstract operation. The extended type is therefore abstract; --- derive an extended type from it. Override the abstract operation with --- a non-abstract operation; inherit one operation from the original --- abstract type, and inherit one operation from the intermediate --- abstract type. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - Package C393011_0 is - -- Definitions - - type Status_Enum is (None, Unhandled, Pending, Handled); - type Serial_Type is new Integer range 0 .. Integer'Last; - subtype Priority_Type is Integer range 0..10; - - type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen); - - Next : Serial_Type := 1; - Display_Device : Display_Enum := Bit_Bucket; - - end C393011_0; - -- Definitions; - - --=======================================================================-- - - with C393011_0; - -- Definitions - - Package C393011_1 is - -- Alert - - package Definitions renames C393011_0; - - type Alert_Type is abstract tagged record - Status : Definitions.Status_Enum := Definitions.None; - Serial_Num : Definitions.Serial_Type := 0; - Priority : Definitions.Priority_Type; - end record; - -- Alert_Type is an abstract type with - -- two operations to be overridden - - procedure Set_Status ( A : in out Alert_Type; -- not abstract - To : Definitions.Status_Enum); - - procedure Set_Serial ( A : in out Alert_Type) is abstract; - procedure Display ( A : Alert_Type) is abstract; - - end C393011_1; - -- Alert - - --=======================================================================-- - - with C393011_0; - package body C393011_1 is - -- Alert - procedure Set_Status ( A : in out Alert_Type; - To : Definitions.Status_Enum) is - begin - A.Status := To; - end Set_Status; - - end C393011_1; - -- Alert; - - --=======================================================================-- - - with C393011_0, - -- Definitions, - C393011_1, - -- Alert, - Calendar; - - Package C393011_3 is - -- New_Alert - - type New_Alert_Type is abstract new C393011_1.Alert_Type with record - Display_Dev : C393011_0.Display_Enum := C393011_0.TTY; - end record; - - -- procedure Set_Status is inherited - - procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body - - procedure Display ( A : New_Alert_Type) is abstract; - -- override is abstract - -- still can't declare objects of New_Alert_Type - - end C393011_3; - -- New_Alert - - --=======================================================================-- - - with C393011_0; - Package Body C393011_3 is - -- New_Alert - - package Definitions renames C393011_0; - - procedure Set_Serial (A : in out New_Alert_Type) is - use type Definitions.Serial_Type; - begin - A.Serial_Num := Definitions.Next; - Definitions.Next := Definitions."+"( Definitions.Next, 1); - end Set_Serial; - - End C393011_3; - -- New_Alert; - - --=======================================================================-- - - with C393011_0, - -- Definitions - C393011_3; - -- New_Alert -- package Alert is not visible - package C393011_4 is - - package New_Alert renames C393011_3; - package Definitions renames C393011_0; - - type Final_Alert_Type is new New_Alert.New_Alert_Type with null record; - -- inherits Set_Status including body - -- inherits Set_Serial including body - -- must override Display since inherited Display is abstract - procedure Display(FA : in Final_Alert_Type); - procedure Handle (FA : in out Final_Alert_Type); - - end C393011_4; - - package body C393011_4 is - - procedure Display (FA : in Final_Alert_Type) is - begin - Definitions.Display_Device := FA.Display_Dev; - end Display; - - procedure Handle (FA : in out Final_Alert_Type) is - begin - Set_Status (FA, Definitions.Handled); - Set_Serial (FA); - Display (FA); - end Handle; - end C393011_4; - - with C393011_0, - -- Definitions - C393011_3; - -- New_Alert -- package Alert is not visible - with C393011_4; - with Report; - procedure C393011 is - use C393011_4; - use Definitions; - - FA : Final_Alert_Type; - - begin - - Report.Test ("C393011", "Check that an extended type can be derived " & - "from an abstract type"); - - if (Definitions.Display_Device /= Definitions.Bit_Bucket) - or (Definitions.Next /= 1) - or (FA.Status /= Definitions.None) - or (FA.Serial_Num /= 0) - or (FA.Display_Dev /= TTY) then - Report.Failed ("Incorrect initial conditions"); - end if; - - Handle (FA); - if (Definitions.Display_Device /= Definitions.TTY) - or (Definitions.Next /= 2) - or (FA.Status /= Definitions.Handled) - or (FA.Serial_Num /= 1) - or (FA.Display_Dev /= TTY) then - Report.Failed ("Incorrect results from Handle"); - end if; - - Report.Result; - - end C393011; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc/testsuite/ada/acats/tests/c3/c393012.a deleted file mode 100644 index 16bf6ddccf8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393012.a +++ /dev/null @@ -1,221 +0,0 @@ --- C393012.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 non-abstract subprogram of an abstract type can be --- called with a controlling operand that is a type conversion to --- the abstract type. --- --- Check that converting to the class-wide type of an abstract type --- inside an operation of that type causes a "redispatch" of the --- called operation. --- --- TEST DESCRIPTION: --- This test defines an abstract type, and further derives types from it. --- The key feature of this test is in the "Display" procedures where --- the bodies of these procedures convert an object to the class-wide --- type of the root abstract type, causing a "redispatch". --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Dec 94 SAIC Add allocation to the object initializations --- ---! - -package C393012_0 is - - subtype Row_Number is Positive range 1..120; - subtype Seat_Letter is Character range 'A'..'M'; - - type Ticket is abstract tagged - record - Flight : Natural; - Row : Row_Number; - Seat : Seat_Letter; - end record; - - function Display( T: Ticket ) return String; - function Service( T: Ticket ) return String is abstract; - -end C393012_0; - -with TCTouch; -package body C393012_0 is - function Display( T: Ticket ) return String is - begin - TCTouch.Touch('T'); --------------------------------------------------- T - return "Fl:" & Natural'Image(T.Flight) - & Service( Ticket'Class( T ) ) - & " Seat:" & Row_Number'Image(T.Row) & T.Seat; - end Display; -end C393012_0; - -with C393012_0; -package C393012_1 is - type Economy is new C393012_0.Ticket with null record; - function Display( T: Economy ) return String; - function Service( T: Economy ) return String; - - type Meal_Designator is ( B, L, D, V, SN ); - - type First is new C393012_0.Ticket with - record - Meal : Meal_Designator; - end record; - function Display( T: First ) return String; - function Service( T: First ) return String; - procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ); - -end C393012_1; - -with TCTouch; -package body C393012_1 is - function Display( T: Economy ) return String is - begin - TCTouch.Touch('E'); --------------------------------------------------- E - return C393012_0.Display( C393012_0.Ticket( T ) ); - end Display; -- conversion to abstract type - - function Service( T: Economy ) return String is - begin - TCTouch.Touch('e'); --------------------------------------------------- e - return " K"; - end Service; - - function Display( T: First ) return String is - begin - TCTouch.Touch('F'); --------------------------------------------------- F - return C393012_0.Display( C393012_0.Ticket( T ) ); - end Display; -- conversion to abstract type - - function Service( T: First ) return String is - begin - TCTouch.Touch('f'); --------------------------------------------------- f - return " F" & Meal_Designator'Image(T.Meal); - end Service; - - procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is - begin - T.Meal := To_Meal; - end Set_Meal; - -end C393012_1; - -with Report; -with TCTouch; -with C393012_0; -with C393012_1; -procedure C393012 is - - package Rt renames C393012_0; - package Tx renames C393012_1; - - type Tix is access Rt.Ticket'Class; - type Itinerary is array(Positive range 1..3) of Tix; - --- Outbound and Inbound itineraries provide different orderings of mixtures --- of Economy and First_Class. Not that that should make any difference... - - Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ), - 2 => new Tx.First' ( 67, 1, 'J', Tx.L ), - 3 => new Tx.Economy'( 345, 37, 'C' ) ); - - Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ), - 2 => new Tx.Economy'( 68, 12, 'D' ), - 3 => new Tx.Economy'( 5336, 6, 'A' ) ); - --- Each call to Display uses a parameter that is a type conversion --- to the abstract type Ticket. - - procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is - begin - if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then - Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 ); - end if; - if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then - Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 ); - end if; - if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then - Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 ); - end if; - end TC_Convert; - --- Each call to Display uses a parameter that is not a type conversion - - procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is - begin - if Rt.Display( I(1).all ) /= Leg1 then - Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 ); - end if; - if Rt.Display( I(2).all ) /= Leg2 then - Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 ); - end if; - if Rt.Display( I(3).all ) /= Leg3 then - Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 ); - end if; - end TC_Match; - -begin -- Main test procedure. - - Report.Test ("C393012", "Check that a non-abstract subprogram of an " - & "abstract type can be called with a " - & "controlling operand that is a type " - & "conversion to the abstract type. " - & "Check that converting to the class-wide type " - & "of an abstract type inside an operation of " - & "that type causes a redispatch" ); - - -- Test conversions to abstract type - - TC_Convert( Outbound, "Fl: 5335 K Seat: 5B", - "Fl: 67 FL Seat: 1J", - "Fl: 345 K Seat: 37C" ); - - TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" ); - - TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F", - "Fl: 68 K Seat: 12D", - "Fl: 5336 K Seat: 6A" ); - - TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" ); - - -- Test without conversions to abstract type - - TC_Match( Outbound, "Fl: 5335 K Seat: 5B", - "Fl: 67 FL Seat: 1J", - "Fl: 345 K Seat: 37C" ); - - TCTouch.Validate( "ETeFTfETe", "Outbound flight" ); - - TC_Match( Inbound, "Fl: 456 FSN Seat: 4F", - "Fl: 68 K Seat: 12D", - "Fl: 5336 K Seat: 6A" ); - - TCTouch.Validate( "FTfETeETe", "Inbound flight" ); - - Report.Result; - -end C393012; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a02.a b/gcc/testsuite/ada/acats/tests/c3/c393a02.a deleted file mode 100644 index 177bd34b87e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393a02.a +++ /dev/null @@ -1,213 +0,0 @@ --- C393A02.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 dispatching call to an abstract subprogram invokes --- the correct subprogram body of a descendant type according to --- the controlling tag. --- Check that a subprogram can be declared with formal parameters --- and result that are of an abstract type's associated class-wide --- type and that such subprograms can be called. 3.4.1(4) --- --- TEST DESCRIPTION: --- This test declares several objects of types derived from the --- abstract type as defined in the foundation F393A00. It then calls --- various dispatching and class-wide subprograms using those objects. --- The packages in F393A00 are instrumented to trace the flow of --- execution. --- The test checks for the correct order of execution, as expected --- by the various calls. --- --- TEST FILES: --- The following files comprise this test: --- --- F393A00.A (foundation code) --- C393A02.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 05 APR 96 SAIC Update RM references for 2.1 --- ---! - -with Report; -with F393A00_0; -with F393A00_1; -with F393A00_2; -with F393A00_3; -with F393A00_4; -procedure C393A02 is - - A_Windmill : F393A00_2.Windmill; - A_Pump : F393A00_3.Pump; - A_Mill : F393A00_4.Mill; - - A_Windmill_2 : F393A00_2.Windmill; - A_Pump_2 : F393A00_3.Pump; - A_Mill_2 : F393A00_4.Mill; - - B_Windmill : F393A00_2.Windmill; - B_Pump : F393A00_3.Pump; - B_Mill : F393A00_4.Mill; - - procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is - begin - F393A00_0.TC_Touch('x'); - F393A00_2.Swap( A,B ); - end Swapem; - - function Zephyr( A: F393A00_2.Windmill'Class ) - return F393A00_2.Windmill'Class is - Item : F393A00_2.Windmill'Class := A; - begin - F393A00_0.TC_Touch('y'); - if not F393A00_1.Initialized( Item ) then -- b - F393A00_2.Initialize( Item ); -- a - end if; - F393A00_2.Stop( Item ); -- f / mff - F393A00_2.Add_Spin( Item, 10 ); -- e - return Item; - end Zephyr; - - function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is - Item : F393A00_2.Windmill'Class := It; - begin - F393A00_2.Stop( Item ); -- f - F393A00_2.Add_Spin( Item, 40 ); -- e - return Item; - end Gale; - - function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is - Item : F393A00_2.Windmill'Class := It; - begin - F393A00_2.Stop( Item ); -- f - F393A00_2.Add_Spin( Item, 50 ); -- e - return Item; - end Gale; - - function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is - Item : F393A00_2.Windmill'Class := It; - begin - F393A00_2.Stop( Item ); -- mff - F393A00_2.Add_Spin( Item, 60 ); -- e - return Item; - end Gale; - -begin -- Main test procedure. - - Report.Test ("C393A02", "Check that a dispatching call to an abstract " - & "subprogram invokes the correct subprogram body. " - & "Check that a subprogram declared with formal " - & "parameters/result of an abstract type's " - & "associated class-wide can be called" ); - - F393A00_0.TC_Validate( "hhh", "Mill declarations" ); - A_Windmill := F393A00_2.Create; - F393A00_0.TC_Validate( "d", "Create A_Windmill" ); - - A_Pump := F393A00_3.Create; - F393A00_0.TC_Validate( "h", "Create A_Pump" ); - - A_Mill := F393A00_4.Create; - F393A00_0.TC_Validate( "hl", "Create A_Mill" ); - - -------------- - - Swapem( A_Windmill, A_Windmill_2 ); - F393A00_0.TC_Validate( "xc", "Windmill Swap" ); - - Swapem( A_Pump, A_Pump_2 ); - F393A00_0.TC_Validate( "xc", "Pump Swap" ); - - Swapem( A_Mill, A_Mill_2 ); - F393A00_0.TC_Validate( "xk", "Pump Swap" ); - - F393A00_2.Initialize( A_Windmill_2 ); - F393A00_3.Initialize( A_Pump_2 ); - F393A00_4.Initialize( A_Mill_2 ); - B_Windmill := A_Windmill_2; - B_Pump := A_Pump_2; - B_Mill := A_Mill_2; - F393A00_2.Add_Spin( B_Windmill, 123 ); - F393A00_3.Set_Rate( B_Pump, 12.34 ); - F393A00_4.Add_Spin( B_Mill, 321 ); - F393A00_0.TC_Validate( "aaaeie", "Setting Values" ); - - declare - It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe - XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe - use type F393A00_2.Rotational_Measurement; - begin - if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) -then - Report.Failed( "Copy to class-wide variable" ); - end if; -- bb - if F393A00_2.Spin( It ) /= 10 -- g - or F393A00_2.Spin( XX ) /= 40 then -- g - Report.Failed( "Call to class-wide operation" ); - end if; - - F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" ); - end; - - declare - It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe - XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe - use type F393A00_2.Rotational_Measurement; - begin - if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) -then - Report.Failed( "Bad copy to class-wide variable" ); - end if; -- bb - if F393A00_2.Spin( It ) /= 10 -- g - or F393A00_2.Spin( XX ) /= 50 then -- g - Report.Failed( "Call to class-wide operation" ); - end if; - - F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" ); - end; - - declare - It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe - XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe - use type F393A00_2.Rotational_Measurement; - begin - if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) -then - Report.Failed( "Bad copy to class-wide variable" ); - end if; -- bb - if F393A00_2.Spin( It ) /= 10 -- g - or F393A00_2.Spin( XX ) /= 60 then -- g - Report.Failed( "Call to class-wide operation" ); - end if; - - F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" ); - end; - - Report.Result; - -end C393A02; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a03.a b/gcc/testsuite/ada/acats/tests/c3/c393a03.a deleted file mode 100644 index 90106f4bf44..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393a03.a +++ /dev/null @@ -1,242 +0,0 @@ --- C393A03.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 non-abstract primitive subprogram of an abstract --- type can be called as a dispatching operation and that the body --- of this subprogram can make a dispatching call to an abstract --- operation of the corresponding abstract type. --- --- TEST DESCRIPTION: --- This test expands on the class family defined in foundation F393A00 --- by deriving a new abstract type from the root abstract type "Object". --- The subprograms defined for the new abstract type are then --- appropriately overridden, and the test ultimately calls various --- mixtures of these subprograms to check that the dispatching occurs --- correctly. --- --- TEST FILES: --- The following files comprise this test: --- --- F393A00.A (foundation code) --- C393A03.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed ARM references from objective text. --- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 --- ---! - -------------------------------------------------------------------- C393A03_0 - -with F393A00_1; -package C393A03_0 is - - type Counting_Object is abstract new F393A00_1.Object with private; - -- inherits Initialize, Swap (abstract) and Create (abstract) - - procedure Bump ( A_Counter: in out Counting_Object ); - procedure Clear( A_Counter: in out Counting_Object ) is abstract; - procedure Zero ( A_Counter: in out Counting_Object ); - function Value( A_Counter: Counting_Object'Class ) return Natural; - -private - - type Counting_Object is abstract new F393A00_1.Object with - record - Tally : Natural :=0; - end record; - -end C393A03_0; - ------------------------------------------------------------------------------ - -with F393A00_0; -package body C393A03_0 is - - procedure Bump ( A_Counter: in out Counting_Object ) is - begin - F393A00_0.TC_Touch('A'); - A_Counter.Tally := A_Counter.Tally +1; - end Bump; - - procedure Zero ( A_Counter: in out Counting_Object ) is - begin - F393A00_0.TC_Touch('B'); - - -- dispatching call to abstract operation of Counting_Object - Clear( Counting_Object'Class(A_Counter) ); - - A_Counter.Tally := 0; - - end Zero; - - function Value( A_Counter: Counting_Object'Class ) return Natural is - begin - F393A00_0.TC_Touch('C'); - return A_Counter.Tally; - end Value; - -end C393A03_0; - -------------------------------------------------------------------- C393A03_1 - -with C393A03_0; -package C393A03_1 is - - type Modular_Object is new C393A03_0.Counting_Object with private; - -- inherits Initialize, Bump, Zero and Value, - -- inherits abstract Swap, Create and Clear - - procedure Swap( A,B: in out Modular_Object ); - procedure Clear( It: in out Modular_Object ); - procedure Set_Max( It : in out Modular_Object; Value : Natural ); - function Create return Modular_Object; - -private - - type Modular_Object is new C393A03_0.Counting_Object with - record - Max_Value : Natural; - end record; - -end C393A03_1; - ------------------------------------------------------------------------------ - -with F393A00_0; -package body C393A03_1 is - - procedure Swap( A,B: in out Modular_Object ) is - T : constant Modular_Object := B; - begin - F393A00_0.TC_Touch('1'); - B := A; - A := T; - end Swap; - - procedure Clear( It: in out Modular_Object ) is - begin - F393A00_0.TC_Touch('2'); - null; - end Clear; - - procedure Set_Max( It : in out Modular_Object; Value : Natural ) is - begin - F393A00_0.TC_Touch('3'); - It.Max_Value := Value; - end Set_Max; - - function Create return Modular_Object is - AMO : Modular_Object; - begin - F393A00_0.TC_Touch('4'); - AMO.Max_Value := Natural'Last; - return AMO; - end Create; - -end C393A03_1; - ---------------------------------------------------------------------- C393A03 - -with Report; -with F393A00_0; -with F393A00_1; -with C393A03_0; -with C393A03_1; -procedure C393A03 is - - A_Thing : C393A03_1.Modular_Object; - Another_Thing : C393A03_1.Modular_Object; - - procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Initialize( It ); -- dispatch to inherited procedure - end Initialize; - - procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Bump( It ); -- dispatch to non-abstract procedure - end Bump; - - procedure Set_Max( It : in out C393A03_1.Modular_Object'Class; - Val : Natural) is - begin - C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure - end Set_Max; - - procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure - end Swap; - - procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Zero( It ); -- dispatch to non-abstract procedure - end Zero; - -begin -- Main test procedure. - - Report.Test ("C393A03", "Check that a non-abstract primitive subprogram " - & "of an abstract type can be called as a " - & "dispatching operation and that the body of this " - & "subprogram can make a dispatching call to an " - & "abstract operation of the corresponding " - & "abstract type" ); - - A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last - F393A00_0.TC_Validate( "4", "Overridden primitive layer 2"); - - Initialize( A_Thing ); - Initialize( Another_Thing ); - F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0"); - - Bump( A_Thing ); -- Tally = 1 - F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1"); - - Set_Max( A_Thing, 42 ); -- Max_Value = 42 - F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2"); - - if not F393A00_1.Initialized( A_Thing ) then - Report.Failed("Initialize didn't"); - end if; - F393A00_0.TC_Validate( "b", "Class-wide layer 0"); - - Swap( A_Thing, Another_Thing ); - F393A00_0.TC_Validate( "1", "Overridden abstract layer 2"); - - Zero( A_Thing ); - F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch"); - - if C393A03_0.Value( A_Thing ) /= 0 then - Report.Failed("Zero didn't"); - end if; - F393A00_0.TC_Validate( "C", "Class-wide normal layer 2"); - - Report.Result; - -end C393A03; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a05.a b/gcc/testsuite/ada/acats/tests/c3/c393a05.a deleted file mode 100644 index b404559cc83..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393a05.a +++ /dev/null @@ -1,166 +0,0 @@ --- C393A05.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 for a nonabstract private extension, any inherited - -- abstract subprograms can be overridden in the private part of - -- the immediately enclosing package and that calls can be made to - -- private dispatching operations. - -- - -- TEST DESCRIPTION: - -- This test builds an additional layer upon the foundation code to - -- provide the required "hidden" dispatching operation. The procedure - -- Swap, a private subprogram, should be called by dispatch. - -- - -- TEST FILES: - -- The following files comprise this test: - -- - -- F393A00.A (foundation code) - -- C393A05.A - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - with F393A00_4; - package C393A05_0 is - type Grinder is new F393A00_4.Mill with private; - type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso); - - procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ); - function Grind( It: Grinder ) return Coarseness; - - function Create return Grinder; - private - procedure Swap( A,B: in out Grinder ); - type Grinder is new F393A00_4.Mill with - record - Grind : Coarseness := Whole_Bean; - end record; - end C393A05_0; - - with F393A00_0; - package body C393A05_0 is - procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is - begin - F393A00_0.TC_Touch( 'A' ); - It.Grind := The_Grind; - end Set_Grind; - - function Grind( It: Grinder ) return Coarseness is - begin - F393A00_0.TC_Touch( 'B' ); - return It.Grind; - end Grind; - - procedure Swap( A,B: in out Grinder ) is - T : constant Grinder := A; - begin - F393A00_0.TC_Touch( 'C' ); - A := B; - B := T; - end Swap; - - function Create return Grinder is - One: Grinder; - begin - F393A00_0.TC_Touch( 'D' ); - F393A00_4.Initialize( F393A00_4.Mill( One ) ); - One.Grind := Fine; - return One; - end Create; - end C393A05_0; - - with Report; - with F393A00_0; - with C393A05_0; - procedure C393A05 is - - package Tracer renames F393A00_0; - package Coffee renames C393A05_0; - use type Coffee.Coarseness; - - Morning : Coffee.Grinder; - Afternoon : Coffee.Grinder; - - Gritty : Coffee.Coarseness; - - procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is - begin - Coffee.Swap( A, B ); -- dispatch - end Class_Swap; - - begin -- Main test procedure. - - Report.Test ("C393A05", "Check that nonabstract private extensions, " - & "inherited abstract subprograms overridden " - & "in the private part can be dispatched from " - & "outside the package" ); - - Tracer.TC_Validate( "hh", "Declarations" ); - - Morning := Coffee.Create; - Tracer.TC_Validate( "hDa", "Creating Morning Coffee" ); - Gritty := Coffee.Grind( Morning ); - Tracer.TC_Validate( "B", "Finding Morning Grind" ); - - Afternoon := Coffee.Create; - Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" ); - Coffee.Set_Grind( Afternoon, Coffee.Medium ); - Tracer.TC_Validate( "A", "Setting Afternoon Grind" ); - - Coffee.Swap( Morning, Afternoon ); - Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" ); - - if Gritty /= Coffee.Grind( Afternoon ) - or Coffee.Grind ( Afternoon ) /= Coffee.Fine then - Report.Failed ("Result of Swap"); - end if; - Tracer.TC_Validate( "BB", "Finding Afternoon Grind" ); - - Sunset: declare - Evening : Coffee.Grinder'Class := Coffee.Create; - begin - Tracer.TC_Validate( "hDa", "Creating Evening Coffee" ); - - Coffee.Set_Grind( Evening, Coffee.Espresso ); - Tracer.TC_Validate( "A", "Setting Evening Grind" ); - - Morning := Coffee.Grinder( Evening ); - Class_Swap( Morning, Evening ); - Tracer.TC_Validate( "C", "Swapping Coffees" ); - if Coffee.Grind( Morning ) /= Coffee.Espresso then - Report.Failed ("Result of Assignment"); - end if; - end Sunset; - - Report.Result; - - end C393A05; - - - diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a06.a b/gcc/testsuite/ada/acats/tests/c3/c393a06.a deleted file mode 100644 index c257d5fa0a0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393a06.a +++ /dev/null @@ -1,201 +0,0 @@ --- C393A06.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 that inherits abstract operations but --- overrides each of these operations is not required to be --- abstract, and that objects of the type and its class-wide type --- may be declared and passed in calls to the overriding --- subprograms. --- --- TEST DESCRIPTION: --- This test derives a type from the root abstract type available --- in foundation F393A00. It declares subprograms as required by --- the language to override the abstract subprograms, allowing the --- derived type itself to be not abstract. It also declares --- operations on the new type, as well as on the associated class- --- wide type. The main program then uses two objects of the type --- and two objects of the class-wide type as parameters for each of --- the subprograms. Correct execution is determined by path --- analysis and value checking. --- --- TEST FILES: --- The following files comprise this test: --- --- F393A00.A (foundation code) --- C393A06.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- ---! - - with F393A00_1; - package C393A06_0 is - type Organism is new F393A00_1.Object with private; - type Kingdoms is ( Animal, Vegetable, Unspecified ); - - procedure Swap( A,B: in out Organism ); - function Create return Organism; - - procedure Initialize( The_Entity : in out Organism; - In_The_Kingdom : Kingdoms ); - function Kingdom( Of_The_Entity : Organism ) return Kingdoms; - - procedure TC_Check( An_Entity : Organism'Class; - In_Kingdom : Kingdoms; - Initialized : Boolean ); - - Incompatible : exception; - - private - type Organism is new F393A00_1.Object with - record - In_Kingdom : Kingdoms; - end record; - end C393A06_0; - - with F393A00_0; - package body C393A06_0 is - - procedure Swap( A,B: in out Organism ) is - begin - F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A - if A.In_Kingdom /= B.In_Kingdom then - F393A00_0.TC_Touch( 'X' ); - raise Incompatible; - else - declare - T: constant Organism := A; - begin - A := B; - B := T; - end; - end if; - end Swap; - - function Create return Organism is - Widget : Organism; - begin - F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B - Initialize( Widget ); - Widget.In_Kingdom := Unspecified; - return Widget; - end Create; - - procedure Initialize( The_Entity : in out Organism; - In_The_Kingdom : Kingdoms ) is - begin - F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C - F393A00_1.Initialize( F393A00_1.Object( The_Entity ) ); - The_Entity.In_Kingdom := In_The_Kingdom; - end Initialize; - - function Kingdom( Of_The_Entity : Organism ) return Kingdoms is - begin - F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D - return Of_The_Entity.In_Kingdom; - end Kingdom; - - procedure TC_Check( An_Entity : Organism'Class; - In_Kingdom : Kingdoms; - Initialized : Boolean ) is - begin - if F393A00_1.Initialized( An_Entity ) /= Initialized then - F393A00_0.TC_Touch( '-' ); ------------------------------------------- - - elsif An_Entity.In_Kingdom /= In_Kingdom then - F393A00_0.TC_Touch( '!' ); ------------------------------------------- ! - else - F393A00_0.TC_Touch( '+' ); ------------------------------------------- + - end if; - end TC_Check; - - end C393A06_0; - - with Report; - - with C393A06_0; - with F393A00_0; - with F393A00_1; - procedure C393A06 is - - package Darwin renames C393A06_0; - package Tagger renames F393A00_0; - package Objects renames F393A00_1; - - Lion : Darwin.Organism; - Tigerlily : Darwin.Organism; - Bear : Darwin.Organism'Class := Darwin.Create; - Sunflower : Darwin.Organism'Class := Darwin.Create; - - use type Darwin.Kingdoms; - - begin -- Main test procedure. - - Report.Test ("C393A06", "Check that a type that inherits abstract " - & "operations but overrides each of these " - & "operations is not required to be abstract. " - & "Check that objects of the type and its " - & "class-wide type may be declared and passed " - & "in calls to the overriding subprograms" ); - - Tagger.TC_Validate( "BaBa", "Declaration Initializations" ); - - Darwin.Initialize( Lion, Darwin.Animal ); - Darwin.Initialize( Tigerlily, Darwin.Vegetable ); - Darwin.Initialize( Bear, Darwin.Animal ); - Darwin.Initialize( Sunflower, Darwin.Vegetable ); - - Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" ); - - Oh_My: begin - Darwin.Swap( Lion, Darwin.Organism( Bear ) ); - Darwin.Swap( Lion, Tigerlily ); - Report.Failed("Exception not raised"); - exception - when Darwin.Incompatible => null; - end Oh_My; - - Tagger.TC_Validate( "AAX", "Swap sequence" ); - - if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then - Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) ); - end if; - - Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" ); - - Darwin.TC_Check( Lion, Darwin.Animal, True ); - Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True ); - Darwin.TC_Check( Bear, Darwin.Animal, True ); - Darwin.TC_Check( Sunflower, Darwin.Vegetable, True ); - - Tagger.TC_Validate( "b+b+b+b+", "Final sequence" ); - - Report.Result; - - end C393A06; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b12.a b/gcc/testsuite/ada/acats/tests/c3/c393b12.a deleted file mode 100644 index 5d1b46daa74..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393b12.a +++ /dev/null @@ -1,131 +0,0 @@ --- C393B12.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived in the specification of a --- generic package when the parent is an abstract type in a library --- package. --- --- TEST DESCRIPTION: --- Extend an abstract type in the visible part of a generic package. --- Make all of the procedures which override abstract procedures --- available as part of the generic interface. Instantiate the generic. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- F393B00.A Package Alert_Foundation --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Oct 95 SAIC Update and repair for ACVC 2.0.1 --- 27 Feb 97 PWB.CTA Add pragma Elaborate for C393B12_0. ---! - ------------------------------------------------------------------ C393B12_0 - -with F393B00; - -- Alert_Foundation -generic - type Generic_Status_Enum is (<>); - -package C393B12_0 is - -- Alert_Functions - - type Generic_Alert_Type is new F393B00.Alert with record - Status : Generic_Status_Enum := Generic_Status_Enum'First; - end record; - -- extension of an abstract type - - procedure Handle (GA : in out Generic_Alert_Type); - -- override of abstract procedure - - function Query_Status (GA : Generic_Alert_Type) - return Generic_Status_Enum; -- new primitive operation for - -- Generic_Alert_Type -end C393B12_0; - -- Alert_Functions - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C393B12_0 is - -- Alert_Functions - - procedure Handle (GA : in out Generic_Alert_Type) is - begin - GA.Status := Generic_Status_Enum'Last; - end Handle; - - function Query_Status (GA : Generic_Alert_Type) - return Generic_Status_Enum is - begin - return GA.Status; - end Query_Status; - -end C393B12_0; - ------------------------------------------------------------------ C393B12_1 - -package C393B12_1 is - type Status is (Low, Medium, High); -end C393B12_1; - -------------------------------------------------------- C393B12_1.C393B12_2 - -with C393B12_0; -pragma Elaborate (C393B12_0); -package C393B12_1.C393B12_2 is new C393B12_0 - -- Alert_Functions - (Generic_Status_Enum => Status); - -------------------------------------------------------------------- C393B12 - -with C393B12_1.C393B12_2; -with Report; -procedure C393B12 is - - use type C393B12_1.Status; - - package Alt_Alert renames C393B12_1.C393B12_2; - - GA : Alt_Alert.Generic_Alert_Type; - -begin - Report.Test ("C393B12", "Check that an extended type can be derived " & - "from an abstract type"); - - if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then - Report.Failed ("Wrong initialization"); - end if; - - Alt_Alert.Handle (GA); - if Alt_Alert.Query_Status (GA) /= C393B12_1.High then - Report.Failed ("Wrong results from Handle"); - end if; - - Report.Result; - -end C393B12; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b13.a b/gcc/testsuite/ada/acats/tests/c3/c393b13.a deleted file mode 100644 index c533badbe04..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393b13.a +++ /dev/null @@ -1,105 +0,0 @@ --- C393B13.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived from an abstract type --- when that derivation is declared in a child package. --- --- TEST DESCRIPTION: --- Add a visible child to Alert_Foundation. Using the abstract type --- Alert as parent, declare an extended type with discriminant and new --- record components. Override the Handle procedure. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- F393B00.A Package Alert_Foundation --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 --- ---! - -package F393B00.C393B13_0 is - -- Alert_Foundation.Public_Child - - subtype Msg_Length_Range is integer range 0 .. 240; - Max_Msg_Length : constant Msg_Length_Range := 80; - Message : String := "Test Passed"; - - type Child_Alert (Length : Msg_Length_Range) - is new Alert with record -- abstract type is in parent package - Times_Handled : Natural := 0; - Msg : String (1..Length); - end record; - - procedure Handle (CA : in out Child_Alert); -- required override - -end F393B00.C393B13_0; - -- Alert_Foundation.Public_Child; - ---=======================================================================-- - -package body F393B00.C393B13_0 is - -- Alert_Foundation.Public_Child - - procedure Handle (CA : in out Child_Alert) is - begin - CA.Msg(1..Message'Length) := Message; - CA.Times_Handled := CA.Times_Handled + 1; - end; - -end F393B00.C393B13_0; - -- Alert_Foundation.Public_Child - ---=======================================================================-- - -with Report; -with F393B00.C393B13_0; - -- Alert_foundation.Public_Child; -procedure C393B13 is - package Child renames F393B00.C393B13_0; - CA : Child.Child_Alert(Child.Message'Length); - -begin - - Report.Test ("C393B13", "Check that an extended type can be derived " & - "from an abstract type"); - - if CA.Times_Handled /= 0 then - Report.Failed ("Wrong initialization"); - end if; - - Child.Handle (CA); - if (CA.Times_Handled /= 1) - or (CA.Msg /= Child.Message) then - Report.Failed ("Wrong results from Handle"); - end if; - - Report.Result; - -end C393B13; diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b14.a b/gcc/testsuite/ada/acats/tests/c3/c393b14.a deleted file mode 100644 index f100377aa04..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393b14.a +++ /dev/null @@ -1,147 +0,0 @@ --- C393B14.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. ---* --- --- TEST OBJECTIVE: --- Check that an extended type can be derived in a private child package --- from an abstract type defined in a library package. --- --- TEST DESCRIPTION: --- Add a private child package to Alert_Foundation. Using Private_Alert --- as parent type, declare an extended type adding a new record component. --- Override procedure Handle. Declare an object of the new type in the --- child specification. Use type definitions from the private part of the --- parent in the body of the child. --- --- TEST FILES: --- This test depends on the following foundation code: --- --- F393B00.A Package Alert_Foundation --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -private package F393B00.C393B14_0 is - -- Alert_Foundation.Private_Child - - type Implementation_Specific_Alert_Type is new Private_Alert with record - New_Private_Field : Implementation_Detail - := Implementation_Detail'Last; - end record; - - procedure Handle (PA : in out Implementation_Specific_Alert_Type); - -- overrides abstract Handle, as required - PA : Implementation_Specific_Alert_Type; - -end F393B00.C393B14_0; - -- Alert_Foundation.Private_Child - ---=======================================================================-- - -package body F393B00.C393B14_0 is - -- Alert_Foundation.Private_Child - - procedure Handle (PA : in out Implementation_Specific_Alert_Type) is - begin - PA.Private_Field := 1; - PA.New_Private_Field := PA.Private_Field + 1; - end; - -end F393B00.C393B14_0; - -- Alert_Foundation.Private_Child - ---=======================================================================-- - -package F393B00.C393B14_1 is - -- Alert_Foundation.Public_Child - - type Timing is (Before, After); - procedure Init; - procedure Modify; - function Check_Before return Boolean; - function Check_After return Boolean; - -end F393B00.C393B14_1; - -- Alert_Foundation.Public_Child - ---=======================================================================-- - -with F393B00.C393B14_0; -- private sibling is visible in the - -- Alert_Foundation.Private_Child -- body of a public sibling -package body F393B00.C393B14_1 is - -- Alert_Foundation.Public_Child - package Priv renames F393B00.C393B14_0; - - procedure Init is - begin - Priv.PA.Private_Field := 5; - Priv.PA.New_Private_Field := 10; - end Init; - - procedure Modify is - begin - Priv.Handle (Priv.PA); - end Modify; - - function Check_Before return Boolean is - begin - return ((Priv.PA.Private_Field = 5) - and (Priv.PA.New_Private_Field =10)); - end Check_Before; - - function Check_After return Boolean is - begin - return ((Priv.PA.Private_Field = 1) - and (Priv.PA.New_Private_Field = 2)); - end Check_After; - -end F393B00.C393B14_1; - -- Alert_Foundation.Public_Child - ---=======================================================================-- - -with Report; -with F393B00.C393B14_1; -procedure C393B14 is - -- Alert_Foundation.Public_Child; - -begin - Report.Test ("C393B14", "Check that an extended type can be derived " & - "from an abstract type"); - - F393B00.C393B14_1.Init; - if not F393B00.C393B14_1.Check_Before then - Report.Failed ("Wrong initialization"); - end if; - - F393B00.C393B14_1.Modify; - if not F393B00.C393B14_1.Check_After then - Report.Failed ("Wrong results from Handle"); - end if; - - Report.Result; -end C393B14; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a b/gcc/testsuite/ada/acats/tests/c3/c3a0001.a deleted file mode 100644 index f8a0681e78f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a +++ /dev/null @@ -1,138 +0,0 @@ --- C3A0001.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 access to subprogram type can be used to select and --- invoke functions with appropriate arguments dynamically. --- --- TEST DESCRIPTION: --- Declare an access to function type in a package specification. --- Declare three different sine functions that can be referred to by --- the access to function type. --- --- In the main program, call each function indirectly by dereferencing --- the access value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C3A0001_0 is - - TC_Call_Tag : Natural := 0; - - -- Type accesses to any sine function - type Sine_Function_Ptr is access function - (Angle : in Float) return Float; - --- Three 'Sine' functions that model an application situation in which --- one function might be chosen when speed is important, another (using --- a different algorithm) might be chosen when accuracy is important, --- and so on. - - function Sine_Calc_Fast (Angle : in Float) return Float; - - function Sine_Calc_Acc (Angle : in Float) return Float; - - function Sine_Calc_Table (Angle : in Float) return Float; - -end C3A0001_0; - - ------------------------------------------------------------------------------ - - -package body C3A0001_0 is - - function Sine_Calc_Fast (Angle : in Float) return Float is - begin - TC_Call_Tag := 1; - return 1.0; - end Sine_Calc_Fast; - - - function Sine_Calc_Acc (Angle : in Float) return Float is - begin - TC_Call_Tag := 2; - return 0.0; - end Sine_Calc_Acc; - - - function Sine_Calc_Table (Angle : in Float) return Float is - begin - TC_Call_Tag := 3; - return -1.0; - end Sine_Calc_Table; - -end C3A0001_0; - ------------------------------------------------------------------------------ - -with Report; -with C3A0001_0; - -procedure C3A0001 is - - Sine_Access : C3A0001_0.Sine_Function_Ptr; - X, Theta : Float := 0.0; - -begin - - Report.Test ("C3A0001", "Check that access to subprogram can be " & - "used to select and invoke an operation with " & - "appropriate arguments dynamically"); - - Sine_Access := C3A0001_0.Sine_Calc_Fast'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access(Theta); - - If C3A0001_0.TC_Call_Tag /= 1 then - Report.Failed ("Incorrect Sine_Calc_Fast result"); - end if; - - Sine_Access := C3A0001_0.Sine_Calc_Acc'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access(Theta); - - If C3A0001_0.TC_Call_Tag /= 2 then - Report.Failed ("Incorrect Sine_Calc_Acc result"); - end if; - - Sine_Access := C3A0001_0.Sine_Calc_Table'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access(Theta); - - If C3A0001_0.TC_Call_Tag /= 3 then - Report.Failed ("Incorrect Sine_Calc_Table result"); - end if; - - Report.Result; - -end C3A0001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a b/gcc/testsuite/ada/acats/tests/c3/c3a0002.a deleted file mode 100644 index 5c05d43fb6a..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a +++ /dev/null @@ -1,142 +0,0 @@ --- C3A0002.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 access to subprogram type can be used to select and --- invoke procedures with appropriate arguments dynamically. --- --- TEST DESCRIPTION: --- Declare an access to procedure type in a package specification. --- Declare three different log procedures that can be referred to by --- the access to procedure type. --- --- In the main program, call each procedure indirectly by dereferencing --- the access value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 05 APR 96 SAIC RM reference change for 2.1 --- --- ---! - - -package C3A0002_0 is - - TC_Call_Tag : Natural := 0; - - Return_Num : Float := 0.0; - - -- Type accesses to any log procedure - type Log_Procedure_Ptr is access procedure - (Angle : in Float); - - procedure Log_Calc_Fast (Angle : in Float); - - procedure Log_Calc_Acc (Angle : in Float); - - procedure Log_Calc_Table (Angle : in Float); - -end C3A0002_0; - - ------------------------------------------------------------------------------ - - -package body C3A0002_0 is - - procedure Log_Calc_Fast (Angle : in Float) is - begin - TC_Call_Tag := 1; - Return_Num := Angle; - end Log_Calc_Fast; - - - procedure Log_Calc_Acc (Angle : in Float) is - begin - TC_Call_Tag := 2; - Return_Num := Angle; - end Log_Calc_Acc; - - - procedure Log_Calc_Table (Angle : in Float) is - begin - TC_Call_Tag := 3; - Return_Num := Angle; - end Log_Calc_Table; - -end C3A0002_0; - ------------------------------------------------------------------------------ - -with Report; -with C3A0002_0; - -procedure C3A0002 is - - Log_Access : C3A0002_0.Log_Procedure_Ptr; - Theta : Float := 0.0; - -begin - - Report.Test ("C3A0002", "Check that access to subprogram type can be " - & "used to select and invoke procedures with " - & "appropriate arguments dynamically" ); - - Log_Access := C3A0002_0.Log_Calc_Fast'Access; - - -- Invoking Log procedure designated by access value - Log_Access (Theta); - - If C3A0002_0.TC_Call_Tag /= 1 or C3A0002_0.Return_Num /= 0.0 then - Report.Failed ("Incorrect Log_Calc_Fast result"); - end if; - - Theta := 1.0; - - Log_Access := C3A0002_0.Log_Calc_Acc'Access; - - -- Invoking Log procedure designated by access value - Log_Access (Theta); - - If C3A0002_0.TC_Call_Tag /= 2 or C3A0002_0.Return_Num /= 1.0 then - Report.Failed ("Incorrect Log_Calc_Acc result"); - end if; - - Theta := -1.0; - - Log_Access := C3A0002_0.Log_Calc_Table'Access; - - -- Invoking Log procedure designated by access value - Log_Access (Theta); - - If C3A0002_0.TC_Call_Tag /= 3 or C3A0002_0.Return_Num /= -1.0 then - Report.Failed ("Incorrect Log_Calc_Table result"); - end if; - - Report.Result; - -end C3A0002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a b/gcc/testsuite/ada/acats/tests/c3/c3a0003.a deleted file mode 100644 index 4f9fdbe29f8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a +++ /dev/null @@ -1,144 +0,0 @@ --- C3A0003.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 function in a generic instance can be called using --- an access-to-subprogram value. --- --- TEST DESCRIPTION: --- Declare a numeric type in the visible part of a generic package. --- Declare an access to function type. Declare three different sine --- functions that can be referred to by the access to function type. --- --- In the main program, instantiate the generic. Call each function --- indirectly by dereferencing the access value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -generic - type Real_Num is digits <>; - -package C3A0003_0 is - - TC_Call_Tag : Natural := 0; - - -- Type accesses to any sine function - type Sine_Function_Ptr is access function - (Angle : in Real_Num) return Real_Num; - - function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num; - - function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num; - - function Sine_Calc_Table (Angle : in Real_Num) return Real_Num; - -end C3A0003_0; - - ------------------------------------------------------------------------------ - - -package body C3A0003_0 is - - function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num is - Sine_Num : Real_Num := 1.0; - begin - TC_Call_Tag := 1; - return Sine_Num; - end Sine_Calc_Fast; - - - function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num is - Sine_Num : Real_Num := 0.0; - begin - TC_Call_Tag := 2; - return Sine_Num; - end Sine_Calc_Acc; - - - function Sine_Calc_Table (Angle : in Real_Num) return Real_Num is - Sine_Num : Real_Num := -1.0; - begin - TC_Call_Tag := 3; - return Sine_Num; - end Sine_Calc_Table; - -end C3A0003_0; - ------------------------------------------------------------------------------ - -with Report; -with C3A0003_0; - -procedure C3A0003 is - - type Real is digits 5; - - Subtype Trig_Float is Real range -1.0 .. 1.0; - - package Trig is new C3A0003_0 (Real_Num => Trig_Float); - - Sine_Access : Trig.Sine_Function_Ptr; - X, Theta : Trig_Float := 0.0; - -begin - - Report.Test ("C3A0003", "Check that a function in a generic instance can " - & "be called using an access-to-subprogram value"); - - Sine_Access := Trig.Sine_Calc_Fast'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access.all(Theta); - - If Trig.TC_Call_Tag /= 1 then - Report.Failed ("Incorrect Sine_Calc_Fast result"); - end if; - - Sine_Access := Trig.Sine_Calc_Acc'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access.all(Theta); - - If Trig.TC_Call_Tag /= 2 then - Report.Failed ("Incorrect Sine_Calc_Acc result"); - end if; - - Sine_Access := Trig.Sine_Calc_Table'Access; - - -- Invoking Sine function designated by access value - X := Sine_Access.all(Theta); - - If Trig.TC_Call_Tag /= 3 then - Report.Failed ("Incorrect Sine_Calc_Table result"); - end if; - - Report.Result; - -end C3A0003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a b/gcc/testsuite/ada/acats/tests/c3/c3a0004.a deleted file mode 100644 index 2557546c2e4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a +++ /dev/null @@ -1,115 +0,0 @@ --- C3A0004.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 access to subprogram may be stored within array - -- objects, and that the access to subprogram can subsequently - -- be called. - -- - -- TEST DESCRIPTION: - -- Declare an access to procedure type in a package specification. - -- Declare an array of the access type. Declare three different - -- procedures that can be referred to by the access to procedure type. - -- - -- In the main program, build the array by dereferencing the access - -- value. - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - with Report; - - procedure C3A0004 is - - Left_Turn : Integer := 1; - - Right_Turn : Integer := 1; - - Center_Turn : Integer := 1; - - -- Type accesses to any procedure - type Action_Ptr is access procedure; - - -- Array of access to procedure - type Action_Array is array (Integer range <>) of Action_Ptr; - - - procedure Rotate_Left is - begin - Left_Turn := 2; - end Rotate_Left; - - - procedure Rotate_Right is - begin - Right_Turn := 3; - end Rotate_Right; - - - procedure Center is - begin - Center_Turn := 0; - end Center; - - - begin - - Report.Test ("C3A0004", "Check that access to subprogram may be " - & "stored within data structures, and that the " - & "access to subprogram can subsequently be called"); - - ------------------------------------------------------------------------ - - declare - Total_Actions : constant := 3; - Action_Sequence : Action_Array (1 .. Total_Actions); - - begin - - -- Build the action sequence - Action_Sequence := (Rotate_Left'Access, Center'Access, - Rotate_Right'Access); - - -- Assign actions by invoking subprogram designated by access value - for I in Action_Sequence'Range loop - Action_Sequence(I).all; - end loop; - - If Left_Turn /= 2 or Right_Turn /= 3 - or Center_Turn /= 0 then - Report.Failed ("Incorrect Action sequence result"); - end if; - - end; - - ------------------------------------------------------------------------ - - Report.Result; - - end C3A0004; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a b/gcc/testsuite/ada/acats/tests/c3/c3a0005.a deleted file mode 100644 index 1f23689579f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a +++ /dev/null @@ -1,147 +0,0 @@ --- C3A0005.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 access to subprogram may be stored within record --- objects, and that the access to subprogram can subsequently --- be called. --- --- TEST DESCRIPTION: --- Declare an access to procedure type in a package specification. --- Declare two different procedures that can be referred to by the --- access to procedure type. Declare a record with the access to --- procedure type as a component. Use the access to procedure type to --- initialize the component of a record. --- --- In the main program, declare an operation. An access value --- designating this operation is passed as a parameter to be --- stored in the record. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C3A0005_0 is - - Default_Call : Boolean := False; - - type Button; - - - -- Type accesses to procedures Push and Default_Response - type Button_Response_Ptr is access procedure - (B : access Button); - - procedure Push (B : access Button); - - procedure Set_Response (B : access Button; - R : in Button_Response_Ptr); - - procedure Default_Response (B : access Button); - - Emergency_Call : Boolean := False; - - procedure Emergency (B : access C3A0005_0.Button); - - type Button is - record - Response : Button_Response_Ptr - := Default_Response'Access; - end record; - -end C3A0005_0; - - ------------------------------------------------------------------------------ - -with TCTouch; -package body C3A0005_0 is - - procedure Push (B : access Button) is - begin - TCTouch.Touch( 'P' ); --------------------------------------------- P - -- Invoking subprogram designated by access value - B.Response (B); - end Push; - - - procedure Set_Response (B : access Button; - R : in Button_Response_Ptr) is - begin - TCTouch.Touch( 'S' ); --------------------------------------------- S - -- Set procedure value in record - B.Response := R; - end Set_Response; - - - procedure Default_Response (B : access Button) is - begin - TCTouch.Touch( 'D' ); --------------------------------------------- D - Default_Call := True; - end Default_Response; - - - procedure Emergency (B : access C3A0005_0.Button) is - begin - TCTouch.Touch( 'E' ); --------------------------------------------- E - Emergency_Call := True; - end Emergency; - -end C3A0005_0; - - ------------------------------------------------------------------------------ - -with TCTouch; -with Report; - -with C3A0005_0; - -procedure C3A0005 is - - Big_Red_Button : aliased C3A0005_0.Button; - -begin - - Report.Test ("C3A0005", "Check that access to subprogram may be " - & "stored within data structures, and that the " - & "access to subprogram can subsequently be called"); - - C3A0005_0.Push (Big_Red_Button'Access); - TCTouch.Validate("PD", "Using default value"); - TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" ); - - -- set Emergency value in Button.Response - C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access); - - C3A0005_0.Push (Big_Red_Button'Access); - TCTouch.Validate("SPE", "After set to Emergency value"); - TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call"); - - Report.Result; - -end C3A0005; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a b/gcc/testsuite/ada/acats/tests/c3/c3a0006.a deleted file mode 100644 index effab346581..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a +++ /dev/null @@ -1,163 +0,0 @@ --- C3A0006.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 access to subprogram may be stored within data --- structures, and that the access to subprogram can subsequently --- be called. --- --- TEST DESCRIPTION: --- Declare an access to function type in a package specification. --- Declare an array of the access type. Declare three different --- functions that can be referred to by the access to function type. --- --- In the main program, declare a key function that builds the array --- by calling each function indirectly through the access value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - -package C3A0006_0 is - - TC_Sine_Call : Integer := 0; - TC_Cos_Call : Integer := 0; - TC_Tan_Call : Integer := 0; - - Sine_Value : Float := 4.0; - Cos_Value : Float := 8.0; - Tan_Value : Float := 10.0; - - -- Type accesses to any function - type Trig_Function_Ptr is access function - (Angle : in Float) return Float; - - function Sine (Angle : in Float) return Float; - - function Cos (Angle : in Float) return Float; - - function Tan (Angle : in Float) return Float; - -end C3A0006_0; - - ------------------------------------------------------------------------------ - - -package body C3A0006_0 is - - function Sine (Angle : in Float) return Float is - begin - TC_Sine_Call := TC_Sine_Call + 1; - Sine_Value := Sine_Value + Angle; - return Sine_Value; - end Sine; - - - function Cos (Angle: in Float) return Float is - begin - TC_Cos_Call := TC_Cos_Call + 1; - Cos_Value := Cos_Value - Angle; - return Cos_Value; - end Cos; - - - function Tan (Angle : in Float) return Float is - begin - TC_Tan_Call := TC_Tan_Call + 1; - Tan_Value := (Tan_Value + (Tan_Value * Angle)); - return Tan_Value; - end Tan; - - -end C3A0006_0; - ------------------------------------------------------------------------------ - - -with Report; - -with C3A0006_0; - -procedure C3A0006 is - - Trig_Value, Theta : Float := 0.0; - - Total_Routines : constant := 3; - - Sine_Total : constant := 7.0; - Cos_Total : constant := 5.0; - Tan_Total : constant := 75.0; - - Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr; - - - -- Key function to build the table - function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr; - Operand : Float) return Float is - begin - return (Func(Operand)); - end Call_Trig_Func; - - -begin - - Report.Test ("C3A0006", "Check that access to subprogram may be " & - "stored within data structures, and that the access " & - "to subprogram can subsequently be called"); - - Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access, - C3A0006_0.Tan'Access); - - -- increase the value of Theta to build the table - for I in 1 .. Total_Routines loop - Theta := Theta + 0.5; - for J in 1 .. Total_Routines loop - Trig_Value := Call_Trig_Func (Trig_Table(J), Theta); - end loop; - end loop; - - if C3A0006_0.TC_Sine_Call /= Total_Routines - or C3A0006_0.TC_Cos_Call /= Total_Routines - or C3A0006_0.TC_Tan_Call /= Total_Routines then - Report.Failed ("Incorrect subprograms result"); - end if; - - if C3A0006_0.Sine_Value /= Sine_Total - or C3A0006_0.Cos_Value /= Cos_Total - or C3A0006_0.Tan_Value /= Tan_Total then - Report.Failed ("Incorrect values returned from subprograms"); - end if; - - if Trig_Value /= Tan_Total then - Report.Failed ("Incorrect call order."); - end if; - - Report.Result; - -end C3A0006; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a b/gcc/testsuite/ada/acats/tests/c3/c3a0007.a deleted file mode 100644 index ff18d2f9e1d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a +++ /dev/null @@ -1,234 +0,0 @@ --- C3A0007.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 call to a subprogram via an access-to-subprogram value --- stored in a data structure will correctly dispatch according to the --- tag of the class-wide parameter passed via that call. --- --- TEST DESCRIPTION: --- Declare an access to procedure type in a package specification. --- Declare a root tagged type with the access to procedure type as a --- component. Declare three primitive procedures for the type that --- can be referred to by the access to procedure type. Use the access --- to procedure type to initialize the component of a record. --- --- Extend the root type with a record extension in another package --- specification. Declare a new primitive procedure for the extension --- (in addition to its three inherited subprograms). --- --- In the main program, declare an operation for the root tagged type --- which can be passed as an access value to change the initial value --- of the component. Call the inherited operation indirectly by --- dereferencing the access value to check on the initial value of the --- extension. Call inherited operations indirectly by dereferencing --- the access value to replace the initial value. Call the primitive --- procedure indirectly by dereferencing the access value to modify the --- extension. --- --- type Button --- procedure Push(Button) --- procedure Set_Response(Button,Button_Response_Ptr) --- procedure Default_Response(Button) --- --- type Priority_Button (new Button) --- procedures Push, Set_Response inherited --- procedure Default_Response --- procedure Set_Priority --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C3A0007_0 is - - Default_Call : Boolean := False; - - type Button is tagged private; - - type Button_Response_Ptr is access procedure - (B : in out Button'Class); - - procedure Push (B : in out Button); -- to be inherited - - procedure Set_Response (B : in out Button; -- to be inherited - R : in Button_Response_Ptr); - - procedure Response (B : in out Button); -- to be inherited - -private - procedure Default_Response(B: in out Button'Class); - type Button is tagged -- root tagged type - record - Action : Button_Response_Ptr - := Default_Response'Access; - end record; -end C3A0007_0; - -with C3A0007_0; -package C3A0007_1 is - - type Priority_Button is new C3A0007_0.Button - with record - Priority : Integer := 0; - end record; - - -- Inherits procedure Push from Button - -- Inherits procedure Set_Response from Button - - -- Override procedure Response from Button - procedure Response (B : in out Priority_Button); - - -- Primitive operation of the extension - procedure Set_Priority (B : in out Priority_Button); - -end C3A0007_1; - -with C3A0007_0; -package C3A0007_2 is - - Emergency_Call : Boolean := False; - - procedure Emergency (B : in out C3A0007_0.Button'Class); -end C3A0007_2; - ------------------------------------------------------------------------------ - -with TCTouch; -package body C3A0007_0 is - - procedure Push (B : in out Button) is - begin - TCTouch.Touch( 'P' ); --------------------------------------------- P - -- Invoking subprogram designated by access value - B.Action (B); - end Push; - - - procedure Set_Response (B : in out Button; - R : in Button_Response_Ptr) is - begin - TCTouch.Touch( 'S' ); --------------------------------------------- S - -- Set procedure value in record - B.Action := R; - end Set_Response; - - - procedure Response (B : in out Button) is - begin - TCTouch.Touch( 'D' ); --------------------------------------------- D - Default_Call := True; - end Response; - - procedure Default_Response (B : in out Button'Class) is - begin - TCTouch.Touch( 'C' ); --------------------------------------------- C - Response(B); - end Default_Response; - -end C3A0007_0; - -with TCTouch; -package body C3A0007_1 is - - procedure Set_Priority (B : in out Priority_Button) is - begin - TCTouch.Touch( 's' ); --------------------------------------------- s - B.Priority := 1; - end Set_Priority; - - procedure Response (B : in out Priority_Button) is - begin - TCTouch.Touch( 'd' ); --------------------------------------------- d - end Response; - -end C3A0007_1; - -with TCTouch; -package body C3A0007_2 is - procedure Emergency (B : in out C3A0007_0.Button'Class) is - begin - TCTouch.Touch( 'E' ); ------------------------------------------- E - Emergency_Call := True; - end Emergency; -end C3A0007_2; - ------------------------------------------------------------------------------ - -with Report; -with TCTouch; - -with C3A0007_0; -with C3A0007_1; -with C3A0007_2; -procedure C3A0007 is - - Pink_Button : C3A0007_0.Button; - Green_Button : C3A0007_1.Priority_Button; - -begin - - Report.Test ("C3A0007", "Check that a call to a subprogram via an " - & "access-to-subprogram value stored in a data " - & "structure will correctly dispatch according to " - & "the tag of the class-wide parameter passed " - & "via that call" ); - - -- Call inherited operation Push to set Default_Response value - -- in the extension. - - C3A0007_1.Push (Green_Button); - TCTouch.Validate("PCd", "First Green Button Push"); - - TCTouch.Assert_Not(C3A0007_0.Default_Call, - "Incorrect Green Default_Response"); - - C3A0007_0.Push (Pink_Button); - TCTouch.Validate("PCD", "First Pink Button Push"); - - -- Call inherited operations Set_Response and Push to set - -- Emergency value in the extension. - C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access); - C3A0007_1.Push (Green_Button); - TCTouch.Validate("SPE", "Second Green Button Push"); - - TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency"); - - C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access); - C3A0007_0.Push (Pink_Button); - TCTouch.Validate("SPE", "Second Pink Button Push"); - - -- Call primitive operation to set priority value - -- in the extension. - C3A0007_1.Set_Priority (Green_Button); - TCTouch.Validate("s", "Green Button Priority"); - - TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority"); - - Report.Result; - -end C3A0007; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a b/gcc/testsuite/ada/acats/tests/c3/c3a0008.a deleted file mode 100644 index 6cd9ce3ddf0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a +++ /dev/null @@ -1,150 +0,0 @@ --- C3A0008.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 subprogram references may be passed as parameters using --- access-to-subprogram types. Check that the passed subprograms may --- be invoked from within the called subprogram. --- --- TEST DESCRIPTION: --- Declare an access to function type in a package specification. --- Declare three different trig functions that can be referred to by --- the access to function type. --- --- In the main program, call each function indirectly by passing the --- access to subprogram value as parameter. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - -package Integrate_Lookup is - - TC_Log_Call : Boolean := False; - - TC_Cos_Call : Boolean := False; - - TC_Sine_Call : Boolean := False; - - -- Type accesses to functions Log, Sine, or Cos - type Integrand_Ptr is access function - (Angle : Float) return Float; - - function Log (Angle : in Float) return Float; - - function Sine (Angle : in Float) return Float; - - function Cos (Angle : in Float) return Float; - - function Integrate (Func : Integrand_Ptr; From, To: Float) - return Float; - -end Integrate_Lookup; - - ------------------------------------------------------------------------------ - - -package body Integrate_Lookup is - - - function Log (Angle : in Float) return Float is - begin - TC_Log_Call := True; - return 0.1; - end Log; - - - function Sine (Angle : in Float) return Float is - begin - TC_Sine_Call := True; - return 0.0; - end Sine; - - - function Cos (Angle : in Float) return Float is - begin - TC_Cos_Call := True; - return 1.0; - end Cos; - - - function Integrate (Func : Integrand_Ptr; From, To: Float) - return Float is - Theta : Float; - begin - -- calls the actual subprogram passed as parameter - Theta := Func (From) + Func (To); - return Theta; - end Integrate; - -end Integrate_Lookup; - - ------------------------------------------------------------------------------ - - -with Report; - -with Integrate_Lookup; - -procedure C3A0008 is - - Area : Float := 0.0; - -begin - - Report.Test ("C3A0008", "Check that subprogram references may be passed " - & "as parameters using access-to-subprogram types. " - & "Check that the passed subprograms may be invoked " - & "from within the called subprogram"); - - Area := Integrate_Lookup.Integrate - (Integrate_Lookup.Log'Access, 1.0, 2.0); - - If not Integrate_Lookup.TC_Log_Call or Area /= 0.2 then - Report.Failed ("Incorrect Log result"); - end if; - - Area := Integrate_Lookup.Integrate - (Integrate_Lookup.Sine'Access, 1.0, 2.0); - - If not Integrate_Lookup.TC_Sine_Call or Area /= 0.0 then - Report.Failed ("Incorrect Sine result"); - end if; - - Area := Integrate_Lookup.Integrate - (Integrate_Lookup.Cos'Access, 1.0, 2.0); - - If not Integrate_Lookup.TC_Cos_Call or Area /= 2.0 then - Report.Failed ("Incorrect Cos result"); - end if; - - Report.Result; - -end C3A0008; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a deleted file mode 100644 index ba3f2f6e1e7..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a +++ /dev/null @@ -1,219 +0,0 @@ --- C3A0009.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 subprogram references may be passed as parameters using --- access-to-subprogram types. Check that the passed subprograms may --- be invoked from within the called subprogram. --- --- TEST DESCRIPTION: --- Declare an access to procedure type in a package specification. --- Declare a root tagged type with the access to procedure type as a --- component. Declare three primitive procedures for the type that --- can be referred to by the access to procedure type. Use the access --- to procedure type to initialize the component of a record. --- --- Extend the root type with a private extension in the same package --- specification. Declare two new primitive subprograms for the extension --- (in addition to its three inherited subprograms). --- --- In the main program, declare an operation for the root tagged type --- which can be passed as an access value to change the initial value --- of the component. Call the inherited operations indirectly by --- de-referencing the access value to set value in the extension. --- Call the primitive function to modify the extension by passing --- the access value designating the primitive procedure as a parameter. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C3A0009_0 is -- Push_Buttons - - type Button is tagged private; - - -- Type accesses to procedures Push and Default_Response - type Button_Response_Ptr is access procedure - (B : in out Button); - - procedure Push (B : in out Button); -- to be inherited - - procedure Set_Response (B : in out Button; -- to be inherited - R : in Button_Response_Ptr); - - procedure Default_Response (B : in out Button); -- to be inherited - - type Alert_Button is new Button with private; -- private extension of - -- root tagged type - -- Inherits procedure Push from Button - -- Inherits procedure Set_Response from Button - -- Inherits procedure Default_Response from Button - - procedure Replace_Action( B: in out Alert_Button ); - - -- type accesses to procedure Default_Action - type Button_Action_Ptr is access procedure; - - -- The following function is needed to set value in the - -- extension's private component. - function Alert (B : in Alert_Button) return Button_Action_Ptr; - -private - - type Button is tagged -- root tagged type - record - Response : Button_Response_Ptr - := Default_Response'Access; - end record; - - procedure Default_Action; - - type Alert_Button is new Button with record - Action : Button_Action_Ptr - := Default_Action'Access; - end record; - -end C3A0009_0; - - ------------------------------------------------------------------------------ - - -with TCTouch; -package body C3A0009_0 is - - procedure Push (B : in out Button) is - begin - TCTouch.Touch( 'P' ); --------------------------------------------- P - -- Invoking subprogram designated by access value - B.Response (B); - end Push; - - - procedure Set_Response (B : in out Button; - R : in Button_Response_Ptr) is - begin - TCTouch.Touch( 'S' ); --------------------------------------------- S - -- Set procedure value in record - B.Response := R; - end Set_Response; - - - procedure Default_Response (B : in out Button) is - begin - TCTouch.Touch( 'D' ); --------------------------------------------- D - end Default_Response; - - - procedure Default_Action is - begin - TCTouch.Touch( 'd' ); --------------------------------------------- d - end Default_Action; - - procedure Replacement_Action is - begin - TCTouch.Touch( 'r' ); --------------------------------------------- r - end Replacement_Action; - - procedure Replace_Action( B: in out Alert_Button ) is - begin - TCTouch.Touch( 'R' ); --------------------------------------------- R - B.Action := Replacement_Action'Access; - end Replace_Action; - - function Alert (B : in Alert_Button) return Button_Action_Ptr is - begin - TCTouch.Touch( 'A' ); --------------------------------------------- A - return (B.Action); - end Alert; - -end C3A0009_0; - ------------------------------------------------------------------------------ - -with C3A0009_0; -package C3A0009_1 is -- Emergency_Items - package Push_Buttons renames C3A0009_0; - - procedure Emergency (B : in out Push_Buttons.Button); -end C3A0009_1; - -with TCTouch; -package body C3A0009_1 is -- Emergency_Items - procedure Emergency (B : in out Push_Buttons.Button) is - begin - TCTouch.Touch( 'E' ); ------------------------------------------- E - end Emergency; -end C3A0009_1; ------------------------------------------------------------------------------ - -with Report; - -with C3A0009_0, C3A0009_1; -with TCTouch; -procedure C3A0009 is - - package Push_Buttons renames C3A0009_0; - package Emergency_Items renames C3A0009_1; - - Black_Button : Push_Buttons.Alert_Button; - Alert_Ptr : Push_Buttons.Button_Action_Ptr; - -begin - - Report.Test ("C3A0009", "Check that subprogram references may be passed " - & "as parameters using access-to-subprogram types. " - & "Check that the passed subprograms may be " - & "invoked from within the called subprogram"); - - - Push_Buttons.Push( Black_Button ); - Push_Buttons.Alert( Black_Button ).all; - - TCTouch.Validate( "PDAd", "Default operation set" ); - - -- Call inherited operations Set_Response and Push to set - -- Emergency value in the extension. - Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access); - - - Push_Buttons.Push( Black_Button ); - Push_Buttons.Alert( Black_Button ).all; - - TCTouch.Validate( "SPEAd", "Altered Response set" ); - - -- Call primitive operation to set action value in the extension. - Push_Buttons.Replace_Action( Black_Button ); - - - Push_Buttons.Push( Black_Button ); - Push_Buttons.Alert( Black_Button ).all; - - TCTouch.Validate( "RPEAr", "Altered Action set" ); - - Report.Result; -end C3A0009; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a b/gcc/testsuite/ada/acats/tests/c3/c3a0010.a deleted file mode 100644 index 5628c9518de..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a +++ /dev/null @@ -1,158 +0,0 @@ --- C3A0010.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 access-to-subprogram type in a generic instance may be --- used to declare access-to-subprogram objects which invoke subprograms --- in the instance. --- --- TEST DESCRIPTION: --- Declare a numeric type in the visible part of a generic package. --- Declare two different math procedures that can be referred to by --- the access to procedure type. --- --- In the main program, instantiate the generic. Declare an access --- to procedure type. Call each procedure indirectly by dereferencing --- the access value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 05 APR 96 SAIC Header correction for 2.1 --- ---! - -generic - type Real_Num is digits <>; - -package C3A0010_0 is - - -- Type accesses to any math procedure - type Math_Procedure_Ptr is access procedure - (First_Num, Second_Num : in Real_Num; - Result_Num : out Real_Num); - - procedure Add (First_Num, Second_Num : in Real_Num; - Result_Num : out Real_Num); - - procedure Subtract (First_Num, Second_Num : in Real_Num; - Result_Num : out Real_Num); - -end C3A0010_0; - - ------------------------------------------------------------------------------ - - -package body C3A0010_0 is - - procedure Add (First_Num, Second_Num : in Real_Num; - Result_Num : out Real_Num) is - begin - Result_Num := First_Num + Second_Num; - end Add; - - - procedure Subtract (First_Num, Second_Num : in Real_Num; - Result_Num : out Real_Num) is - begin - Result_Num := First_Num - Second_Num; - end Subtract; - -end C3A0010_0; - ------------------------------------------------------------------------------ - -with Report; -with C3A0010_0; - -procedure C3A0010 is - - type Real is digits 2; - - subtype Math_Float is Real range -10.0 .. 10.0; - - package Math_Pk is new C3A0010_0 (Real_Num => Math_Float); - - Math_Access : Math_Pk.Math_Procedure_Ptr; - - Total_Num : Math_Float := 0.0; - First_Num : Math_Float := 1.0; - Second_Num : Math_Float := 2.0; - - procedure Max( A_Num, B_Num: in Math_Float; Result : out Math_Float ) is - begin - if A_Num > B_Num then - Result := A_Num; - else - Result := B_Num; - end if; - end Max; - - procedure Due_Process( Process: Math_Pk.Math_Procedure_Ptr ) is - begin - Process(First_Num, Second_Num, Total_Num); - end Due_Process; - -begin - - Report.Test ("C3A0010", "Check that an access-to-subprogram type in a " - & "generic instance may be used to declare " - & "access-to-subprogram objects which invoke " - & "subprograms in the instance"); - --- Check for correct defaulting - if Math_Pk."/="( Math_Access, null) then - Report.Failed("subprogram access type object not initialized to null"); - end if; - - Math_Access := Math_Pk.Add'Access; - - -- Invoking Add procedure designated by access value - Due_Process( Math_Access ); - - If Total_Num /= 3.0 then - Report.Failed ("Incorrect Add result"); - end if; - - Math_Access := Math_Pk.Subtract'Access; - - Due_Process( Math_Access ); - - If Total_Num /= -1.0 then - Report.Failed ("Incorrect Subtract result"); - end if; - - Math_Access := Max'Access; - - Due_Process( Math_Access ); - - If Total_Num /= 2.0 then - Report.Failed ("Incorrect Max result"); - end if; - - Report.Result; - -end C3A0010; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a b/gcc/testsuite/ada/acats/tests/c3/c3a0011.a deleted file mode 100644 index 985080659a1..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a +++ /dev/null @@ -1,186 +0,0 @@ --- C3A0011.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 access-to-subprogram object whose type is declared in a --- parent package, may be used to invoke subprograms in a child package. --- Check that such access objects may be stored in a data structure and --- that subprograms may be called by walking the data structure. --- --- TEST DESCRIPTION: --- In the package, declare an access to procedure type. Declare an --- array of the access type. Declare three different procedures that --- can be referred to by the access to procedure type. --- --- In the visible child package, declare two procedures that can be --- referred to by the access to procedure type of the parent. Build --- the array by calling each procedure indirectly through the access --- value. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Dec 94 SAIC Improved visibility of "/=" in main body --- ---! - -package C3A0011_0 is -- Interpreter - - type Compass_Point is mod 360; - - function Heading return Compass_Point; - - -- Type accesses to any procedure - type Action_Ptr is access procedure; - - -- Array of access to procedure - type Action_Array is array (Natural range <>) of Action_Ptr; - - procedure Rotate_Left; - - procedure Rotate_Right; - - procedure Center; - -private - The_Heading : Compass_Point := Compass_Point'First; - -end C3A0011_0; - - ------------------------------------------------------------------------------ - - -package body C3A0011_0 is - - function Heading return Compass_Point is - begin - return The_Heading; - end Heading; - - procedure Rotate_Left is - begin - The_Heading := The_Heading - 90; - end Rotate_Left; - - - procedure Rotate_Right is - begin - The_Heading := The_Heading + 90; - end Rotate_Right; - - - procedure Center is - begin - The_Heading := 0; - end Center; - -end C3A0011_0; - - ------------------------------------------------------------------------------ - - -package C3A0011_0.Action is - - procedure Rotate_Front; - - procedure Rotate_Back; - -end C3A0011_0.Action; - - ------------------------------------------------------------------------------ - - -package body C3A0011_0.Action is - - procedure Rotate_Front is - begin - The_Heading := The_Heading + 5; - end Rotate_Front; - - - procedure Rotate_Back is - begin - The_Heading := The_Heading - 5; - end Rotate_Back; - -end C3A0011_0.Action; - - ------------------------------------------------------------------------------ - - -with C3A0011_0.Action; - -with Report; - -procedure C3A0011 is - - Total_Actions : constant := 6; - - Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions); - - type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point; - - Action_Results : Result_Array(1 .. Total_Actions); - - package IA renames C3A0011_0.Action; - -begin - - Report.Test ("C3A0011", "Check that an access-to-subprogram object whose " - & "type is declared in a parent package, may be " - & "used to invoke subprograms in a child package. " - & "Check that such access objects may be stored in " - & "a data structure and that subprograms may be " - & "called by walking the data structure"); - - -- Build the action sequence - Action_Sequence := (C3A0011_0.Rotate_Left'Access, - C3A0011_0.Center'Access, - C3A0011_0.Rotate_Right'Access, - IA.Rotate_Front'Access, - C3A0011_0.Center'Access, - IA.Rotate_Back'Access); - - -- Build the expected result - Action_Results := ( 270, 0, 90, 95, 0, 355 ); - - -- Assign actions by invoking subprogram designated by access value - for I in Action_Sequence'Range loop - Action_Sequence(I).all; - if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then - Report.Failed ("Expecting " - & C3A0011_0.Compass_Point'Image(Action_Results(I)) - & " Got" - & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading)); - end if; - end loop; - - Report.Result; - -end C3A0011; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a b/gcc/testsuite/ada/acats/tests/c3/c3a00120.a deleted file mode 100644 index 5ce7b6175d5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a +++ /dev/null @@ -1,83 +0,0 @@ --- C3A00120.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 file C3A00122.AM - -- - -- TEST DESCRIPTION: - -- See file C3A00122.AM - -- - -- TEST FILES: - -- The following files comprise this test: - -- - -- => C3A00120.A - -- C3A00121.A - -- C3A00122.AM - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - package C3A0012_0 is - - type Call_Kind is (No_Call_Made, Fast_Call, Accurate_Call, - Table_Lookup_Call); - - Log_Result : Float := 0.0; - - -- Type accesses to any log procedure - type Log_Procedure_Ptr is access procedure - (Angle : in Float; Log_Call : out Call_Kind); - - procedure Log_Calc_Fast (Angle : in Float; - Method : out Call_Kind); - - procedure Log_Calc_Acc (Angle : in Float; - Method : out Call_Kind); - - procedure Log_Calc_Table (Angle : in Float; - Method : out Call_Kind); - - end C3A0012_0; - - - --=======================================================================-- - - - package body C3A0012_0 is - - procedure Log_Calc_Fast (Angle : in Float; - Method : out Call_Kind) is separate; - - procedure Log_Calc_Acc (Angle : in Float; - Method : out Call_Kind) is separate; - - procedure Log_Calc_Table (Angle : in Float; - Method : out Call_Kind) is separate; - - end C3A0012_0; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a b/gcc/testsuite/ada/acats/tests/c3/c3a00121.a deleted file mode 100644 index acb1dab99aa..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a +++ /dev/null @@ -1,76 +0,0 @@ --- C3A00121.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 file C3A00122.AM - -- - -- TEST DESCRIPTION: - -- See file C3A00122.AM - -- - -- TEST FILES: - -- The following files comprise this test: - -- - -- C3A00120.A - -- => C3A00121.A - -- C3A00122.AM - -- - -- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- - --! - - Separate (C3A0012_0) - procedure Log_Calc_Fast (Angle : in Float; - Method : out Call_Kind) is - begin - C3A0012_0.Log_Result := Angle; - Method := Fast_Call; - end Log_Calc_Fast; - - - --=======================================================================-- - - - Separate (C3A0012_0) - procedure Log_Calc_Acc (Angle : in Float; - Method : out Call_Kind) is - begin - C3A0012_0.Log_Result := Angle; - Method := Accurate_Call; - end Log_Calc_Acc; - - - --=======================================================================-- - - - Separate (C3A0012_0) - procedure Log_Calc_Table (Angle : in Float; - Method : out Call_Kind) is - begin - C3A0012_0.Log_Result := Angle; - Method := Table_Lookup_Call; - end Log_Calc_Table; - diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a b/gcc/testsuite/ada/acats/tests/c3/c3a0013.a deleted file mode 100644 index b23d4ee1151..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a +++ /dev/null @@ -1,347 +0,0 @@ --- C3A0013.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 general access type object may reference allocated --- pool objects as well as aliased objects. (3,4) --- Check that formal parameters of tagged types are implicitly --- defined as aliased; check that the 'Access of these formal --- parameters designates the correct object with the correct --- tag. (5) --- Check that the current instance of a limited type is defined as --- aliased. (5) --- --- TEST DESCRIPTION: --- This test takes from the hierarchy defined in C390003; making --- the root type Vehicle limited private. It also shifts the --- abstraction to include the notion of a transmission, an object --- which is contained within any vehicle. Using an access --- discriminant, any subprogram which operates on a transmission --- may also reference the vehicle in which it is installed. --- --- Class Hierarchy: --- Vehicle Transmission --- / \ --- Truck Car --- --- Contains: --- Vehicle( Transmission ) --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Dec 94 SAIC Fixed accessibility problems --- ---! - -package C3A0013_1 is - type Vehicle is tagged limited private; - type Vehicle_ID is access all Vehicle'Class; - - -- Constructors - procedure Create ( It : in out Vehicle; - Wheels : Natural := 4 ); - -- Modifiers - procedure Accelerate ( It : in out Vehicle ); - procedure Decelerate ( It : in out Vehicle ); - procedure Up_Shift ( It : in out Vehicle ); - procedure Stop ( It : in out Vehicle ); - - -- Selectors - function Speed ( It : Vehicle ) return Natural; - function Wheels ( It : Vehicle ) return Natural; - function Gear_Factor( It : Vehicle ) return Natural; - - -- TC_Ops - procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ); - - -- dispatching procedure used to check tag correctness - procedure TC_Validate( It : Vehicle; - TC_ID : Character); - -private - - type Transmission(Within: access Vehicle'Class) is limited record - Engaged : Boolean := False; - Gear : Integer range -1..5 := 0; - end record; - - -- Current instance of a limited type is defined as aliased - - type Vehicle is tagged limited record - Wheels: Natural; - Speed : Natural; - Power_Train: Transmission( Vehicle'Access ); - end record; -end C3A0013_1; - -with C3A0013_1; -package C3A0013_2 is - type Car is new C3A0013_1.Vehicle with private; - procedure TC_Validate( It : Car; - TC_ID : Character); - function Gear_Factor( It : Car ) return Natural; -private - type Car is new C3A0013_1.Vehicle with record - Displacement : Natural; - end record; -end C3A0013_2; - -with C3A0013_1; -package C3A0013_3 is - type Truck is new C3A0013_1.Vehicle with private; - procedure TC_Validate( It : Truck; - TC_ID : Character); - function Gear_Factor( It : Truck ) return Natural; -private - type Truck is new C3A0013_1.Vehicle with record - Displacement : Natural; - end record; -end C3A0013_3; - -with Report; -package body C3A0013_1 is - - procedure Create ( It : in out Vehicle; - Wheels : Natural := 4 ) is - begin - It.Wheels := Wheels; - It.Speed := 0; - end Create; - - procedure Accelerate( It : in out Vehicle ) is - begin - It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all ); - end Accelerate; - - procedure Decelerate( It : in out Vehicle ) is - begin - It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all ); - end Decelerate; - - procedure Stop ( It : in out Vehicle ) is - begin - It.Speed := 0; - It.Power_Train.Engaged := False; - end Stop; - - function Gear_Factor( It : Vehicle ) return Natural is - begin - return It.Power_Train.Gear; - end Gear_Factor; - - function Speed ( It : Vehicle ) return Natural is - begin - return It.Speed; - end Speed; - - function Wheels ( It : Vehicle ) return Natural is - begin - return It.Wheels; - end Wheels; - - -- formal tagged parameters are implicitly aliased - - procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is - License: Vehicle_ID := It'Unchecked_Access; - begin - if Speed( License.all ) /= Speed_Trap then - Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap)); - end if; - end TC_Validate; - - procedure TC_Validate( It : Vehicle; - TC_ID : Character) is - begin - if TC_ID /= 'V' then - Report.Failed("Dispatched to Vehicle"); - end if; - if Wheels( It ) /= 1 then - Report.Failed("Not a Vehicle"); - end if; - end TC_Validate; - - procedure Up_Shift( It: in out Vehicle ) is - begin - It.Power_Train.Gear := It.Power_Train.Gear +1; - It.Power_Train.Engaged := True; - Accelerate( It ); - end Up_Shift; -end C3A0013_1; - -with Report; -package body C3A0013_2 is - - procedure TC_Validate( It : Car; - TC_ID : Character ) is - begin - if TC_ID /= 'C' then - Report.Failed("Dispatched to Car"); - end if; - if Wheels( It ) /= 4 then - Report.Failed("Not a Car"); - end if; - end TC_Validate; - - function Gear_Factor( It : Car ) return Natural is - begin - return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2; - end Gear_Factor; - -end C3A0013_2; - -with Report; -package body C3A0013_3 is - - procedure TC_Validate( It : Truck; - TC_ID : Character) is - begin - if TC_ID /= 'T' then - Report.Failed("Dispatched to Truck"); - end if; - if Wheels( It ) /= 3 then - Report.Failed("Not a Truck"); - end if; - end TC_Validate; - - function Gear_Factor( It : Truck ) return Natural is - begin - return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3; - end Gear_Factor; - -end C3A0013_3; - -package C3A0013_4 is - procedure Perform_Tests; -end C3A0013_4; - -with Report; -with C3A0013_1; -with C3A0013_2; -with C3A0013_3; -package body C3A0013_4 is - package Root renames C3A0013_1; - package Cars renames C3A0013_2; - package Trucks renames C3A0013_3; - - type Car_Pool is array(1..4) of aliased Cars.Car; - Commuters : Car_Pool; - - My_Car : aliased Cars.Car; - Company_Car : Root.Vehicle_ID; - Repair_Shop : Root.Vehicle_ID; - - The_Vehicle : Root.Vehicle; - The_Car : Cars.Car; - The_Truck : Trucks.Truck; - - procedure TC_Dispatch( Ptr : Root.Vehicle_ID; - Char : Character ) is - begin - Root.TC_Validate( Ptr.all, Char ); - end TC_Dispatch; - - procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class; - Char: Character) is - begin - TC_Dispatch( Item'Unchecked_Access, Char ); - end TC_Check_Formal_Access; - - procedure Perform_Tests is - begin -- Main test procedure. - - for Lane in Commuters'Range loop - Cars.Create( Commuters(Lane) ); - for Excitement in 1..Lane loop - Cars.Up_Shift( Commuters(Lane) ); - end loop; - end loop; - - Cars.Create( My_Car ); - Cars.Up_Shift( My_Car ); - Cars.TC_Validate( My_Car, 2 ); - - Root.Create( The_Vehicle, 1 ); - Cars.Create( The_Car , 4 ); - Trucks.Create( The_Truck, 3 ); - - TC_Check_Formal_Access( The_Vehicle, 'V' ); - TC_Check_Formal_Access( The_Car, 'C' ); - TC_Check_Formal_Access( The_Truck, 'T' ); - - Root.Up_Shift( The_Vehicle ); - Cars.Up_Shift( The_Car ); - Trucks.Up_Shift( The_Truck ); - - Root.TC_Validate( The_Vehicle, 1 ); - Cars.TC_Validate( The_Car, 2 ); - Trucks.TC_Validate( The_Truck, 3 ); - - -- general access type may reference allocated objects - - Company_Car := new Cars.Car; - Root.Create( Company_Car.all ); - Root.Up_Shift( Company_Car.all ); - Root.Up_Shift( Company_Car.all ); - Root.TC_Validate( Company_Car.all, 6 ); - - -- general access type may reference aliased objects - - Repair_Shop := My_Car'Access; - Root.TC_Validate( Repair_Shop.all, 2 ); - - -- general access type may reference aliased objects - - Construction: declare - type Speed_List is array(Commuters'Range) of Natural; - Accelerations : constant Speed_List := (2, 6, 12, 20); - begin - for Rotation in Commuters'Range loop - Repair_Shop := Commuters(Rotation)'Access; - Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) ); - end loop; - end Construction; - -end Perform_Tests; - -end C3A0013_4; - -with C3A0013_4; -with Report; -procedure C3A0013 is -begin - - Report.Test ("C3A0013", "Check general access types. Check aliased " - & "nature of formal tagged type parameters. " - & "Check aliased nature of the current " - & "instance of a limited type. Check the " - & "constraining of actual subtypes for " - & "discriminated objects" ); - - C3A0013_4.Perform_Tests; - - Report.Result; -end C3A0013; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a deleted file mode 100644 index c83ab4f5e28..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a +++ /dev/null @@ -1,453 +0,0 @@ --- C3A0014.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 if the view defined by an object declaration is aliased, --- and the type of the object has discriminants, then the object is --- constrained by its initial value even if its nominal subtype is --- unconstrained. --- --- Check that the attribute A'Constrained returns True if A is a formal --- out or in out parameter, or dereference thereof, and A denotes an --- aliased view of an object. --- --- TEST DESCRIPTION: --- These rules apply to objects of a record type with defaulted --- discriminants, which may be unconstrained variables. If such a --- variable is declared to be aliased, then it is constrained by its --- initial value, and the value of the discriminant cannot be changed --- for the life of the variable. --- --- The rules do not apply to aliased component types because if such --- types are discriminated they must be constrained. --- --- A'Constrained returns True if A denotes a constant, value, or --- constrained variable. Since aliased objects are constrained, it must --- return True if the actual parameter corresponding to a formal --- parameter A is an aliased object. The objective only mentions formal --- parameters of mode out and in out, since parameters of mode in are --- by definition constant, and would result in True anyway. --- --- This test declares aliased objects of a nominally unconstrained --- record subtype, both with and without initialization expressions. --- It also declares access values which point to such objects. It then --- checks that Constraint_Error is raised if an attempt is made to --- change the discriminant value of an aliased object, either directly --- or via a dereference of an access value. For aliased objects, this --- check is also performed for subprogram parameters of mode out. --- --- The test also passes aliased objects and access values which point --- to such objects as actuals to subprograms and verifies, for parameter --- modes out and in out, that P'Constrained returns true if P is the --- corresponding formal parameter or a dereference thereof. --- --- Additionally, the test declares a generic package which declares a --- an aliased object of a formal derived unconstrained type, which is --- is initialized with the value of a formal object of that type. --- procedure declared within the generic assigns a value to the object --- which has the same discriminant value as the formal derived type's --- ancestor type. The generic is instantiated with various actuals --- for the formal object, and the procedure is called. The test verifies --- that Constraint_Error is raised if the discriminant values of the --- actual corresponding to the formal object and the value assigned --- by the procedure are not equal. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors. --- ---! - -package C3A0014_0 is - - subtype Reasonable is Integer range 1..10; - -- Unconstrained (sub)type. - type UC (D: Reasonable := 2) is record -- Discriminant default. - S: String (1 .. D) := "Hi"; -- Default value. - end record; - - type AUC is access all UC; - - -- Nominal subtype is unconstrained for the following: - - Obj0 : UC; -- An unconstrained object. - - Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization, - -- an unconstrained object. - - Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization, - -- a constrained object. - - Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view), - -- a constrained object. - Obj4 : aliased UC; -- Aliased without initialization, Obj4 - -- constrained here to initial value - -- taken from default for type. - - Ptr1 : AUC := new UC'(Obj1); - Ptr2 : AUC := new UC; - Ptr3 : AUC := Obj3'Access; - Ptr4 : AUC := Obj4'Access; - - - procedure NP_Proc (A: out UC); - procedure NP_Cons (A: in out UC; B: out Boolean); - procedure P_Cons (A: out AUC; B: out Boolean); - - - generic - type FT is new UC; - FObj : in out FT; - package Gen is - F : aliased FT := FObj; -- Constrained if FT has discriminants. - procedure Proc; - end Gen; - - - procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ); - - -end C3A0014_0; - - - --=======================================================================-- - -with Report; - -package body C3A0014_0 is - - procedure NP_Proc (A: out UC) is - begin - A := (3, "Bye"); - end NP_Proc; - - procedure NP_Cons (A: in out UC; B: out Boolean) is - begin - B := A'Constrained; - end NP_Cons; - - procedure P_Cons (A: out AUC; B: out Boolean) is - begin - B := A.all'Constrained; - end P_Cons; - - - package body Gen is - - procedure Proc is - begin - F := (2, "Fi"); - end Proc; - - end Gen; - - - procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is - Default : UC := (1, "!"); -- Unique value. - begin - if P = Default then -- Both If branches can't do the same thing. - Report.Failed (Msg & ": Constraint_Error not raised"); - else -- Subtests should always select this path. - Report.Failed ("Constraint_Error not raised " & Msg); - end if; - end Avoid_Optimization_and_Fail; - - -end C3A0014_0; - - - --=======================================================================-- - - -with C3A0014_0; use C3A0014_0; -with Report; - -procedure C3A0014 is -begin - - Report.Test("C3A0014", "Check that if the view defined by an object " & - "declaration is aliased, and the type of the " & - "object has discriminants, then the object is " & - "constrained by its initial value even if its " & - "nominal subtype is unconstrained. Check that " & - "the attribute A'Constrained returns True if A " & - "is a formal out or in out parameter, or " & - "dereference thereof, and A denotes an aliased " & - "view of an object"); - - Non_Pointer_Block: - begin - - begin - Obj0 := (3, "Bye"); -- OK: Obj0 not constrained. - if Obj0 /= (3, "Bye") then - Report.Failed - ("Wrong value after aggregate assignment - Subtest 1"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 1"); - end; - - - begin - Obj1 := (3, "Bye"); -- OK: Obj1 not constrained. - if Obj1 /= (3, "Bye") then - Report.Failed - ("Wrong value after aggregate assignment - Subtest 2"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 2"); - end; - - - begin - Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5). - Avoid_Optimization_and_Fail (Obj2, "Subtest 3"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5). - Avoid_Optimization_and_Fail (Obj3, "Subtest 4"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2). - Avoid_Optimization_and_Fail (Obj4, "Subtest 5"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - exception - when others => Report.Failed("Unexpected exception: Non_Pointer_Block"); - end Non_Pointer_Block; - - - Pointer_Block: - begin - - begin - Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5). - Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2). - Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5). - Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2). - Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - exception - when others => Report.Failed("Unexpected exception: Pointer_Block"); - end Pointer_Block; - - - Subprogram_Block: - declare - Is_Constrained : Boolean; - begin - - begin - NP_Proc (Obj0); -- OK: Obj0 not constrained, can - if Obj0 /= (3, "Bye") then -- change discriminant value. - Report.Failed - ("Wrong value after aggregate assignment - Subtest 10"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 10"); - end; - - - begin - NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5). - Avoid_Optimization_and_Fail (Obj2, "Subtest 11"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5). - Avoid_Optimization_and_Fail (Obj3, "Subtest 12"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2). - Avoid_Optimization_and_Fail (Obj4, "Subtest 13"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - - begin - Is_Constrained := True; - NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1 - if Is_Constrained then -- is not constrained. - Report.Failed ("Wrong result from 'Constrained - Subtest 14"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 14"); - end; - - - begin - Is_Constrained := False; - NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is - if not Is_Constrained then -- constrained. - Report.Failed ("Wrong result from 'Constrained - Subtest 15"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 15"); - end; - - - - - begin - Is_Constrained := False; - P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all - if not Is_Constrained then -- is constrained. - Report.Failed ("Wrong result from 'Constrained - Subtest 16"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 16"); - end; - - - begin - Is_Constrained := False; - P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all - if not Is_Constrained then -- is constrained. - Report.Failed ("Wrong result from 'Constrained - Subtest 17"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 17"); - end; - - - exception - when others => Report.Failed("Exception raised in Subprogram_Block"); - end Subprogram_Block; - - - Generic_Block: - declare - - type NUC is new UC; - - Obj : NUC; - - - package Instance_A is new Gen (NUC, Obj); - package Instance_B is new Gen (UC, Obj2); - package Instance_C is new Gen (UC, Obj3); - package Instance_D is new Gen (UC, Obj4); - - begin - - begin - Instance_A.Proc; -- OK: Obj.D = 2. - if Instance_A.F /= (2, "Fi") then - Report.Failed - ("Wrong value after aggregate assignment - Subtest 18"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 18"); - end; - - - begin - Instance_B.Proc; -- C_E: Obj2.D = 5. - Avoid_Optimization_and_Fail (Obj2, "Subtest 19"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Instance_C.Proc; -- C_E: Obj3.D = 5. - Avoid_Optimization_and_Fail (Obj3, "Subtest 20"); - exception - when Constraint_Error => null; -- Exception is expected. - end; - - - begin - Instance_D.Proc; -- OK: Obj4.D = 2. - if Instance_D.F /= (2, "Fi") then - Report.Failed - ("Wrong value after aggregate assignment - Subtest 21"); - end if; - exception - when others => - Report.Failed ("Unexpected exception raised - Subtest 21"); - end; - - exception - when others => Report.Failed("Exception raised in Generic_Block"); - end Generic_Block; - - - Report.Result; - -end C3A0014; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a b/gcc/testsuite/ada/acats/tests/c3/c3a0015.a deleted file mode 100644 index 856c910f92d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a +++ /dev/null @@ -1,267 +0,0 @@ --- C3A0015.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 derived access type has the same storage pool as its --- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)). --- --- CHANGE HISTORY: --- 24 JAN 2001 PHL Initial version. --- 29 JUN 2001 RLB Reformatted for ACATS. --- ---! -with System.Storage_Elements; -use System.Storage_Elements; -with System.Storage_Pools; -use System.Storage_Pools; -package C3A0015_0 is - - type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with - record - First_Free : Storage_Count := 1; - Contents : Storage_Array (1 .. Storage_Size); - end record; - - procedure Allocate (Pool : in out C3A0015_0.Pool; - Storage_Address : out System.Address; - Size_In_Storage_Elements : in Storage_Count; - Alignment : in Storage_Count); - - procedure Deallocate (Pool : in out C3A0015_0.Pool; - Storage_Address : in System.Address; - Size_In_Storage_Elements : in Storage_Count; - Alignment : in Storage_Count); - - function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count; - -end C3A0015_0; - -package body C3A0015_0 is - - use System; - - procedure Allocate (Pool : in out C3A0015_0.Pool; - Storage_Address : out System.Address; - Size_In_Storage_Elements : in Storage_Count; - Alignment : in Storage_Count) is - Unaligned_Address : constant System.Address := - Pool.Contents (Pool.First_Free)'Address; - Unalignment : Storage_Count; - begin - Unalignment := Unaligned_Address mod Alignment; - if Unalignment = 0 then - Storage_Address := Unaligned_Address; - Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements; - else - Storage_Address := - Pool.Contents (Pool.First_Free + Alignment - Unalignment)' - Address; - Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements + - Alignment - Unalignment; - end if; - end Allocate; - - procedure Deallocate (Pool : in out C3A0015_0.Pool; - Storage_Address : in System.Address; - Size_In_Storage_Elements : in Storage_Count; - Alignment : in Storage_Count) is - begin - if Storage_Address + Size_In_Storage_Elements = - Pool.Contents (Pool.First_Free)'Address then - -- Only deallocate if the block is at the end. - Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements; - end if; - end Deallocate; - - function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is - begin - return Pool.Storage_Size; - end Storage_Size; - -end C3A0015_0; - -with Ada.Exceptions; -use Ada.Exceptions; -with Ada.Unchecked_Deallocation; -with Report; -use Report; -with System.Storage_Elements; -use System.Storage_Elements; -with C3A0015_0; -procedure C3A0015 is - - type Standard_Pool is access Float; - type Derived_Standard_Pool is new Standard_Pool; - type Derived_Derived_Standard_Pool is new Derived_Standard_Pool; - - type User_Defined_Pool is access Integer; - type Derived_User_Defined_Pool is new User_Defined_Pool; - type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool; - - My_Pool : C3A0015_0.Pool (1024); - for User_Defined_Pool'Storage_Pool use My_Pool; - - generic - type Designated is private; - Value : Designated; - type Acc is access Designated; - type Derived_Acc is new Acc; - procedure Check (Subtest : String; User_Defined_Pool : Boolean); - - procedure Check (Subtest : String; User_Defined_Pool : Boolean) is - - procedure Deallocate is - new Ada.Unchecked_Deallocation (Object => Designated, - Name => Acc); - procedure Deallocate is - new Ada.Unchecked_Deallocation (Object => Designated, - Name => Derived_Acc); - - First_Free : Storage_Count; - X : Acc; - Y : Derived_Acc; - begin - if User_Defined_Pool then - First_Free := My_Pool.First_Free; - end if; - X := new Designated'(Value); - if User_Defined_Pool and then First_Free >= My_Pool.First_Free then - Failed (Subtest & - " - Allocation didn't consume storage in the pool - 1"); - else - First_Free := My_Pool.First_Free; - end if; - - Y := Derived_Acc (X); - if User_Defined_Pool and then First_Free /= My_Pool.First_Free then - Failed (Subtest & - " - Conversion did consume storage in the pool - 1"); - end if; - if Y.all /= Value then - Failed (Subtest & - " - Incorrect allocation/conversion of access values - 1"); - end if; - - Deallocate (Y); - if User_Defined_Pool and then First_Free <= My_Pool.First_Free then - Failed (Subtest & - " - Deallocation didn't release storage from the pool - 1"); - else - First_Free := My_Pool.First_Free; - end if; - - Y := new Designated'(Value); - if User_Defined_Pool and then First_Free >= My_Pool.First_Free then - Failed (Subtest & - " - Allocation didn't consume storage in the pool - 2"); - else - First_Free := My_Pool.First_Free; - end if; - - X := Acc (Y); - if User_Defined_Pool and then First_Free /= My_Pool.First_Free then - Failed (Subtest & - " - Conversion did consume storage in the pool - 2"); - end if; - if X.all /= Value then - Failed (Subtest & - " - Incorrect allocation/conversion of access values - 2"); - end if; - - Deallocate (X); - if User_Defined_Pool and then First_Free <= My_Pool.First_Free then - Failed (Subtest & - " - Deallocation didn't release storage from the pool - 2"); - end if; - exception - when E: others => - Failed (Subtest & " - Exception " & Exception_Name (E) & - " raised - " & Exception_Message (E)); - end Check; - - -begin - Test ("C3A0015", "Check that a dervied access type has the same " & - "storage pool as its parent"); - - Comment ("Access types using the standard storage pool"); - - Std: - declare - procedure Check1 is - new Check (Designated => Float, - Value => 3.0, - Acc => Standard_Pool, - Derived_Acc => Derived_Standard_Pool); - procedure Check2 is - new Check (Designated => Float, - Value => 4.0, - Acc => Standard_Pool, - Derived_Acc => Derived_Derived_Standard_Pool); - procedure Check3 is - new Check (Designated => Float, - Value => 5.0, - Acc => Derived_Standard_Pool, - Derived_Acc => Derived_Derived_Standard_Pool); - begin - Check1 ("Standard_Pool/Derived_Standard_Pool", - User_Defined_Pool => False); - Check2 ("Standard_Pool/Derived_Derived_Standard_Pool", - User_Defined_Pool => False); - Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool", - User_Defined_Pool => False); - end Std; - - Comment ("Access types using a user-defined storage pool"); - - User: - declare - procedure Check1 is - new Check (Designated => Integer, - Value => 17, - Acc => User_Defined_Pool, - Derived_Acc => Derived_User_Defined_Pool); - procedure Check2 is - new Check (Designated => Integer, - Value => 18, - Acc => User_Defined_Pool, - Derived_Acc => Derived_Derived_User_Defined_Pool); - procedure Check3 is - new Check (Designated => Integer, - Value => 19, - Acc => Derived_User_Defined_Pool, - Derived_Acc => Derived_Derived_User_Defined_Pool); - begin - Check1 ("User_Defined_Pool/Derived_User_Defined_Pool", - User_Defined_Pool => True); - Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool", - User_Defined_Pool => True); - Check3 - ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool", - User_Defined_Pool => True); - end User; - - Result; -end C3A0015; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a b/gcc/testsuite/ada/acats/tests/c3/c3a1001.a deleted file mode 100644 index 9b05b5da254..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a +++ /dev/null @@ -1,315 +0,0 @@ --- C3A1001.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 full type completing a type with no discriminant part --- or an unknown discriminant part may have explicitly declared or --- inherited discriminants. --- Check for cases where the types are records and protected types. --- --- TEST DESCRIPTION: --- Declare two groups of incomplete types: one group with no discriminant --- part and one group with unknown discriminant part. Both groups of --- incomplete types are completed with both explicit and inherited --- discriminants. Discriminants for record and protected types are --- declared with default and non default values. --- In the main program, verify that objects of both groups of incomplete --- types can be created by default values or by assignments. --- --- --- CHANGE HISTORY: --- 11 Oct 95 SAIC Initial prerelease version. --- 11 Nov 96 SAIC Revised for version 2.1. --- ---! - -package C3A1001_0 is - - type Incomplete1 (<>); -- unknown discriminant - - type Incomplete2; -- no discriminant - - type Incomplete3 (<>); -- unknown discriminant - - type Incomplete4; -- no discriminant - - type Incomplete5 (<>); -- unknown discriminant - - type Incomplete6; -- no discriminant - - type Incomplete8; -- no discriminant - - subtype Small_Int is Integer range 1 .. 10; - - type Enu_Type is (M, F); - - type Incomplete1 (Disc : Enu_Type) is -- unknown discriminant/ - record -- explicit discriminant - case Disc is - when M => MInteger : Small_Int := 3; - when F => FInteger : Small_Int := 8; - end case; - end record; - - type Incomplete2 (Disc : Small_Int := 8) is -- no discriminant/ - record -- explicit discriminant - ID : String (1 .. Disc) := "Plymouth"; - end record; - - type Incomplete3 is new Incomplete2; -- unknown discriminant/ - -- inherited discriminant - - type Incomplete4 is new Incomplete2; -- no discriminant/ - -- inherited discriminant - - protected type Incomplete5 -- unknown discriminant/ - (Disc : Enu_Type) is -- explicit discriminant - function Get_Priv_Val return Enu_Type; - private - Enu_Obj : Enu_Type := Disc; - end Incomplete5; - - protected type Incomplete6 -- no discriminant/ - (Disc : Small_Int := 1) is -- explicit discriminant - function Get_Priv_Val return Small_Int; -- with default - private - Num : Small_Int := Disc; - end Incomplete6; - - type Incomplete8 (Disc : Small_Int) is -- no discriminant/ - record -- explicit discriminant - Str : String (1 .. Disc); -- no default - end record; - - type Incomplete9 is new Incomplete8; - - function Return_String (S : String) return String; - -end C3A1001_0; - - --==================================================================-- - -with Report; - -package body C3A1001_0 is - - protected body Incomplete5 is - - function Get_Priv_Val return Enu_Type is - begin - return Enu_Obj; - end Get_Priv_Val; - - end Incomplete5; - - ---------------------------------------------------------------------- - protected body Incomplete6 is - - function Get_Priv_Val return Small_Int is - begin - return Num; - end Get_Priv_Val; - - end Incomplete6; - - ---------------------------------------------------------------------- - function Return_String (S : String) return String is - begin - if Report.Ident_Bool(True) = True then - return S; - end if; - - return S; - end Return_String; - -end C3A1001_0; - - --==================================================================-- - -with Report; - -with C3A1001_0; -use C3A1001_0; - -procedure C3A1001 is - - -- Discriminant value comes from default. - - Incomplete2_Obj_1 : Incomplete2; - - Incomplete4_Obj_1 : Incomplete4; - - Incomplete6_Obj_1 : Incomplete6; - - -- Discriminant value comes from explicit constraint. - - Incomplete1_Obj_1 : Incomplete1 (F); - - Incomplete5_Obj_1 : Incomplete5 (M); - - Incomplete6_Obj_2 : Incomplete6 (2); - - -- Discriminant value comes from assignment. - - Incomplete3_Obj_1 : Incomplete3 := (Disc => 6, ID => "Sentra"); - - Incomplete1_Obj_2 : Incomplete1 := (Disc => M, MInteger => 9); - - Incomplete2_Obj_2 : Incomplete2 := (Disc => 5, ID => "Buick"); - -begin - - Report.Test ("C3A1001", "Check that the full type completing a type " & - "with no discriminant part or an unknown discriminant " & - "part may have explicitly declared or inherited " & - "discriminants. Check for cases where the types are " & - "records and protected types"); - - -- Check the initial values. - - if (Incomplete2_Obj_1.Disc /= 8) or - (Incomplete2_Obj_1.ID /= "Plymouth") then - Report.Failed ("Wrong initial values for Incomplete2_Obj_1"); - end if; - - if (Incomplete4_Obj_1.Disc /= 8) or - (Incomplete4_Obj_1.ID /= "Plymouth") then - Report.Failed ("Wrong initial values for Incomplete4_Obj_1"); - end if; - - if (Incomplete6_Obj_1.Disc /= 1) or - (Incomplete6_Obj_1.Get_Priv_Val /= 1) then - Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); - end if; - - -- Check the explicit values. - - if (Incomplete1_Obj_1.Disc /= F) or - (Incomplete1_Obj_1.FInteger /= 8) then - Report.Failed ("Wrong values for Incomplete1_Obj_1"); - end if; - - if (Incomplete5_Obj_1.Disc /= M) or - (Incomplete5_Obj_1.Get_Priv_Val /= M) then - Report.Failed ("Wrong value for Incomplete5_Obj_1"); - end if; - - if (Incomplete6_Obj_2.Disc /= 2) or - (Incomplete6_Obj_2.Get_Priv_Val /= 2) then - Report.Failed ("Wrong value for Incomplete6_Obj_2"); - end if; - - -- Check the assigned values. - - if (Incomplete3_Obj_1.Disc /= 6) or - (Incomplete3_Obj_1.ID /= "Sentra") then - Report.Failed ("Wrong values for Incomplete3_Obj_1"); - end if; - - if (Incomplete1_Obj_2.Disc /= M) or - (Incomplete1_Obj_2.MInteger /= 9) then - Report.Failed ("Wrong values for Incomplete1_Obj_2"); - end if; - - if (Incomplete2_Obj_2.Disc /= 5) or - (Incomplete2_Obj_2.ID /= "Buick") then - Report.Failed ("Wrong values for Incomplete2_Obj_2"); - end if; - - -- Make sure that assignments work without problems. - - Incomplete1_Obj_1.FInteger := 1; - - -- Avoid optimization (dead variable removal of FInteger): - - if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1) - then - Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger"); - end if; - - Incomplete2_Obj_1.ID := Return_String ("12345678"); - - -- Avoid optimization (dead variable removal of ID) - - if Incomplete2_Obj_1.ID /= Return_String ("12345678") - then - Report.Failed ("Wrong values for Incomplete8_Obj_1.ID"); - end if; - - Incomplete4_Obj_1.ID := Return_String ("87654321"); - - -- Avoid optimization (dead variable removal of ID) - - if Incomplete4_Obj_1.ID /= Return_String ("87654321") - then - Report.Failed ("Wrong values for Incomplete4_Obj_1.ID"); - end if; - - - Test1: - declare - - Incomplete8_Obj_1 : Incomplete8 (10); - - begin - Incomplete8_Obj_1.Str := "Merry Xmas"; - - -- Avoid optimization (dead variable removal of Str): - - if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas" - then - Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1"); - - end Test1; - - Test2: - declare - - Incomplete8_Obj_2 : Incomplete8 (5); - - begin - Incomplete8_Obj_2.Str := "Happy"; - - -- Avoid optimization (dead variable removal of Str): - - if Return_String (Incomplete8_Obj_2.Str) /= "Happy" - then - Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2"); - - end Test2; - - Report.Result; - -end C3A1001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a b/gcc/testsuite/ada/acats/tests/c3/c3a1002.a deleted file mode 100644 index 27d1f843c30..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a +++ /dev/null @@ -1,251 +0,0 @@ --- C3A1002.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 full type completing a type with no discriminant part --- or an unknown discriminant part may have explicitly declared or --- inherited discriminants. --- Check for cases where the types are tagged records and task types. --- --- TEST DESCRIPTION: --- Declare two groups of incomplete types: one group with no discriminant --- part and one group with unknown discriminant part. Both groups of --- incomplete types are completed with both explicit and inherited --- discriminants. Discriminants for task types are declared with both --- default and non default values. Discriminants for tagged types are --- only declared without default values. --- In the main program, verify that objects of both groups of incomplete --- types can be created by default values or by assignments. --- --- --- CHANGE HISTORY: --- 23 Oct 95 SAIC Initial prerelease version. --- 19 Oct 96 SAIC ACVC 2.1: modified test description. Initialized --- Int_Val. --- ---! - -package C3A1002_0 is - - subtype Small_Int is Integer range 1 .. 15; - - type Enu_Type is (M, F); - - type Tag_Type is tagged - record - I : Small_Int := 1; - end record; - - type NTag_Type (D : Small_Int) is new Tag_Type with - record - S : String (1 .. D) := "Aloha"; - end record; - - type Incomplete1; -- no discriminant - - type Incomplete2 (<>); -- unknown discriminant - - type Incomplete3; -- no discriminant - - type Incomplete4 (<>); -- unknown discriminant - - type Incomplete5; -- no discriminant - - type Incomplete6 (<>); -- unknown discriminant - - type Incomplete1 (D1 : Enu_Type) is tagged -- no discriminant/ - record -- explicit discriminant - case D1 is - when M => MInteger : Small_Int := 9; - when F => FInteger : Small_Int := 8; - end case; - end record; - - type Incomplete2 (D2 : Small_Int) is new -- unknown discriminant/ - Incomplete1 (D1 => F) with record -- explicit discriminant - ID : String (1 .. D2) := "ACVC95"; - end record; - - type Incomplete3 is new -- no discriminant/ - NTag_Type with record -- inherited discriminant - E : Enu_Type := M; - end record; - - type Incomplete4 is new -- unknown discriminant/ - NTag_Type (D => 3) with record -- inherited discriminant - E : Enu_Type := F; - end record; - - task type Incomplete5 (D5 : Enu_Type) is -- no discriminant/ - entry Read_Disc (P : out Enu_Type); -- explicit discriminant - end Incomplete5; - - task type Incomplete6 - (D6 : Small_Int := 4) is -- unknown discriminant/ - entry Read_Int (P : out Small_Int); -- explicit discriminant - end Incomplete6; - -end C3A1002_0; - - --==================================================================-- - -package body C3A1002_0 is - - task body Incomplete5 is - begin - select - accept Read_Disc (P : out Enu_Type) do - P := D5; - end Read_Disc; - or - terminate; - end select; - - end Incomplete5; - - ---------------------------------------------------------------------- - task body Incomplete6 is - begin - select - accept Read_Int (P : out Small_Int) do - P := D6; - end Read_Int; - or - terminate; - end select; - - end Incomplete6; - -end C3A1002_0; - - --==================================================================-- - -with Report; - -with C3A1002_0; -use C3A1002_0; - -procedure C3A1002 is - - Enum_Val : Enu_Type := M; - - Int_Val : Small_Int := 15; - - -- Discriminant value comes from default. - - Incomplete6_Obj_1 : Incomplete6; - - -- Discriminant value comes from explicit constraint. - - Incomplete1_Obj_1 : Incomplete1 (M); - - Incomplete2_Obj_1 : Incomplete2 (6); - - Incomplete5_Obj_1 : Incomplete5 (F); - - Incomplete6_Obj_2 : Incomplete6 (7); - - -- Discriminant value comes from assignment. - - Incomplete1_Obj_2 : Incomplete1 - := (F, 12); - - Incomplete3_Obj_1 : Incomplete3 - := (D => 2, S => "Hi", I => 10, E => F); - - Incomplete4_Obj_1 : Incomplete4 - := (E => M, D => 3, S => "Bye", I => 14); - -begin - - Report.Test ("C3A1002", "Check that the full type completing a type " & - "with no discriminant part or an unknown discriminant " & - "part may have explicitly declared or inherited " & - "discriminants. Check for cases where the types are " & - "tagged records and task types"); - - -- Check the initial values. - - if (Incomplete6_Obj_1.D6 /= 4) then - Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); - end if; - - -- Check the explicit values. - - if (Incomplete1_Obj_1.D1 /= M) or - (Incomplete1_Obj_1.MInteger /= 9) then - Report.Failed ("Wrong values for Incomplete1_Obj_1"); - end if; - - if (Incomplete2_Obj_1.D2 /= 6) or - (Incomplete2_Obj_1.FInteger /= 8) or - (Incomplete2_Obj_1.ID /= "ACVC95") then - Report.Failed ("Wrong values for Incomplete2_Obj_1"); - end if; - - if (Incomplete5_Obj_1.D5 /= F) then - Report.Failed ("Wrong value for Incomplete5_Obj_1"); - end if; - - Incomplete5_Obj_1.Read_Disc (Enum_Val); - - if (Enum_Val /= F) then - Report.Failed ("Wrong value for Enum_Val"); - end if; - - if (Incomplete6_Obj_2.D6 /= 7) then - Report.Failed ("Wrong value for Incomplete6_Obj_2"); - end if; - - Incomplete6_Obj_1.Read_Int (Int_Val); - - if (Int_Val /= 4) then - Report.Failed ("Wrong value for Int_Val"); - end if; - - -- Check the assigned values. - - if (Incomplete1_Obj_2.D1 /= F) or - (Incomplete1_Obj_2.FInteger /= 12) then - Report.Failed ("Wrong values for Incomplete1_Obj_2"); - end if; - - if (Incomplete3_Obj_1.D /= 2 ) or - (Incomplete3_Obj_1.I /= 10) or - (Incomplete3_Obj_1.E /= F ) or - (Incomplete3_Obj_1.S /= "Hi") then - Report.Failed ("Wrong values for Incomplete3_Obj_1"); - end if; - - if (Incomplete4_Obj_1.E /= M ) or - (Incomplete4_Obj_1.D /= 3) or - (Incomplete4_Obj_1.S /= "Bye") or - (Incomplete4_Obj_1.I /= 14) then - Report.Failed ("Wrong values for Incomplete4_Obj_1"); - end if; - - Report.Result; - -end C3A1002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a b/gcc/testsuite/ada/acats/tests/c3/c3a2001.a deleted file mode 100644 index c3c7f441062..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a +++ /dev/null @@ -1,460 +0,0 @@ --- C3A2001.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 access type may be defined to designate the --- class-wide type of an abstract type. Check that the access type --- may then be used subsequently with types derived from the abstract --- type. Check that dispatching operations dispatch correctly, when --- called using values designated by objects of the access type. --- --- TEST DESCRIPTION: --- This test declares an abstract type Breaker in a package, and --- then derives from it. The type Basic_Breaker defines the least --- possible in order to not be abstract. The type Ground_Fault is --- defined to inherit as much as possible, whereas type Special_Breaker --- overrides everything it can. The type Special_Breaker also includes --- an embedded Basic_Breaker object. The main program then utilizes --- each of the three types of breaker, and to ascertain that the --- overloading and tagging resolution are correct, each "Create" --- procedure is called with a unique value. The diagram below --- illustrates the relationships. --- --- Abstract type: Breaker(1) --- | --- Basic_Breaker(2) --- / \ --- Ground_Fault(3) Special_Breaker(4) --- --- Test structure is a polymorphic linked list, modeling a circuit --- as a list of components. The type component is the access type --- defined to designate Breaker'Class values. The test then creates --- some values, and traverses the list to determine correct operation. --- This test is instrumented with a the trace facility found in --- foundation F392C00 to simplify the verification process. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1 --- 23 APR 96 SAIC Added pragma Elaborate_All --- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All --- ---! - -with Report; -with TCTouch; -package C3A2001_1 is - - type Breaker is abstract tagged private; - type Status is ( Power_Off, Power_On, Tripped, Failed ); - - procedure Flip ( The_Breaker : in out Breaker ) is abstract; - procedure Trip ( The_Breaker : in out Breaker ) is abstract; - procedure Reset( The_Breaker : in out Breaker ) is abstract; - procedure Fail ( The_Breaker : in out Breaker ); - - procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); - - function Status_Of( The_Breaker : Breaker ) return Status; - -private - type Breaker is abstract tagged record - State : Status := Power_Off; - end record; -end C3A2001_1; - ----------------------------------------------------------------------------- - -with TCTouch; -package body C3A2001_1 is - procedure Fail( The_Breaker : in out Breaker ) is - begin - TCTouch.Touch( 'a' ); --------------------------------------------- a - The_Breaker.State := Failed; - end Fail; - - procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is - begin - The_Breaker.State := To_State; - end Set; - - function Status_Of( The_Breaker : Breaker ) return Status is - begin - TCTouch.Touch( 'b' ); --------------------------------------------- b - return The_Breaker.State; - end Status_Of; -end C3A2001_1; - ----------------------------------------------------------------------------- - -with C3A2001_1; -package C3A2001_2 is - - type Basic_Breaker is new C3A2001_1.Breaker with private; - - type Voltages is ( V12, V110, V220, V440 ); - type Amps is ( A1, A5, A10, A25, A100 ); - - function Construct( Voltage : Voltages; Amperage : Amps ) - return Basic_Breaker; - - procedure Flip ( The_Breaker : in out Basic_Breaker ); - procedure Trip ( The_Breaker : in out Basic_Breaker ); - procedure Reset( The_Breaker : in out Basic_Breaker ); -private - type Basic_Breaker is new C3A2001_1.Breaker with record - Voltage_Level : Voltages := V110; - Amperage : Amps; - end record; -end C3A2001_2; - ----------------------------------------------------------------------------- - -with TCTouch; -package body C3A2001_2 is - function Construct( Voltage : Voltages; Amperage : Amps ) - return Basic_Breaker is - It : Basic_Breaker; - begin - TCTouch.Touch( 'c' ); --------------------------------------------- c - It.Amperage := Amperage; - It.Voltage_Level := Voltage; - C3A2001_1.Set( It, C3A2001_1.Power_Off ); - return It; - end Construct; - - procedure Flip ( The_Breaker : in out Basic_Breaker ) is - begin - TCTouch.Touch( 'd' ); --------------------------------------------- d - case Status_Of( The_Breaker ) is - when C3A2001_1.Power_Off => - C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); - when C3A2001_1.Power_On => - C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off ); - when C3A2001_1.Tripped | C3A2001_1.Failed => null; - end case; - end Flip; - - procedure Trip ( The_Breaker : in out Basic_Breaker ) is - begin - TCTouch.Touch( 'e' ); --------------------------------------------- e - C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped ); - end Trip; - - procedure Reset( The_Breaker : in out Basic_Breaker ) is - begin - TCTouch.Touch( 'f' ); --------------------------------------------- f - case Status_Of( The_Breaker ) is - when C3A2001_1.Power_Off | C3A2001_1.Tripped => - C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); - when C3A2001_1.Power_On | C3A2001_1.Failed => null; - end case; - end Reset; - -end C3A2001_2; - ----------------------------------------------------------------------------- - -with C3A2001_1,C3A2001_2; -package C3A2001_3 is - use type C3A2001_1.Status; - - type Ground_Fault is new C3A2001_2.Basic_Breaker with private; - - function Construct( Voltage : C3A2001_2.Voltages; - Amperage : C3A2001_2.Amps ) - return Ground_Fault; - - procedure Set_Trip( The_Breaker : in out Ground_Fault; - Capacitance : in Integer ); - -private - type Ground_Fault is new C3A2001_2.Basic_Breaker with record - Capacitance : Integer; - end record; -end C3A2001_3; - ----------------------------------------------------------------------------- - -with TCTouch; -package body C3A2001_3 is - - function Construct( Voltage : C3A2001_2.Voltages; - Amperage : C3A2001_2.Amps ) - return Ground_Fault is - begin - TCTouch.Touch( 'g' ); --------------------------------------------- g - return ( C3A2001_2.Construct( Voltage, Amperage ) - with Capacitance => 0 ); - end Construct; - - - procedure Set_Trip( The_Breaker : in out Ground_Fault; - Capacitance : in Integer ) is - begin - TCTouch.Touch( 'h' ); --------------------------------------------- h - The_Breaker.Capacitance := Capacitance; - end Set_Trip; - -end C3A2001_3; - ----------------------------------------------------------------------------- - -with C3A2001_1, C3A2001_2; -package C3A2001_4 is - - type Special_Breaker is new C3A2001_2.Basic_Breaker with private; - - function Construct( Voltage : C3A2001_2.Voltages; - Amperage : C3A2001_2.Amps ) - return Special_Breaker; - - procedure Flip ( The_Breaker : in out Special_Breaker ); - procedure Trip ( The_Breaker : in out Special_Breaker ); - procedure Reset( The_Breaker : in out Special_Breaker ); - procedure Fail ( The_Breaker : in out Special_Breaker ); - - function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status; - function On_Backup( The_Breaker : Special_Breaker ) return Boolean; - -private - type Special_Breaker is new C3A2001_2.Basic_Breaker with record - Backup : C3A2001_2.Basic_Breaker; - end record; -end C3A2001_4; - ----------------------------------------------------------------------------- - -with TCTouch; -package body C3A2001_4 is - - function Construct( Voltage : C3A2001_2.Voltages; - Amperage : C3A2001_2.Amps ) - return Special_Breaker is - It: Special_Breaker; - procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is - begin - It := C3A2001_2.Construct( Voltage, Amperage ); - end Set_Root; - begin - TCTouch.Touch( 'i' ); --------------------------------------------- i - Set_Root( C3A2001_2.Basic_Breaker( It ) ); - Set_Root( It.Backup ); - return It; - end Construct; - - function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status - renames C3A2001_1.Status_Of; - - procedure Flip ( The_Breaker : in out Special_Breaker ) is - begin - TCTouch.Touch( 'j' ); --------------------------------------------- j - case Status_Of( C3A2001_1.Breaker( The_Breaker )) is - when C3A2001_1.Power_Off | C3A2001_1.Power_On => - C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) ); - when others => - C3A2001_2.Flip( The_Breaker.Backup ); - end case; - end Flip; - - procedure Trip ( The_Breaker : in out Special_Breaker ) is - begin - TCTouch.Touch( 'k' ); --------------------------------------------- k - case Status_Of( C3A2001_1.Breaker( The_Breaker )) is - when C3A2001_1.Power_Off => null; - when C3A2001_1.Power_On => - C3A2001_2.Reset( The_Breaker.Backup ); - C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) ); - when others => - C3A2001_2.Trip( The_Breaker.Backup ); - end case; - end Trip; - - procedure Reset( The_Breaker : in out Special_Breaker ) is - begin - TCTouch.Touch( 'l' ); --------------------------------------------- l - case Status_Of( C3A2001_1.Breaker( The_Breaker )) is - when C3A2001_1.Tripped => - C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker )); - when C3A2001_1.Failed => - C3A2001_2.Reset( The_Breaker.Backup ); - when C3A2001_1.Power_On | C3A2001_1.Power_Off => - null; - end case; - end Reset; - - procedure Fail ( The_Breaker : in out Special_Breaker ) is - begin - TCTouch.Touch( 'm' ); --------------------------------------------- m - case Status_Of( C3A2001_1.Breaker( The_Breaker )) is - when C3A2001_1.Failed => - C3A2001_2.Fail( The_Breaker.Backup ); - when others => - C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker )); - C3A2001_2.Reset( The_Breaker.Backup ); - end case; - end Fail; - - function Status_Of( The_Breaker : Special_Breaker ) - return C3A2001_1.Status is - begin - TCTouch.Touch( 'n' ); --------------------------------------------- n - case Status_Of( C3A2001_1.Breaker( The_Breaker )) is - when C3A2001_1.Power_On => return C3A2001_1.Power_On; - when C3A2001_1.Power_Off => return C3A2001_1.Power_Off; - when others => - return C3A2001_2.Status_Of( The_Breaker.Backup ); - end case; - end Status_Of; - - function On_Backup( The_Breaker : Special_Breaker ) return Boolean is - use C3A2001_2; - use type C3A2001_1.Status; - begin - return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped - or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed; - end On_Backup; - -end C3A2001_4; - ----------------------------------------------------------------------------- - -with C3A2001_1; -package C3A2001_5 is - - type Component is access C3A2001_1.Breaker'Class; - - type Circuit; - type Connection is access Circuit; - - type Circuit is record - The_Gadget : Component; - Next : Connection; - end record; - - procedure Flipper( The_Circuit : Connection ); - procedure Tripper( The_Circuit : Connection ); - procedure Restore( The_Circuit : Connection ); - procedure Failure( The_Circuit : Connection ); - - Short : Connection := null; - -end C3A2001_5; - ----------------------------------------------------------------------------- -with Report; -with TCTouch; -with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4; - -pragma Elaborate_All( Report, TCTouch, - C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 ); - -package body C3A2001_5 is - - function Neww( Breaker: in C3A2001_1.Breaker'Class ) - return Component is - begin - return new C3A2001_1.Breaker'Class'( Breaker ); - end Neww; - - procedure Add( Gadget : in Component; - To_Circuit : in out Connection) is - begin - To_Circuit := new Circuit'(Gadget,To_Circuit); - end Add; - - procedure Flipper( The_Circuit : Connection ) is - Probe : Connection := The_Circuit; - begin - while Probe /= null loop - C3A2001_1.Flip( Probe.The_Gadget.all ); - Probe := Probe.Next; - end loop; - end Flipper; - - procedure Tripper( The_Circuit : Connection ) is - Probe : Connection := The_Circuit; - begin - while Probe /= null loop - C3A2001_1.Trip( Probe.The_Gadget.all ); - Probe := Probe.Next; - end loop; - end Tripper; - - procedure Restore( The_Circuit : Connection ) is - Probe : Connection := The_Circuit; - begin - while Probe /= null loop - C3A2001_1.Reset( Probe.The_Gadget.all ); - Probe := Probe.Next; - end loop; - end Restore; - - procedure Failure( The_Circuit : Connection ) is - Probe : Connection := The_Circuit; - begin - while Probe /= null loop - C3A2001_1.Fail( Probe.The_Gadget.all ); - Probe := Probe.Next; - end loop; - end Failure; - -begin - Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short ); - Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short ); - Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short ); -end C3A2001_5; - ----------------------------------------------------------------------------- - -with Report; -with TCTouch; -with C3A2001_5; -procedure C3A2001 is - -begin -- Main test procedure. - - Report.Test ("C3A2001", "Check that an abstract type can be declared " & - "and used. Check actual subprograms dispatch correctly" ); - - -- This Validate call must be _after_ the call to Report.Test - TCTouch.Validate( "cgcicc", "Adding" ); - - C3A2001_5.Flipper( C3A2001_5.Short ); - TCTouch.Validate( "jbdbdbdb", "Flipping" ); - - C3A2001_5.Tripper( C3A2001_5.Short ); - TCTouch.Validate( "kbfbeee", "Tripping" ); - - C3A2001_5.Restore( C3A2001_5.Short ); - TCTouch.Validate( "lbfbfbfb", "Restoring" ); - - C3A2001_5.Failure( C3A2001_5.Short ); - TCTouch.Validate( "mbafbaa", "Circuits Failing" ); - - Report.Result; - -end C3A2001; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a b/gcc/testsuite/ada/acats/tests/c3/c3a2002.a deleted file mode 100644 index 63ea7008b66..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a +++ /dev/null @@ -1,295 +0,0 @@ --- C3A2002.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, for X'Access of a general access type A, Program_Error is --- raised if the accessibility level of X is deeper than that of A. --- Check for the case where X denotes a view that is a dereference of an --- access parameter, or a rename thereof. --- --- Check for cases where the actual corresponding to X is: --- (a) An allocator. --- (b) An expression of a named access type. --- (c) Obj'Access. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the designated --- object X must be at the same or a less deep nesting level than the --- general access type A -- X must "live" as long as A. Nesting --- levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares subprograms with access parameters, within which --- 'Access is attempted on a dereference of the access parameter, and --- assigned to an access object whose type A is declared at some nesting --- level. The test verifies that Program_Error is raised if the actual --- corresponding to the access parameter is: --- --- (1) an allocator, and the accessibility level of the execution --- of the called subprogram is deeper than that of the access --- type A. --- --- (2) an expression of a named access type, and the accessibility --- level of the named access type is deeper than that of the --- access type A. --- --- (3) a reference to the Access attribute (e.g., X'Access), and --- the accessibility level of X is deeper than that of the --- access type A. --- --- Note that the static nesting level of the actual corresponding to the --- access parameter can be deeper than that of the type A -- it is --- the run-time nesting that matters for accessibility rules. Consider --- the case where the access type A is declared within the called --- subprogram. The accessibility check will never fail, even if the --- actual happens to have a deeper static nesting level: --- --- procedure P (X: access T) is --- type A is access all T; -- Static level = 2, e.g. --- Acc : A := X.all'Access; -- Check should never fail. --- begin null; end; --- . . . --- declare --- Actual : aliased T; -- Static level = 3, e.g. --- begin --- P (Actual'Access); --- end; --- --- For the execution of P, the accessibility level of type A will --- always be deeper than that of Actual, so there is no danger of a --- dangling reference arising from the assignment to Acc. Thus, --- X.all'Access is safe, even though the static nesting level of --- Actual is deeper than that of A. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C3A2002_0 is - - type Desig is array (1 .. 10) of Integer; - - X0 : aliased Desig; -- Level = 0. - - type Acc_L0 is access all Desig; -- Level = 0. - A0 : Acc_L0; - - type Result_Kind is (OK, P_E, O_E); - - procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind); - procedure Never_Fails (X: access Desig; R : out Result_Kind); - -end C3A2002_0; - - - --==================================================================-- - -package body C3A2002_0 is - - procedure A_Is_Level_0 (X : access Desig; - R : out Result_Kind) is - begin - -- The accessibility level of the type of A0 is 0. - A0 := X.all'Access; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end A_Is_Level_0; - - ----------------------------------------------- - procedure Never_Fails (X: access Desig; - R : out Result_Kind) is - type Acc_Local is access all Desig; - AL : Acc_Local; - begin - -- X.all'Access below will always be safe, since the accessibility - -- level (although not necessarily the static nesting depth) of the - -- type of AL will always be deeper than or the same as that of the - -- actual corresponding to Y. - AL := X.all'Access; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Never_Fails; - -end C3A2002_0; - - - --==================================================================-- - - -with C3A2002_0; -with Report; - -procedure C3A2002 is - - X1 : aliased C3A2002_0.Desig; -- Level = 1. - - type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1. - A1 : Acc_L1; - - Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access; - Expr_L1 : Acc_L1 := X1'Access; - - Res : C3A2002_0.Result_Kind; - - use type C3A2002_0.Result_Kind; - - ----------------------------------------------- - procedure A_Is_Level_1 (X : access C3A2002_0.Desig; - R : out C3A2002_0.Result_Kind) is - -- Dereference of an access_to_object value is aliased. - Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference - begin -- of an access parameter. - -- The accessibility level of the type of A1 is 1. - A1 := Ren'Access; - R := C3A2002_0.OK; - exception - when Program_Error => - R := C3A2002_0.P_E; - when others => - R := C3A2002_0.O_E; - end A_Is_Level_1; - - ----------------------------------------------- - procedure Display_Results (Result : in C3A2002_0.Result_Kind; - Expected: in C3A2002_0.Result_Kind; - Message : in String) is - begin - if Result /= Expected then - case Result is - when C3A2002_0.OK => Report.Failed ("No exception raised: " & - Message); - when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " & - Message); - when C3A2002_0.O_E => Report.Failed ("Unexpected exception " & - "raised: " & Message); - end case; - end if; - end Display_Results; - -begin -- C3A2002 - - Report.Test ("C3A2002", "Check that, for X'Access of general access " & - "type A, Program_Error is raised if the accessibility " & - "level of X is deeper than that of A: X is an access " & - "parameter; corresponding actual is an allocator, " & - "expression of a named access type, Obj'Access, or a " & - "rename thereof"); - - - -- Actual is X'Access: - - C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res); - Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type"); - - C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res); - Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type"); - - C3A2002_0.A_Is_Level_0 (X1'Access, Res); - Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type"); - - A_Is_Level_1 (X1'Access, Res); - Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type"); - - - -- Actual is expression of a named access type: - - C3A2002_0.Never_Fails (Expr_L1, Res); - Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type"); - - C3A2002_0.A_Is_Level_0 (Expr_L1, Res); - Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type"); - - A_Is_Level_1 (Expr_L0, Res); - Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type"); - - A_Is_Level_1 (Expr_L1, Res); - Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type"); - - -- Actual is allocator (level of execution = 2): - - C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); - Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " & - "local access type"); - - -- Since actual is an allocator, its accessibility level is that of - -- the execution of the called subprogram, i.e., level 2. - - C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res); - Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & - "level 0 access type"); - - A_Is_Level_1 (new C3A2002_0.Desig, Res); - Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & - "level 1 access type"); - - - Block_L2: - declare - X2 : aliased C3A2002_0.Desig; -- Level = 2. - type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2. - Expr_L2 : Acc_L2 := X1'Access; - begin - - -- Actual is X'Access: - - C3A2002_0.Never_Fails (X2'Access, Res); - Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type"); - - C3A2002_0.A_Is_Level_0 (X2'Access, Res); - Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type"); - - - -- Actual is expression of a named access type: - - A_Is_Level_1 (Expr_L2, Res); - Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type"); - - - -- Actual is allocator (level of execution = 3): - - C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); - Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " & - "local access type"); - - A_Is_Level_1 (new C3A2002_0.Desig, Res); - Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " & - "level 1 access type"); - - end Block_L2; - - Report.Result; - -end C3A2002; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a b/gcc/testsuite/ada/acats/tests/c3/c3a2003.a deleted file mode 100644 index deb92f1a8c5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a +++ /dev/null @@ -1,329 +0,0 @@ --- C3A2003.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, for X'Access of a general access type A, Program_Error is --- raised if the accessibility level of X is deeper than that of A. --- Check for the case where X denotes a view that is a dereference of an --- access parameter, or a rename thereof. Check for the case where X is --- an access parameter and the corresponding actual is another access --- parameter. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the designated --- object X must be at the same or a less deep nesting level than the --- general access type A -- X must "live" as long as A. Nesting --- levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares subprograms with access parameters, within which --- 'Access is attempted on a dereference of an access parameter, and --- assigned to an access object whose type A is declared at some nesting --- level. The test verifies that Program_Error is raised if the actual --- corresponding to the access parameter is another access parameter, --- and the actual corresponding to this second access parameter is: --- --- (1) an expression of a named access type, and the accessibility --- level of the named access type is deeper than that of the --- access type A. --- --- (2) a reference to the Access attribute (e.g., X'Access), and --- the accessibility level of X is deeper than that of the --- access type A. --- --- Note that the static nesting level of the actual corresponding to the --- access parameter can be deeper than that of the type A -- it is --- the run-time nesting that matters for accessibility rules. Consider --- the case where the access type A is declared within the called --- subprogram. The accessibility check will never fail, even if the --- actual happens to have a deeper static nesting level: --- --- procedure P (X: access T) is --- type A is access all T; -- Static level = 2, e.g. --- Acc : A := X.all'Access; -- Check should never fail. --- begin null; end; --- . . . --- procedure Q (Y: access T) is --- begin --- P(Y); --- end; --- . . . --- declare --- Actual : aliased T; -- Static level = 3, e.g. --- begin --- Q (Actual'Access); --- end; --- --- For the execution of Q (and hence P), the accessibility level of --- type A will always be deeper than that of Actual, so there is no --- danger of a dangling reference arising from the assignment to --- Acc. Thus, X.all'Access is safe, even though the static nesting --- level of Actual is deeper than that of A. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Jul 98 EDS Avoid optimization. --- 28 Jun 02 RLB Added pragma Elaborate_All (Report);. ---! - -with report; use report; pragma Elaborate_All (report); -package C3A2003_0 is - - type Desig is array (1 .. 10) of Integer; - - X0 : aliased Desig := (Desig'Range => Ident_Int(3)); -- Level = 0. - - type Acc_L0 is access all Desig; -- Level = 0. - A0 : Acc_L0; - - type Result_Kind is (OK, P_E, O_E); - - procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); - procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); - procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); - -end C3A2003_0; - - - --==================================================================-- - - -package body C3A2003_0 is - - procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is - - - -- This procedure utilizes 'Access on a dereference of an access - -- parameter, and assigned to an access object whose type A is - -- declared at some nesting level. Program_Error is raised if - -- the accessibility level of the operand type is deeper than that - -- of the target type. - - procedure Nested (X: access Desig; R: out Result_Kind) is - -- Dereference of an access_to_object value is aliased. - Ren : Desig renames X.all; -- Renaming of a dereference - begin -- of an access parameter. - -- The accessibility level of type A0 is 0. - A0 := Ren'Access; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Nested; - - begin -- Target_Is_Level_0_Nest - Nested (Y, S); - end Target_Is_Level_0_Nest; - - ------------------------------------------------------------------ - - procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is - - type Acc_Deeper is access all Desig; - AD : Acc_Deeper; - - function Nested (X: access Desig) return Result_Kind is - begin - -- X.all'Access below will always be safe, since the accessibility - -- level (although not necessarily the static nesting depth) of the - -- type of AD will always be deeper than or the same as that of the - -- actual corresponding to Y. - AD := X.all'Access; - if Ident_Int (AD(4)) /= 3 then --Avoid Optimization of AD - FAILED ("Initial Values not correct."); - end if; - return OK; - exception - when Program_Error => - return P_E; - when others => - return O_E; - end Nested; - - begin -- Never_Fails_Nest - S := Nested (Y); - end Never_Fails_Nest; - - ------------------------------------------------------------------ - - procedure Called_By_Never_Fails_Same - (X: access Desig; R: out Result_Kind) is - type Acc_Local is access all Desig; - AL : Acc_Local; - - -- Dereference of an access_to_object value is aliased. - Ren : Desig renames X.all; -- Renaming of a dereference - begin -- of an access parameter. - -- Ren'Access below will always be safe, since the accessibility - -- level (although not necessarily the static nesting depth) of - -- type of AL will always be deeper than or the same as that of the - -- actual corresponding to Y. - AL := Ren'Access; - if Ident_Int (AL(4)) /= 3 then --Avoid Optimization of AL - FAILED ("Initial Values not correct."); - end if; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Called_By_Never_Fails_Same; - - ------------------------------------------------------------------ - - procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is - begin - Called_By_Never_Fails_Same (Y, S); - end Never_Fails_Same; - -end C3A2003_0; - - - --==================================================================-- - - -with C3A2003_0; -use C3A2003_0; - -with Report; use report; - -procedure C3A2003 is - - type Acc_L1 is access all Desig; -- Level = 1. - A1 : Acc_L1; - X1 : aliased Desig := (Desig'Range => Ident_Int(3)); - Res : Result_Kind; - - - procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is - begin - -- The accessibility level of the type of A1 is 1. - A1 := X.all'Access; - if IDENT_INT (A1(4)) /= 3 then --Avoid optimization of A1 - FAILED ("Initial values not correct."); - end if; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Called_By_Target_L1; - - ------------------------------------------------------------------ - - function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is - S : Result_Kind; - begin - Called_By_Target_L1 (Y, S); - return S; - end Target_Is_Level_1_Same; - - ------------------------------------------------------------------ - - procedure Display_Results (Result : in Result_Kind; - Expected: in Result_Kind; - Msg : in String) is - begin - if Result /= Expected then - case Result is - when OK => Report.Failed ("No exception raised: " & Msg); - when P_E => Report.Failed ("Program_Error raised: " & Msg); - when O_E => Report.Failed ("Unexpected exception raised: " & Msg); - end case; - end if; - end Display_Results; - -begin -- C3A2003 - - Report.Test ("C3A2003", "Check that, for X'Access of general access " & - "type A, Program_Error is raised if the accessibility " & - "level of X is deeper than that of A: X is an access " & - "parameter; corresponding actual is another access " & - "parameter"); - - - -- Accessibility level of actual is 0 (actual is X'Access): - - Never_Fails_Same (X0'Access, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); - - Never_Fails_Nest (X0'Access, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); - - Target_Is_Level_0_Nest (X0'Access, Res); - Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); - - Res := Target_Is_Level_1_Same (X0'Access); - Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); - - - -- Accessibility level of actual is 1 (actual is X'Access): - - Never_Fails_Same (X1'Access, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); - - Never_Fails_Nest (X1'Access, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); - - Target_Is_Level_0_Nest (X1'Access, Res); - Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); - - Res := Target_Is_Level_1_Same (X1'Access); - Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); - - - Block_L2: - declare - X2 : aliased Desig := (Desig'Range => Ident_Int(3)); - type Acc_L2 is access all Desig; -- Level = 2. - Expr_L2 : Acc_L2 := X2'Access; - begin - - -- Accessibility level of actual is 2 (actual is expression of named - -- access type): - - Never_Fails_Same (Expr_L2, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); - - Never_Fails_Nest (Expr_L2, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); - - Target_Is_Level_0_Nest (Expr_L2, Res); - Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); - - Res := Target_Is_Level_1_Same (Expr_L2); - Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); - - end Block_L2; - - Report.Result; - -end C3A2003; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a deleted file mode 100644 index 8271d486904..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a +++ /dev/null @@ -1,367 +0,0 @@ --- C3A2A01.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, for X'Access of a general access type A, Program_Error is --- raised if the accessibility level of X is deeper than that of A. --- Check for cases where X'Access occurs in an instance body, and A --- is passed as an actual during instantiation. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the designated --- object X must be at the same or a less deep nesting level than the --- general access type A -- X must "live" as long as A. Nesting --- levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares three generic units, each of which has a formal --- general access type: --- --- (1) A generic package, in which X is declared in the specification, --- and X'Access occurs within the declarative part of the body. --- --- (2) A generic package, in which X is a formal in out object of a --- tagged formal derived type, and X'Access occurs in the sequence --- of statements of a nested subprogram. --- --- (3) A generic procedure, in which X is a dereference of an access --- parameter, and X'Access occurs in the sequence of statements. --- --- The test verifies the following: --- --- For (1), Program_Error is raised upon instantiation if the generic --- package is instantiated at a deeper level than that of the general --- access type passed as an actual. The exception is propagated to the --- innermost enclosing master. --- --- For (2), Program_Error is raised when the nested subprogram is --- called if the object passed as an actual during instantiation of --- the generic package has an accessibility level deeper than that of --- the general access type passed as an actual. The exception is --- handled within the nested subprogram. Also, check that --- Program_Error is not raised if the level of the actual access type --- is deeper than that of the actual object. --- --- For (3), Program_Error is raised when the instance subprogram is --- called if the object pointed to by the actual corresponding to --- the access parameter has an accessibility level deeper than that of --- the general access type passed as an actual during instantiation. --- The exception is handled within the instance subprogram. Also, --- check that Program_Error is not raised if the level of the actual --- access type is deeper than that of the actual corresponding to the --- access parameter. --- --- TEST FILES: --- The following files comprise this test: --- --- F3A2A00.A --- -> C3A2A01.A --- --- --- CHANGE HISTORY: --- 12 May 95 SAIC Initial prerelease version. --- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. --- ---! - -with F3A2A00; -generic - type FD is new F3A2A00.Array_Type; - type FAF is access all FD; -package C3A2A01_0 is - X : aliased FD; - - procedure Dummy; -- Needed to allow package body. -end C3A2A01_0; - - - --==================================================================-- - - -with Report; -package body C3A2A01_0 is - Ptr : FAF := X'Access; - Index : Integer := F3A2A00.Array_Type'First; - - procedure Dummy is - begin - null; - end Dummy; -begin - -- Avoid optimization (dead variable removal of Ptr): - - if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. - Report.Failed ("Unexpected error in C3A2A01_0 instance"); - end if; -end C3A2A01_0; - - - --==================================================================-- - - -with F3A2A00; -generic - type FD is new F3A2A00.Tagged_Type with private; - type FAF is access all FD; - FObj : in out FD; -package C3A2A01_1 is - procedure Handle (R: out F3A2A00.TC_Result_Kind); -end C3A2A01_1; - - - --==================================================================-- - - -with Report; -package body C3A2A01_1 is - - procedure Handle (R: out F3A2A00.TC_Result_Kind) is - Ptr : FAF; - begin - Ptr := FObj'Access; - R := F3A2A00.OK; - - -- Avoid optimization (dead variable removal of Ptr): - - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in Handle"); - end if; - exception - when Program_Error => R := F3A2A00.P_E; - when others => R := F3A2A00.O_E; - end Handle; - -end C3A2A01_1; - - - --==================================================================-- - - -with F3A2A00; -generic - type FD is new F3A2A00.Array_Type; - type FAF is access all FD; -procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind); - - - --==================================================================-- - - -with Report; -procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is - Ptr : FAF; - Index : Integer := F3A2A00.Array_Type'First; -begin - Ptr := P.all'Access; - R := F3A2A00.OK; - - -- Avoid optimization (dead variable removal of Ptr): - - if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. - Report.Failed ("Unexpected error in C3A2A01_2 instance"); - end if; -exception - when Program_Error => R := F3A2A00.P_E; - when others => R := F3A2A00.O_E; -end C3A2A01_2; - - - --==================================================================-- - - -with F3A2A00; -with C3A2A01_0; -with C3A2A01_1; -with C3A2A01_2; - -with Report; -procedure C3A2A01 is -begin -- C3A2A01. -- [ Level = 1 ] - - Report.Test ("C3A2A01", "Run-time accessibility checks: instance " & - "bodies. Type of X'Access is passed as actual to instance"); - - - SUBTEST1: - declare -- [ Level = 2 ] - Result : F3A2A00.TC_Result_Kind; - begin -- SUBTEST1. - - declare -- [ Level = 3 ] - type AccArr_L3 is access all F3A2A00.Array_Type; - begin - declare -- [ Level = 4 ] - -- The accessibility level of Pack.X is that of the instantiation - -- (4). The accessibility level of the actual access type used to - -- instantiate Pack is 3. Therefore, the X'Access in Pack - -- propagates Program_Error when the instance body is elaborated: - - package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3); - begin - Result := F3A2A00.OK; - end; - exception - when Program_Error => Result := F3A2A00.P_E; -- Expected result. - when others => Result := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1"); - - end SUBTEST1; - - - - SUBTEST2: - declare -- [ Level = 2 ] - Result : F3A2A00.TC_Result_Kind; - begin -- SUBTEST2. - - declare -- [ Level = 3 ] - -- The instantiation of C3A2A01_1 should NOT result in any - -- exceptions. - - type AccTag_L3 is access all F3A2A00.Tagged_Type; - - package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type, - AccTag_L3, - F3A2A00.X_L0); - begin - -- The accessibility level of the actual object used to instantiate - -- Pack_OK is 0. The accessibility level of the actual access type - -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in - -- Pack_OK.Handle does not raise an exception when the subprogram is - -- called. If an exception is (incorrectly) raised, however, it is - -- handled within the subprogram: - - Pack_OK.Handle (Result); - end; - - F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " & - "during instantiation of generic"); - when others => - Report.Failed ("SUBTEST #2: Unexpected exception raised " & - "during instantiation of generic"); - end SUBTEST2; - - - - SUBTEST3: - declare -- [ Level = 2 ] - Result : F3A2A00.TC_Result_Kind; - begin -- SUBTEST3. - - declare -- [ Level = 3 ] - -- The instantiation of C3A2A01_1 should NOT result in any - -- exceptions. - - X_L3: F3A2A00.Tagged_Type; - - package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type, - F3A2A00.AccTag_L0, - X_L3); - begin - -- The accessibility level of the actual object used to instantiate - -- Pack_PE is 3. The accessibility level of the actual access type - -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in - -- Pack_OK.Handle raises Program_Error when the subprogram is - -- called. The exception is handled within the subprogram: - - Pack_PE.Handle (Result); - end; - - F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " & - "during instantiation of generic"); - when others => - Report.Failed ("SUBTEST #3: Unexpected exception raised " & - "during instantiation of generic"); - end SUBTEST3; - - - - SUBTEST4: - declare -- [ Level = 2 ] - Result1 : F3A2A00.TC_Result_Kind; - Result2 : F3A2A00.TC_Result_Kind; - begin -- SUBTEST4. - - declare -- [ Level = 3 ] - -- The instantiation of C3A2A01_2 should NOT result in any - -- exceptions. - - X_L3: aliased F3A2A00.Array_Type; - type AccArr_L3 is access all F3A2A00.Array_Type; - - procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3); - begin - -- The accessibility level of Proc.P.all is that of the corresponding - -- actual during the call (in this case 3). The accessibility level of - -- the access type used to instantiate Proc is also 3. Therefore, the - -- P.all'Access in Proc does not raise an exception when the - -- subprogram is called. If an exception is (incorrectly) raised, - -- however, it is handled within the subprogram: - - Proc (X_L3'Access, Result1); - - F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, - "SUBTEST #4: same levels"); - - declare -- [ Level = 4 ] - X_L4: aliased F3A2A00.Array_Type; - begin - -- Within this block, the accessibility level of the actual - -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access - -- in Proc raises Program_Error when the subprogram is called. The - -- exception is handled within the subprogram: - - Proc (X_L4'Access, Result2); - - F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, - "SUBTEST #4: object at deeper level"); - end; - - end; - - exception - when Program_Error => - Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " & - "during instantiation of generic"); - when others => - Report.Failed ("SUBTEST #4: Unexpected exception raised " & - "during instantiation of generic"); - end SUBTEST4; - - - Report.Result; - -end C3A2A01; diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a deleted file mode 100644 index 23b2c1c5de8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a +++ /dev/null @@ -1,396 +0,0 @@ --- C3A2A02.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, for X'Access of a general access type A, Program_Error is --- raised if the accessibility level of X is deeper than that of A. --- Check for cases where X'Access occurs in an instance body, and A --- is a type either declared inside the instance, or declared outside --- the instance but not passed as an actual during instantiation. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the designated --- object X must be at the same or a less deep nesting level than the --- general access type A -- X must "live" as long as A. Nesting --- levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares three generic packages: --- --- (1) One in which X is of a formal tagged derived type and declared --- in the body, A is a type declared outside the instance, and --- X'Access occurs in the declarative part of a nested subprogram. --- --- (2) One in which X is a formal object of a tagged type, A is a --- type declared outside the instance, and X'Access occurs in the --- declarative part of the body. --- --- (3) One in which there are two X's and two A's. In the first pair, --- X is a formal in object of a tagged type, A is declared in the --- specification, and X'Access occurs in the declarative part of --- the body. In the second pair, X is of a formal derived type, --- X and A are declared in the specification, and X'Access occurs --- in the sequence of statements of the body. --- --- The test verifies the following: --- --- For (1), Program_Error is raised when the nested subprogram is --- called, if the generic package is instantiated at a deeper level --- than that of A. The exception is propagated to the innermost --- enclosing master. Also, check that Program_Error is not raised --- if the instantiation is at the same level as that of A. --- --- For (2), Program_Error is raised upon instantiation if the object --- passed as an actual during instantiation has an accessibility level --- deeper than that of A. The exception is propagated to the innermost --- enclosing master. Also, check that Program_Error is not raised if --- the level of the actual object is not deeper than that of A. --- --- For (3), Program_Error is not raised, for actual objects at --- various accessibility levels (since A will have at least the same --- accessibility level as X in all cases, no exception should ever --- be raised). --- --- TEST FILES: --- The following files comprise this test: --- --- F3A2A00.A --- -> C3A2A02.A --- --- --- CHANGE HISTORY: --- 12 May 95 SAIC Initial prerelease version. --- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. --- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package --- package C3A2A02_3, in order to avoid possible --- instantiation error. ---! - -with F3A2A00; -generic - type FD is new F3A2A00.Tagged_Type with private; -package C3A2A02_0 is - procedure Proc; -end C3A2A02_0; - - - --==================================================================-- - - -with Report; -package body C3A2A02_0 is - X : aliased FD; - - procedure Proc is - Ptr : F3A2A00.AccTagClass_L0 := X'Access; - begin - -- Avoid optimization (dead variable removal of Ptr): - - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in Proc"); - end if; - end Proc; -end C3A2A02_0; - - - --==================================================================-- - - -with F3A2A00; -generic - FObj : in out F3A2A00.Tagged_Type; -package C3A2A02_1 is - procedure Dummy; -- Needed to allow package body. -end C3A2A02_1; - - - --==================================================================-- - - -with Report; -package body C3A2A02_1 is - Ptr : F3A2A00.AccTag_L0 := FObj'Access; - - procedure Dummy is - begin - null; - end Dummy; -begin - -- Avoid optimization (dead variable removal of Ptr): - - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in C3A2A02_1 instance"); - end if; -end C3A2A02_1; - - - --==================================================================-- - - -with F3A2A00; -generic - type FD is new F3A2A00.Array_Type; - FObj : in F3A2A00.Tagged_Type; -package C3A2A02_2 is - type GAF is access all FD; - type GAO is access constant F3A2A00.Tagged_Type; - XG : aliased FD; - PtrF : GAF; - Index : Integer := FD'First; - - procedure Dummy; -- Needed to allow package body. -end C3A2A02_2; - - - --==================================================================-- - - -with Report; -package body C3A2A02_2 is - PtrO : GAO := FObj'Access; - - procedure Dummy is - begin - null; - end Dummy; -begin - PtrF := XG'Access; - - -- Avoid optimization (dead variable removal of PtrO and/or PtrF): - - if not Report.Equal (PtrO.C, PtrO.C) then -- Always false. - Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO"); - end if; - - if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false. - Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF"); - end if; -end C3A2A02_2; - - - --==================================================================-- - - --- The instantiation of C3A2A02_0 should NOT result in any exceptions. - -with F3A2A00; -with C3A2A02_0; -pragma Elaborate (C3A2A02_0); -package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type); - - - --==================================================================-- - - -with F3A2A00; -with C3A2A02_0; -with C3A2A02_1; -with C3A2A02_2; -with C3A2A02_3; - -with Report; -procedure C3A2A02 is -begin -- C3A2A02. -- [ Level = 1 ] - - Report.Test ("C3A2A02", "Run-time accessibility checks: instance " & - "bodies. Type of X'Access is local or global to instance"); - - - SUBTEST1: - declare -- [ Level = 2 ] - Result1 : F3A2A00.TC_Result_Kind; - Result2 : F3A2A00.TC_Result_Kind; - begin -- SUBTEST1. - - declare -- [ Level = 3 ] - package Pack_Same_Level renames C3A2A02_3; - begin - -- The accessibility level of Pack_Same_Level.X is that of the - -- instance (0), not that of the renaming declaration. The level of - -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is - -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise - -- an exception when the subprogram is called. The level of execution - -- of the subprogram is irrelevant: - - Pack_Same_Level.Proc; - Result1 := F3A2A00.OK; -- Expected result. - exception - when Program_Error => Result1 := F3A2A00.P_E; - when others => Result1 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, - "SUBTEST #1 (same level)"); - - - declare -- [ Level = 3 ] - -- The instantiation of C3A2A02_0 should NOT result in any - -- exceptions. - - package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type); - begin - -- The accessibility level of Pack_Deeper_Level.X is that of the - -- instance (3). The level of the type of Pack_Deeper_Level.X'Access - -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in - -- Pack_Deeper_Level.Proc propagates Program_Error when the - -- subprogram is called: - - Pack_Deeper_Level.Proc; - Result2 := F3A2A00.OK; - exception - when Program_Error => Result2 := F3A2A00.P_E; -- Expected result. - when others => Result2 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, - "SUBTEST #1: deeper level"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " & - "during instantiation of generic"); - when others => - Report.Failed ("SUBTEST #1: Unexpected exception raised " & - "during instantiation of generic"); - end SUBTEST1; - - - - SUBTEST2: - declare -- [ Level = 2 ] - Result1 : F3A2A00.TC_Result_Kind; - Result2 : F3A2A00.TC_Result_Kind; - begin -- SUBTEST2. - - declare -- [ Level = 3 ] - X_L3 : F3A2A00.Tagged_Type; - begin - declare -- [ Level = 4 ] - -- The accessibility level of the actual object corresponding to - -- FObj in Pack_PE is 3. The level of the type of FObj'Access - -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE - -- propagates Program_Error when the instance body is elaborated: - - package Pack_PE is new C3A2A02_1 (X_L3); - begin - Result1 := F3A2A00.OK; - end; - exception - when Program_Error => Result1 := F3A2A00.P_E; -- Expected result. - when others => Result1 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E, - "SUBTEST #2: deeper level"); - - - begin -- [ Level = 3 ] - declare -- [ Level = 4 ] - -- The accessibility level of the actual object corresponding to - -- FObj in Pack_OK is 0. The level of the type of FObj'Access - -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in - -- Pack_OK does not raise an exception when the instance body is - -- elaborated: - - package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0); - begin - Result2 := F3A2A00.OK; -- Expected result. - end; - exception - when Program_Error => Result2 := F3A2A00.P_E; - when others => Result2 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, - "SUBTEST #2: same level"); - - end SUBTEST2; - - - - SUBTEST3: - declare -- [ Level = 2 ] - Result1 : F3A2A00.TC_Result_Kind; - Result2 : F3A2A00.TC_Result_Kind; - begin -- SUBTEST3. - - declare -- [ Level = 3 ] - X_L3 : F3A2A00.Tagged_Type; - begin - declare -- [ Level = 4 ] - -- Since the accessibility level of the type of X'Access in - -- both cases within Pack_OK1 is that of the instance, and since - -- X is either passed as an actual (in which case its level will - -- not be deeper than that of the instance) or is declared within - -- the instance (in which case its level is the same as that of - -- the instance), no exception should be raised when the instance - -- body is elaborated: - - package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3); - begin - Result1 := F3A2A00.OK; -- Expected result. - end; - exception - when Program_Error => Result1 := F3A2A00.P_E; - when others => Result1 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, - "SUBTEST #3: 1st okay case"); - - - declare -- [ Level = 3 ] - type My_Array is new F3A2A00.Array_Type; - begin - declare -- [ Level = 4 ] - -- Since the accessibility level of the type of X'Access in - -- both cases within Pack_OK2 is that of the instance, and since - -- X is either passed as an actual (in which case its level will - -- not be deeper than that of the instance) or is declared within - -- the instance (in which case its level is the same as that of - -- the instance), no exception should be raised when the instance - -- body is elaborated: - - package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0); - begin - Result2 := F3A2A00.OK; -- Expected result. - end; - exception - when Program_Error => Result2 := F3A2A00.P_E; - when others => Result2 := F3A2A00.O_E; - end; - - F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, - "SUBTEST #3: 2nd okay case"); - - - end SUBTEST3; - - - - Report.Result; - -end C3A2A02; |