Subversion Repositories openrisc_me

-- C432002.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 an extension aggregate specifies a value for a record

--      extension and the ancestor expression has discriminants that are

--      inherited by the record extension, then a check is made that each

--      discriminant has the value specified.

--

--      Check that if an extension aggregate specifies a value for a record

--      extension and the ancestor expression has discriminants that are not

--      inherited by the record extension, then a check is made that each

--      such discriminant has the value specified for the corresponding

--      discriminant.

--

--      Check that the corresponding discriminant value may be specified

--      in the record component association list or in the derived type

--      definition for an ancestor.

--

--      Check the case of ancestors that are several generations removed.

--      Check the case where the value of the discriminant(s) in question

--      is supplied several generations removed.

--

--      Check the case of multiple discriminants.

--

--      Check that Constraint_Error is raised if the check fails.

--

-- TEST DESCRIPTION:

--      A hierarchy of tagged types is declared from a discriminated

--      root type. Each level declares two kinds of types: (1) a type

--      extension which constrains the discriminant of its parent to

--      the value of an expression and (2) a type extension that

--      constrains the discriminant of its parent to equal a new discriminant

--      of the type extension (These are the two categories of noninherited

--      discriminants).

--

--      Values for each type are declared within nested blocks. This is

--      done so that the instances that produce Constraint_Error may

--      be dealt with cleanly without forcing the program to exit.

--

--      Success and failure cases (which should raise Constraint_Error)

--      are set up for each kind of type. Additionally, for the first

--      level of the hierarchy, separate tests are done for ancestor

--      expressions specified by aggregates and those specified by

--      variables. Later tests are performed using variables only.

--

--      Additionally, the cases tested consist of the following kinds of

--      types:

--

--         Extensions of extensions, using both the parent and grandparent

--         types for the ancestor expression,

--

--         Ancestor expressions which are several generations removed

--         from the type of the aggregate,

--

--         Extensions of types with multiple discriminants, where the

--         extension declares a new discriminant which corresponds to

--         more than one discriminant of the ancestor types.

--

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--      19 Dec 94   SAIC    Removed RM references from objective text.

--      20 Dec 94   SAIC    Repair confusion WRT overridden discriminants

--

--!

package C432002_0 is

   subtype Length is Natural range 0..256;

   type Discriminant (L : Length) is tagged

      record

         S1 : String (1..L);

      end record;

   procedure Do_Something (Rec : in out Discriminant);

   -- inherited by all type extensions

   -- Aggregates of Discriminant are of the form

   --    (L, S1) where L= S1'Length

   -- Discriminant of parent constrained to value of an expression

   type Constrained_Discriminant_Extension is

      new Discriminant (L => 10)

      with record

         S2 : String (1..20);

      end record;

   -- Aggregates of Constrained_Discriminant_Extension are of the form

   --    (L, S1, S2), where L = S1'Length = 10, S2'Length = 20

   type Once_Removed is new Constrained_Discriminant_Extension

      with record

         S3 : String (1..3);

      end record;

   type Twice_Removed is new Once_Removed

      with record

         S4 : String (1..8);

      end record;

   -- Aggregates of Twice_Removed are of the form

   --    (L, S1, S2, S3, S4), where L = S1'Length = 10,

   --                               S2'Length = 20,

   --                               S3'Length = 3,

   --                               S4'Length = 8

   -- Discriminant of parent constrained to equal new discriminant

   type New_Discriminant_Extension (N : Length) is

      new Discriminant (L => N) with

      record

         S2 : String (1..N);

      end record;

   -- Aggregates of New_Discriminant_Extension are of the form

   --   (N, S1, S2), where N = S1'Length = S2'Length

   -- Discriminant of parent extension constrained to the value of

   -- an expression

   type Constrained_Extension_Extension is

      new New_Discriminant_Extension (N => 20)

      with record

         S3 : String (1..5);

      end record;

   -- Aggregates of Constrained_Extension_Extension are of the form

   --   (N, S1, S2, S3), where N = S1'Length = S2'Length = 20,

   --                             S3'Length = 5

   -- Discriminant of parent extension constrained to equal a new

   -- discriminant

   type New_Extension_Extension (I : Length) is

      new New_Discriminant_Extension (N => I)

      with record

         S3 : String (1..I);

      end record;

   -- Aggregates of New_Extension_Extension are of the form

   --    (I, S1, 2, S3), where

   --       I = S1'Length = S2'Length = S3'Length

   type Multiple_Discriminants (A, B : Length) is tagged

      record

         S1 : String (1..A);

         S2 : String (1..B);

      end record;

   procedure Do_Something (Rec : in out Multiple_Discriminants);

   -- inherited by type extension

   -- Aggregates of Multiple_Discriminants are of the form

   --    (A, B, S1, S2), where A = S1'Length, B = S2'Length

   type Multiple_Discriminant_Extension (C : Length) is

      new Multiple_Discriminants (A => C, B => C)

      with record

         S3 : String (1..C);

      end record;

   -- Aggregates of Multiple_Discriminant_Extension are of the form

   --    (A, B, S1, S2, C, S3), where

   --       A = B = C = S1'Length = S2'Length = S3'Length

