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