diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c5/c540001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c5/c540001.a | 410 |
1 files changed, 0 insertions, 410 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c5/c540001.a b/gcc/testsuite/ada/acats/tests/c5/c540001.a deleted file mode 100644 index b7dbdd6e97f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c5/c540001.a +++ /dev/null @@ -1,410 +0,0 @@ --- C540001.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 expression in a case statement may be of a generic formal --- type. Check that a function call may be used as a case statement --- expression. Check that a call to a generic formal function may be --- used as a case statement expression. Check that a call to an inherited --- function may be used as a case statement expression even if its result --- type does not correspond to any nameable subtype. --- --- TEST DESCRIPTION: --- This transition test creates examples where expressions in a case --- statement can be a generic formal object and a call to a generic formal --- function. This test also creates examples when either a function call, --- a renaming of a function, or a call to an inherited function is used --- in the case expressions, the choices of the case statement only need --- to cover the values in the result of the function. --- --- Inspired by B54A08A.ADA. --- --- --- CHANGE HISTORY: --- 12 Feb 96 SAIC Initial version for ACVC 2.1. --- ---! - -package C540001_0 is - type Int is range 1 .. 2; - -end C540001_0; - - --==================================================================-- - -with C540001_0; -package C540001_1 is - type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3. - type Mixed is ('A','B', 'C', None); - subtype Small_Num is Natural range 0 .. 10; - type Small_Int is range 1 .. 2; - function Get_Small_Int (P : Boolean) return Small_Int; - procedure Assign_Mixed (P1 : in Boolean; - P2 : out Mixed); - - type Tagged_Type is tagged - record - C1 : Enum_Type; - end record; - function Get_Tagged (P : Tagged_Type) return C540001_0.Int; - -end C540001_1; - - --==================================================================-- - -package body C540001_1 is - function Get_Small_Int (P : Boolean) return Small_Int is - begin - if P then - return Small_Int'First; - else - return Small_Int'Last; - end if; - end Get_Small_Int; - - --------------------------------------------------------------------- - procedure Assign_Mixed (P1 : in Boolean; - P2 : out Mixed) is - begin - case Get_Small_Int (P1) is -- Function call as expression - when 1 => P2 := None; -- in case statement. - when 2 => P2 := 'A'; - -- No others needed. - end case; - - end Assign_Mixed; - - --------------------------------------------------------------------- - function Get_Tagged (P : Tagged_Type) return C540001_0.Int is - begin - return C540001_0.Int'Last; - end Get_Tagged; - -end C540001_1; - - --==================================================================-- - -generic - - type Formal_Scalar is range <>; - - FSO : Formal_Scalar; - -package C540001_2 is - - type Enum is (Alpha, Beta, Theta); - - procedure Assign_Enum (ET : out Enum); - -end C540001_2; - - --==================================================================-- - -package body C540001_2 is - - procedure Assign_Enum (ET : out Enum) is - begin - case FSO is -- Type of expression in case - when 1 => ET := Alpha; -- statement is generic formal type. - when 2 => ET := Beta; - when others => ET := Theta; - end case; - - end Assign_Enum; - -end C540001_2; - - --==================================================================-- - -with C540001_1; -generic - - type Formal_Enum_Type is new C540001_1.Enum_Type; - - with function Formal_Func (P : C540001_1.Small_Num) - return Formal_Enum_Type is <>; - -function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type; - - --==================================================================-- - -function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is - -begin - return Formal_Func (P); -end C540001_3; - - --==================================================================-- - -with C540001_1; -generic - - type Formal_Int_Type is new C540001_1.Small_Int; - - with function Formal_Func return Formal_Int_Type; - -package C540001_4 is - - procedure Gen_Assign_Mixed (P : out C540001_1.Mixed); - -end C540001_4; - - --==================================================================-- - -package body C540001_4 is - - procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is - begin - case Formal_Func is -- Case expression is - when 1 => P := C540001_1.'A'; -- generic function. - when others => P := C540001_1.'B'; - end case; - - end Gen_Assign_Mixed; - -end C540001_4; - - --==================================================================-- - -with C540001_1; -package C540001_5 is - type New_Tagged is new C540001_1.Tagged_Type with - record - C2 : C540001_1.Mixed; - end record; - - -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int; - -- Note that the return type of the inherited function is not - -- nameable here. - - procedure Assign_Tagged (P1 : in New_Tagged; - P2 : out New_Tagged); - -end C540001_5; - - --==================================================================-- - -package body C540001_5 is - - procedure Assign_Tagged (P1 : in New_Tagged; - P2 : out New_Tagged) is - begin - case Get_Tagged (P1) is -- Case expression is - -- inherited function. - when 2 => P2 := (C540001_1.Bee, 'B'); - when others => P2 := (C540001_1.Sea, C540001_1.None); - end case; - - end Assign_Tagged; - -end C540001_5; - - --==================================================================-- - -with Report; -with C540001_1; -with C540001_2; -with C540001_3; -with C540001_4; -with C540001_5; - -procedure C540001 is - type Value is range 1 .. 5; - -begin - Report.Test ("C540001", "Check that an expression in a case statement " & - "may be of a generic formal type. Check that a function " & - "call may be used as a case statement expression. Check " & - "that a call to a generic formal function may be used as " & - "a case statement expression. Check that a call to an " & - "inherited function may be used as a case statement " & - "expression"); - - Generic_Formal_Object_Subtest: - begin - declare - One : Value := 1; - package One_Pck is new C540001_2 (Value, One); - use One_Pck; - EObj : Enum; - begin - Assign_Enum (EObj); - if EObj /= Alpha then - Report.Failed ("Incorrect result for value of one in generic" & - "formal object subtest"); - end if; - end; - - declare - Five : Value := 5; - package Five_Pck is new C540001_2 (Value, Five); - use Five_Pck; - EObj : Enum; - begin - Assign_Enum (EObj); - if EObj /= Theta then - Report.Failed ("Incorrect result for value of five in generic" & - "formal object subtest"); - end if; - end; - - end Generic_Formal_Object_Subtest; - - Instantiated_Generic_Function_Subtest: - declare - type New_Enum_Type is new C540001_1.Enum_Type; - - function Get_Enum_Value (P : C540001_1.Small_Num) - return New_Enum_Type is - begin - return New_Enum_Type'Val (P); - end Get_Enum_Value; - - function Val_Func is new C540001_3 - (Formal_Enum_Type => New_Enum_Type, - Formal_Func => Get_Enum_Value); - - procedure Assign_Num (P : in out C540001_1.Small_Num) is - begin - case Val_Func (P) is -- Case expression is - -- instantiated generic - when New_Enum_Type (C540001_1.Eh) | -- function. - New_Enum_Type (C540001_1.Sea) => P := 4; - when New_Enum_Type (C540001_1.Bee) => P := 7; - when others => P := 9; - end case; - - end Assign_Num; - - SNObj : C540001_1.Small_Num; - - begin - SNObj := 0; - Assign_Num (SNObj); - if SNObj /= 4 then - Report.Failed ("Incorrect result for value of zero in call to " & - "generic function subtest"); - end if; - - SNObj := 3; - Assign_Num (SNObj); - if SNObj /= 9 then - Report.Failed ("Incorrect result for value of three in call to " & - "generic function subtest"); - end if; - - end Instantiated_Generic_Function_Subtest; - - -- When a function call, a renaming of a function, or a call to an - -- inherited function is used in the case expressions, the choices - -- of the case statement only need to cover the values in the result - -- of the function. - - Function_Call_Subtest: - declare - MObj : C540001_1.Mixed := 'B'; - BObj : Boolean := True; - use type C540001_1.Mixed; - begin - C540001_1.Assign_Mixed (BObj, MObj); - if MObj /= C540001_1.None then - Report.Failed ("Incorrect result for value of true in function" & - "call subtest"); - end if; - - BObj := False; - C540001_1.Assign_Mixed (BObj, MObj); - if MObj /= C540001_1.'A' then - Report.Failed ("Incorrect result for value of false in function" & - "call subtest"); - end if; - - end Function_Call_Subtest; - - Function_Renaming_Subtest: - declare - use C540001_1; - function Rename_Get_Small_Int (P : Boolean) - return Small_Int renames Get_Small_Int; - MObj : Mixed := None; - BObj : Boolean := False; - begin - case Rename_Get_Small_Int (BObj) is - when 1 => MObj := 'A'; - when 2 => MObj := 'B'; - -- No others needed. - end case; - - if MObj /= 'B' then - Report.Failed ("Incorrect result for value of false in function" & - "renaming subtest"); - end if; - - end Function_Renaming_Subtest; - - Call_To_Generic_Formal_Function_Subtest: - declare - type New_Small_Int is new C540001_1.Small_Int; - - function Get_Int_Value return New_Small_Int is - begin - return New_Small_Int'First; - end Get_Int_Value; - - package Int_Pck is new C540001_4 - (Formal_Int_Type => New_Small_Int, - Formal_Func => Get_Int_Value); - - use type C540001_1.Mixed; - MObj : C540001_1.Mixed := C540001_1.None; - - begin - Int_Pck.Gen_Assign_Mixed (MObj); - if MObj /= C540001_1.'A' then - Report.Failed ("Incorrect result in call to generic formal " & - "function subtest"); - end if; - - end Call_To_Generic_Formal_Function_Subtest; - - Call_To_Inherited_Function_Subtest: - declare - NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh, - C2 => C540001_1.'A'); - NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C'); - use type C540001_1.Mixed; - use type C540001_1.Enum_Type; - begin - C540001_5.Assign_Tagged (NTObj1, NTObj2); - if NTObj2.C1 /= C540001_1.Bee or - NTObj2.C2 /= C540001_1.'B' then - Report.Failed ("Incorrect result in inherited function subtest"); - end if; - - end Call_To_Inherited_Function_Subtest; - - Report.Result; - -end C540001; |