end C432002_0;

with Report;

package body C432002_0 is

   S : String (1..20) := "12345678901234567890";

   procedure Do_Something (Rec : in out Discriminant) is

   begin

      Rec.S1 := Report.Ident_Str (S (1..Rec.L));

   end Do_Something;

   procedure Do_Something (Rec : in out Multiple_Discriminants) is

   begin

      Rec.S1 := Report.Ident_Str (S (1..Rec.A));

   end Do_Something;

end C432002_0;

with C432002_0;

with Report;

procedure C432002 is

   -- Various different-sized strings for variety

   String_3  : String (1..3)  := Report.Ident_Str("123");

   String_5  : String (1..5)  := Report.Ident_Str("12345");

   String_8  : String (1..8)  := Report.Ident_Str("12345678");

   String_10 : String (1..10) := Report.Ident_Str("1234567890");

   String_11 : String (1..11) := Report.Ident_Str("12345678901");

   String_20 : String (1..20) := Report.Ident_Str("12345678901234567890");

begin

   Report.Test ("C432002",

                "Extension aggregates for discriminated types");

   --------------------------------------------------------------------

   -- Extension constrains parent's discriminant to value of expression

   --------------------------------------------------------------------

   -- Successful cases - value matches corresponding discriminant value

   CD_Matched_Aggregate:

   begin

      declare

         CD : C432002_0.Constrained_Discriminant_Extension :=

            (C432002_0.Discriminant'(L  => 10,

                                     S1 => String_10)

               with S2 => String_20);

      begin

         C432002_0.Do_Something(CD); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end CD_Matched_Aggregate;

   CD_Matched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 10) :=

            C432002_0.Discriminant'(L  => 10,

                                    S1 => String_10);

         CD : C432002_0.Constrained_Discriminant_Extension :=

            (D with S2 => String_20);

      begin

         C432002_0.Do_Something(CD); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is a variable");

         Report.Failed ("Aggregate of extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end CD_Matched_Variable;

   -- Unsuccessful cases - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   CD_Unmatched_Aggregate:

   begin

      declare

         CD : C432002_0.Constrained_Discriminant_Extension :=

            (C432002_0.Discriminant'(L  => 5,

                                     S1 => String_5)

               with S2 => String_20);

      begin

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(CD); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise of Constraint_Error is expected

   end CD_Unmatched_Aggregate;

   CD_Unmatched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 5) :=

            C432002_0.Discriminant'(L  => 5,

                                    S1 => String_5);

         CD : C432002_0.Constrained_Discriminant_Extension :=

            (D with S2 => String_20);

      begin

         Report.Comment ("Ancestor expression is an variable");

         Report.Failed ("Aggregate of extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(CD); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise of Constraint_Error is expected

   end CD_Unmatched_Variable;

   -----------------------------------------------------------------------

   -- Extension constrains parent's discriminant to equal new discriminant

   -----------------------------------------------------------------------

   -- Successful cases - value matches corresponding discriminant value

   ND_Matched_Aggregate:

   begin

      declare

         ND : C432002_0.New_Discriminant_Extension (N => 8) :=

            (C432002_0.Discriminant'(L  => 8,

                                     S1 => String_8)

               with N  => 8,

                    S2 => String_8);

      begin

         C432002_0.Do_Something(ND); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension " &

                        "with new discriminant: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end ND_Matched_Aggregate;

   ND_Matched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 3) :=

            C432002_0.Discriminant'(L  => 3,

                                    S1 => String_3);

         ND : C432002_0.New_Discriminant_Extension (N => 3) :=

            (D with N  => 3,

                    S2 => String_3);

      begin

         C432002_0.Do_Something(ND); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is an variable");

         Report.Failed ("Aggregate of extension " &

                        "with new discriminant: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end ND_Matched_Variable;

   -- Unsuccessful cases - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   ND_Unmatched_Aggregate:

   begin

      declare

         ND : C432002_0.New_Discriminant_Extension (N => 20) :=

            (C432002_0.Discriminant'(L  => 11,

                                     S1 => String_11)

               with N  => 20,

                    S2 => String_20);

      begin

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension " &

                        "with new discriminant: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(ND); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end ND_Unmatched_Aggregate;

   ND_Unmatched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 5) :=

            C432002_0.Discriminant'(L  => 5,

                                    S1 => String_5);

         ND : C432002_0.New_Discriminant_Extension (N => 20) :=

            (D with N  => 20,

                    S2 => String_20);

      begin

         Report.Comment ("Ancestor expression is an variable");

         Report.Failed ("Aggregate of extension " &

                        "with new discriminant: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(ND); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end ND_Unmatched_Variable;

   --------------------------------------------------------------------

   -- Extension constrains parent's discriminant to value of expression

   -- Parent is a discriminant extension

   --------------------------------------------------------------------

   -- Successful cases - value matches corresponding discriminant value

   CE_Matched_Aggregate:

   begin

      declare

         CE : C432002_0.Constrained_Extension_Extension :=

            (C432002_0.Discriminant'(L  => 20,

                                     S1 => String_20)

               with N => 20,

                    S2 => String_20,

                    S3 => String_5);

      begin

         C432002_0.Do_Something(CE); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with discriminant constrained: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end CE_Matched_Aggregate;

   CE_Matched_Variable:

   begin

      declare

         ND : C432002_0.New_Discriminant_Extension (N => 20) :=

            C432002_0.New_Discriminant_Extension'

               (N  => 20,

                S1 => String_20,

                S2 => String_20);

         CE : C432002_0.Constrained_Extension_Extension :=

            (ND with S3 => String_5);

      begin

         C432002_0.Do_Something(CE); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is a variable");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with discriminant constrained: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end CE_Matched_Variable;

   -- Unsuccessful cases - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   CE_Unmatched_Aggregate:

   begin

      declare

         CE : C432002_0.Constrained_Extension_Extension :=

            (C432002_0.New_Discriminant_Extension'

               (N  => 11,

                S1 => String_11,

                S2 => String_11)

            with S3 => String_5);

      begin

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "Constraint_Error was not raised " &

                        "with discriminant constrained: " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(CE); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise of Constraint_Error is expected

   end CE_Unmatched_Aggregate;

   CE_Unmatched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 8) :=

            C432002_0.Discriminant'(L  => 8,

                                    S1 => String_8);

         CE : C432002_0.Constrained_Extension_Extension :=

            (D with N  => 8,

                    S2 => String_8,

                    S3 => String_5);

      begin

         Report.Comment ("Ancestor expression is a variable");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with discriminant constrained: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(CE); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise of Constraint_Error is expected

   end CE_Unmatched_Variable;

   -----------------------------------------------------------------------

   -- Extension constrains parent's discriminant to equal new discriminant

   -- Parent is a discriminant extension

   -----------------------------------------------------------------------

   -- Successful cases - value matches corresponding discriminant value

   NE_Matched_Aggregate:

   begin

      declare

         NE : C432002_0.New_Extension_Extension (I => 8) :=

            (C432002_0.Discriminant'(L  => 8,

                                     S1 => String_8)

               with I  => 8,

                    S2 => String_8,

                    S3 => String_8);

      begin

         C432002_0.Do_Something(NE); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is an aggregate");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with new discriminant: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end NE_Matched_Aggregate;

   NE_Matched_Variable:

   begin

      declare

         ND : C432002_0.New_Discriminant_Extension (N => 3) :=

            C432002_0.New_Discriminant_Extension'

               (N  => 3,

                S1 => String_3,

                S2 => String_3);

         NE : C432002_0.New_Extension_Extension (I => 3) :=

            (ND with I  => 3,

                     S3 => String_3);

      begin

         C432002_0.Do_Something(NE); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Comment ("Ancestor expression is a variable");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with new discriminant: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end NE_Matched_Variable;

   -- Unsuccessful cases - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   NE_Unmatched_Aggregate:

   begin

      declare

         NE : C432002_0.New_Extension_Extension (I => 8) :=

            (C432002_0.New_Discriminant_Extension'

               (C432002_0.Discriminant'(L  => 11,

                                        S1 => String_11)

                with N  => 11,

                     S2 => String_11)

            with I  => 8,

                 S3 => String_8);

      begin

         Report.Comment ("Ancestor expression is an extension aggregate");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with new discriminant: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(NE); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end NE_Unmatched_Aggregate;

   NE_Unmatched_Variable:

   begin

      declare

         D : C432002_0.Discriminant(L => 5) :=

            C432002_0.Discriminant'(L  => 5,

                                    S1 => String_5);

         NE : C432002_0.New_Extension_Extension (I => 20) :=

            (D with I  => 5,

                    S2 => String_5,

                    S3 => String_20);

      begin

         Report.Comment ("Ancestor expression is a variable");

         Report.Failed ("Aggregate of extension (of extension) " &

                        "with new discriminant: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(NE); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end NE_Unmatched_Variable;

   -----------------------------------------------------------------------

   -- Corresponding discriminant is two levels deeper than aggregate

   -----------------------------------------------------------------------

   -- Successful case - value matches corresponding discriminant value

   TR_Matched_Variable:

   begin

      declare

         D : C432002_0.Discriminant (L => 10) :=

            C432002_0.Discriminant'(L  => 10,

                                    S1 => String_10);

         TR : C432002_0.Twice_Removed :=

            C432002_0.Twice_Removed'(D with S2 => String_20,

                                            S3 => String_3,

                                            S4 => String_8);

         -- N is constrained to a value in the derived_type_definition

         -- of Constrained_Discriminant_Extension. Its omission from

         -- the above record_component_association_list is allowed by

         -- 4.3.2(6).

      begin

         C432002_0.Do_Something(TR); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Failed ("Aggregate of far-removed extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end TR_Matched_Variable;

   -- Unsuccessful case - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   TR_Unmatched_Variable:

   begin

      declare

         D : C432002_0.Discriminant (L => 5) :=

            C432002_0.Discriminant'(L  => 5,

                                    S1 => String_5);

         TR : C432002_0.Twice_Removed :=

            C432002_0.Twice_Removed'(D with S2 => String_20,

                                            S3 => String_3,

                                            S4 => String_8);

      begin

         Report.Failed ("Aggregate of far-removed extension " &

                        "with discriminant constrained: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(TR); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end TR_Unmatched_Variable;

   ------------------------------------------------------------------------

   -- Parent has multiple discriminants.

   -- Discriminant in extension corresponds to both parental discriminants.

   ------------------------------------------------------------------------

   -- Successful case - value matches corresponding discriminant value

   MD_Matched_Variable:

   begin

      declare

         MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) :=

            C432002_0.Multiple_Discriminants'(A  => 10,

                                              B  => 10,

                                              S1 => String_10,

                                              S2 => String_10);

         MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=

            (MD with C  => 10,

                     S3 => String_10);

      begin

         C432002_0.Do_Something(MDE); -- success

      end;

   exception

      when Constraint_Error =>

         Report.Failed ("Aggregate of extension " &

                        "of multiply-discriminated parent: " &

                        "Constraint_Error was incorrectly raised " &

                        "for value that matches corresponding " &

                        "discriminant");

   end MD_Matched_Variable;

   -- Unsuccessful case - value does not match value of corresponding

   --                      discriminant. Constraint_Error should be

   --                      raised.

   MD_Unmatched_Variable:

   begin

      declare

         MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) :=

            C432002_0.Multiple_Discriminants'(A  => 10,

                                              B  => 8,

                                              S1 => String_10,

                                              S2 => String_8);

         MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=

            (MD with C  => 10,

                     S3 => String_10);

      begin

         Report.Failed ("Aggregate of extension " &

                        "of multiply-discriminated parent: " &

                        "Constraint_Error was not raised " &

                        "for discriminant value that does not match " &

                        "corresponding discriminant");

         C432002_0.Do_Something(MDE); -- disallow unused var optimization

      end;

   exception

      when Constraint_Error =>

         null; -- raise is expected

   end MD_Unmatched_Variable;

   Report.Result;

end C432002;