diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432004.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432004.a | 319 |
1 files changed, 319 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432004.a new file mode 100644 index 000000000..3a1486211 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c432004.a @@ -0,0 +1,319 @@ +-- C432004.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 the type of an extension aggregate may be derived from the +-- type of the ancestor part through multiple record extensions. Check +-- for ancestor parts that are subtype marks. Check that the type of the +-- ancestor part may be abstract. +-- +-- TEST DESCRIPTION: +-- This test defines the following type hierarchies: +-- +-- (A) (F) +-- Abstract Abstract +-- Tagged record Tagged private +-- / \ / \ +-- / (C) (G) \ +-- (B) Abstract Abstract (H) +-- Record private record Private +-- extension extension extension extension +-- | | | | +-- (D) (E) (I) (J) +-- Record Record Record Record +-- extension extension extension extension +-- +-- Extension aggregates for B, D, E, I, and J are constructed using each +-- of its ancestor types as the ancestor part (except for E and J, for +-- which only the immediate ancestor is used, since using A and F, +-- respectively, as the ancestor part would be illegal). +-- +-- X1 : B := (A with ...); +-- X2 : D := (A with ...); X5 : I := (F with ...); +-- X3 : D := (B with ...); X6 : I := (G with ...); +-- X4 : E := (C with ...); X7 : J := (H with ...); +-- +-- For each assignment of an aggregate, the value of the target object is +-- checked to ensure that the proper values for each component were +-- assigned. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C432004_0 is + + type Drawers is record + Building : natural; + end record; + + type Location is access Drawers; + + type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); + + type SampleType_A is abstract tagged record + Era : Eras := Cenozoic; + Loc : Location; + end record; + + type SampleType_F is abstract tagged private; + + -- The following function is needed to verify the values of the + -- private components. + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean; + +private + type SampleType_F is abstract tagged record + Era : Eras := Mesozoic; + end record; + +end C432004_0; + + --==================================================================-- + +package body C432004_0 is + + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean is + begin + return (Rec.Era = E); + end TC_Correct_Result; + +end C432004_0; + + --==================================================================-- + +with C432004_0; +package C432004_1 is + + type Periods is + (Aphebian, Helikian, Hadrynian, + Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, + Triassic, Jurassic, Cretaceous, + Tertiary, Quaternary); + + type SampleType_B is new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_C is abstract new C432004_0.SampleType_A with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean; + + type SampleType_G is abstract new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + Loc : C432004_0.Location; + end record; + + type SampleType_H is new C432004_0.SampleType_F with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean; + +private + type SampleType_C is abstract new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_H is new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + end record; + +end C432004_1; + + --==================================================================-- + +package body C432004_1 is + + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean is + begin + return (Rec.Period = P); + end TC_Correct_Result; + + ------------------------------------------------------------- + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean is + begin + return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E); + end TC_Correct_Result; + +end C432004_1; + + --==================================================================-- + +with C432004_0; +with C432004_1; +package C432004_2 is + + -- All types herein are record extensions, since aggregates + -- cannot be given for private extensions + + type SampleType_D is new C432004_1.SampleType_B with record + Sample_On_Loan : Boolean := False; + end record; + + type SampleType_E is new C432004_1.SampleType_C + with null record; + + type SampleType_I is new C432004_1.SampleType_G with record + Sample_On_Loan : Boolean := True; + end record; + + type SampleType_J is new C432004_1.SampleType_H with record + Sample_On_Loan : Boolean := True; + end record; + +end C432004_2; + + + --==================================================================-- + +with Report; +with C432004_0; +with C432004_1; +with C432004_2; +use C432004_1; +use C432004_2; + +procedure C432004 is + + -- Variety of extension aggregates. + + -- Default values for the components of SampleType_A + -- (Era => Cenozoic, Loc => null). + Sample_B : SampleType_B + := (C432004_0.SampleType_A with Period => Devonian); + + -- Default values from SampleType_A (Era => Cenozoic, Loc => null). + Sample_D1 : SampleType_D + := (C432004_0.SampleType_A with Period => Cambrian, + Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_B + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_D2 : SampleType_D + := (SampleType_B with Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_C + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_E : SampleType_E + := (SampleType_C with null record); + + -- Default value from SampleType_F (Era => Mesozoic). + Sample_I1 : SampleType_I + := (C432004_0.SampleType_F with Period => Tertiary, + Loc => new C432004_0.Drawers'(Building => 9), + Sample_On_Loan => False); + + -- Default values from SampleType_F and SampleType_G + -- (Era => Mesozoic, Period => Jurassic, Loc => null). + Sample_I2 : SampleType_I + := (SampleType_G with Sample_On_Loan => False); + + -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic). + Sample_J : SampleType_J + := (SampleType_H with Sample_On_Loan => False); + + use type C432004_0.Eras; + use type C432004_0.Location; + +begin + + Report.Test ("C432004", "Check that the type of an extension aggregate " & + "may be derived from the type of the ancestor part through " & + "multiple record extensions"); + + if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then + Report.Failed ("Object of record extension of abstract ancestor, " & + "SampleType_B, failed content check"); + end if; + + ------------------- + if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null, + Period => Cambrian, Sample_On_Loan => True) then + Report.Failed ("Object 1 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + + ------------------- + if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then + Report.Failed ("Object 2 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + ------------------- + if Sample_E.Era /= C432004_0.Cenozoic or + Sample_E.Loc /= null or + not TC_Correct_Result (Sample_E, Quaternary) then + Report.Failed ("Object of record extension of abstract private " & + "extension of abstract ancestor, SampleType_E, " & + "failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or + Sample_I1.Period /= Tertiary or + Sample_I1.Loc.Building /= 9 or + Sample_I1.Sample_On_Loan /= False then + Report.Failed ("Object 1 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or + Sample_I2.Period /= Jurassic or + Sample_I2.Loc /= null or + Sample_I2.Sample_On_Loan /= False then + Report.Failed ("Object 2 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not TC_Correct_Result (Sample_J, + Jurassic, + C432004_0.Mesozoic) or + Sample_J.Sample_On_Loan /= False then + Report.Failed ("Object of record extension of private extension " & + "of abstract private ancestor, SampleType_J, " & + "failed content check"); + end if; + + Report.Result; + +end C432004; |