-- B650007.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. -- -- Notice -- -- The ACAA has created and maintains the Ada Conformity Assessment Test -- Suite for the purpose of conformity assessments conducted in accordance -- with the International Standard ISO/IEC 18009 - Ada: Conformity -- assessment of a language processor. This test suite should not be used -- to make claims of conformance unless used in accordance with -- ISO/IEC 18009 and any applicable ACAA procedures. --* -- OBJECTIVES: -- Check that an extended return statement containing the reserved word -- aliased is only allowed if the type of the return object is immutably -- limited. -- -- TEST DESCRIPTION: -- This test checks the rule added by AI05-0277-1 (6.5(5.10/3)). This rule -- is incompatible with the Ada 2005 definition, although the language was -- badly specified for the aliased reserved word in extended return -- statements. Thus, any use was non-portable or unnecessary. -- -- CHANGE HISTORY: -- 30 Dec 2021 RLB Created new test. package B650007_0 is -- Declare a number of types, including some that are immutably limited. -- Note: Most of these types were copied from various foundations. -- Elementary types: type Status is (Unknown, Raw, Bound, Solved); type Numerals is range -256 .. 255; type Float_Type is digits 3; -- Tagged record types: subtype Lengths is Natural range 0 .. 50; type Parent is abstract tagged null record; type Tag (Len: Lengths) is new Parent with record Msg : String (1 .. Len); end record; -- Access types (designated type is tagged): type Tagged_Ptr is access Tag; type Tag_Class_Ptr is access Tag'Class; -- Array types: type An_Array is array (Positive range <>) of Float_Type; type Diff_Array is array (Numerals) of Status; -- Private types (not immutably limited): type Priv1 is limited private; type Priv2 is tagged private; -- Immutably limited types: type Lim_Rec is limited record A : Integer; B : Boolean; end record; protected type Prot is function Get return Natural; procedure Set (Val : in Natural); private Value : Natural := 0; end Prot; type Priv3 is tagged limited private; -- A record with an immutably limited component (not -- immutably limited): type Lim_Comp is record P : Prot; N : Natural; end record; private type Priv1 is new Lim_Rec; -- Full type is immutably limited, private type is not. type Priv2 is new Parent with null record; type Priv3 is tagged limited record P : Prot; N : Natural; end record; end B650007_0; package body B650007_0 is protected body Prot is function Get return Natural is begin return Value; end Get; procedure Set (Val : in Natural) is begin Value := Val; end Set; end Prot; end B650007_0; with B650007_0; use B650007_0; package B650007 is Glob : Boolean := False; function Test01 return Status; function Test02 return Numerals; function Test03 return Float_Type; function Test05 return Parent'Class; function Test06 return Tag; function Test07 return Tagged_Ptr; function Test08 return Tag_Class_Ptr; function Test09 return An_Array; function Test10 return Diff_Array; function Test11 return Priv1; function Test12 return Priv2; function Test13 return Lim_Rec; function Test14 return Prot; function Test15 return Priv3; function Test16 return Lim_Comp; end B650007; package body B650007 is function Test01 return Status is begin if Glob then return A : Status := Unknown; -- OK. {10} else return B : aliased Status := Unknown; -- ERROR: {10} end if; end Test01; function Test02 return Numerals is begin if Glob then return A : Numerals := 0; -- OK. {10} else return B : aliased Numerals := 0; -- ERROR: {10} end if; end Test02; function Test03 return Float_Type is begin if Glob then return A : Float_Type := 0.0; -- OK. {10} else return B : aliased Float_Type := 0.0; -- ERROR: {10} end if; end Test03; function Test05 return Parent'Class is begin if Glob then return A : Tag(10); -- OK. {10} else return B : aliased Tag(10); -- ERROR: {10} end if; end Test05; function Test06 return Tag is begin if Glob then return A : Tag(10); -- OK. {10} else return B : aliased Tag(10); -- ERROR: {10} end if; end Test06; function Test07 return Tagged_Ptr is begin if Glob then return A : Tagged_Ptr := null; -- OK. {10} else return B : aliased Tagged_Ptr := null; -- ERROR: {10} end if; end Test07; function Test08 return Tag_Class_Ptr is begin if Glob then return A : Tag_Class_Ptr := null; -- OK. {10} else return B : aliased Tag_Class_Ptr := null; -- ERROR: {10} end if; end Test08; function Test09 return An_Array is begin if Glob then return A : An_Array(1..5); -- OK. {10} else return B : aliased An_Array(1..8); -- ERROR: {10} end if; end Test09; function Test10 return Diff_Array is begin if Glob then return A : Diff_Array; -- OK. {10} else return B : aliased Diff_Array; -- ERROR: {10} end if; end Test10; function Test11 return Priv1 is begin if Glob then return A : Priv1; -- OK. {10} else return B : aliased Priv1; -- ERROR: {10} end if; end Test11; function Test12 return Priv2 is begin if Glob then return A : Priv2; -- OK. {10} else return B : aliased Priv2; -- ERROR: {10} end if; end Test12; function Test13 return Lim_Rec is -- Lim_Rec is immutably limited. begin if Glob then return A : Lim_Rec; -- OK. {10} else return B : aliased Lim_Rec; -- OK. {10} end if; end Test13; function Test14 return Prot is -- Prot is immutably limited. begin if Glob then return A : Prot; -- OK. {10} else return B : aliased Prot; -- OK. {10} end if; end Test14; function Test15 return Priv3 is -- Priv3 is immutably limited. begin if Glob then return A : Priv3; -- OK. {10} else return B : aliased Priv3; -- OK. {10} end if; end Test15; function Test16 return Lim_Comp is begin if Glob then return A : Lim_Comp; -- OK. {10} else return B : aliased Lim_Comp; -- ERROR: {10} end if; end Test16; end B650007;