-- C431004.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. -- --* -- OBJECTIVE: -- Check that the association in an extension aggregate for a discriminant -- with a default can be given by <>. -- -- TEST DESCRIPTION: -- Extension aggregate cases for paragraph 4.3.1(17.1/2). Note that this -- rule applies to all Ada versions since Amendment 1 for Ada 95. -- -- Aggregates are commonly used. Thus, we assume that almost all cases -- will eventually appear in actual usage and thus do not try to describe -- a specific usage scenario. -- -- CHANGE HISTORY: -- 2022-02-24 JAC Initial pre-release version. -- 2022-03-28 RLB Cleaned up for release. -- --! with Report; procedure C431004 is type Units_Type is (Feet, Metres); type Tagged_Units_Type is tagged record Units_Field : Units_Type; end record; Tagged_Units : constant Tagged_Units_Type := (Units_Field => Metres); -- Example where a discriminant of a numeric type determines the bounds of a -- 1-D array type Integer_Vector_Type is array (Integer range <>) of Integer; Max : constant := 100; subtype Index is Integer range 0 .. Max; type Poly_Type (N : Index := 1) is record IV : Integer_Vector_Type (0 .. N); end record; type Dimensioned_Poly_Type is new Tagged_Units_Type with record Poly : Poly_Type; end record; -- Discriminant explicitly initialised to default Dimensioned_Poly_1 : constant Dimensioned_Poly_Type := (Units_Field => Metres, Poly => (N => <>, IV => <>)); -- Discriminant explicitly initialised to a specific value Dimensioned_Poly_2 : Dimensioned_Poly_Type := (Units_Field => Feet, Poly => (N => 2, IV => <>)); -- Example where discriminants of a numeric type determine the bounds of a -- matrix subtype Bounds_Type is Integer range 0 .. 100; type Matrix_Type is array (Bounds_Type range <>, Bounds_Type range <>) of Float; type Matrix_Rec_Type (Rows : Integer := 2; Columns : Integer := 3) is record Mat : Matrix_Type (1 .. Rows, 1 .. Columns); end record; type Dimensioned_Matrix_Rec_Type is new Tagged_Units_Type with record Matrix_Rec : Matrix_Rec_Type; end record; Dimensioned_Matrix_Rec : Dimensioned_Matrix_Rec_Type := (Units_Field => Metres, Matrix_Rec => (Rows => <>, Columns => <>, Mat => (others => (others => 0.0)))); -- Example where a discriminant of an enumeration type selects a variant type Gender_Type is (Male, Female); type Person_Type (Gender : Gender_Type := Male) is record Height : Float; case Gender is when Male => Bearded : Boolean; when Female => No_Of_Children : Natural; end case; end record; type Dimensioned_Person_Type is new Tagged_Units_Type with record Person : Person_Type; end record; Dimensioned_Person : Dimensioned_Person_Type; begin Report.Test ("C431004", "Check that the association in an extension aggregate for a" & " discriminant with a default can be given by <>"); -- Check that the default discriminant value of 1 has been used if Dimensioned_Poly_1.Poly.N /= 1 then Report.Failed ("Discriminant not as expected, 1-D array, discriminant set to" & " default at creation"); end if; -- Discriminant returned to default by assignment Dimensioned_Poly_2 := (Tagged_Units with Poly => (N => <>, IV => <>)); -- Check that the default discriminant value of 1 has been used if Dimensioned_Poly_2.Poly.N /= 1 then Report.Failed ("Discriminant not as expected, 1-D array, discriminant reset to" & " default at subsequent assignment"); end if; -- Check that the default discriminant values of 2 and 3 have been used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 2 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 3 then Report.Failed ("Discriminants not as expected, rows and columns both set to" & " defaults at creation"); end if; Dimensioned_Matrix_Rec := (Tagged_Units with Matrix_Rec => (Rows => <>, Columns => <>, Mat => (others => (others => 0.0)))); -- Check that the default discriminant values of 2 and 3 have been used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 2 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 3 then Report.Failed ("Discriminants not as expected, rows and columns both set to" & " defaults at subsequent assignment"); end if; Dimensioned_Matrix_Rec := (Tagged_Units with Matrix_Rec => (Rows => 5, Columns => <>, Mat => (others => (others => 0.0)))); -- Check that the discriminant values of specific 5 and default 3 have been -- used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 5 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 3 then Report.Failed ("Discriminants not as expected, rows specific and columns using" & " default"); end if; Dimensioned_Matrix_Rec := (Tagged_Units with Matrix_Rec => (Rows => <>, Columns => 4, Mat => (others => (others => 0.0)))); -- Check that the discriminant values of default 2 and specific 4 have been -- used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 2 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 4 then Report.Failed ("Discriminants not as expected, rows using default and columns" & " specific"); end if; Dimensioned_Matrix_Rec := (Tagged_Units with Matrix_Rec => (others => <>)); -- Check that the default discriminant values of 2 and 3 have been used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 2 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 3 then Report.Failed ("Discriminants not as expected, rows and columns both set to" & " defaults at subsequent assignment using others"); end if; Dimensioned_Matrix_Rec := (Tagged_Units with Matrix_Rec => (Rows => 6, others => <>)); -- Check that the discriminant values of specific 6 and default 3 have been -- used if Dimensioned_Matrix_Rec.Matrix_Rec.Rows /= 6 and then Dimensioned_Matrix_Rec.Matrix_Rec.Columns /= 3 then Report.Failed ("Discriminants not as expected, rows specific and columns using" & " default via others"); end if; Dimensioned_Person := (Tagged_Units with Person => (Gender => <>, Height => <>, Bearded => <>)); -- Check that the default discriminant value of Male has been used if Dimensioned_Person.Person.Gender /= Male then Report.Failed ("Discriminant not as expected, variant parts"); end if; Dimensioned_Person := (Tagged_Units with Person => (others => <>)); -- Check that the default discriminant value of Male has been used if Dimensioned_Person.Person.Gender /= Male then Report.Failed ("Discriminant not as expected, variant parts - 2"); end if; Dimensioned_Person := (Tagged_Units with Person => (Gender => Female, others => <>)); -- Check that the discriminant value of Female has been used if Dimensioned_Person.Person.Gender /= Female then Report.Failed ("Discriminant not as expected, variant parts - 3"); end if; Report.Result; end C431004;