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