| -- 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; |
