-- C393A06.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 a type that inherits abstract operations but -- overrides each of these operations is not required to be -- abstract, and that objects of the type and its class-wide type -- may be declared and passed in calls to the overriding -- subprograms. -- -- TEST DESCRIPTION: -- This test derives a type from the root abstract type available -- in foundation F393A00. It declares subprograms as required by -- the language to override the abstract subprograms, allowing the -- derived type itself to be not abstract. It also declares -- operations on the new type, as well as on the associated class- -- wide type. The main program then uses two objects of the type -- and two objects of the class-wide type as parameters for each of -- the subprograms. Correct execution is determined by path -- analysis and value checking. -- -- TEST FILES: -- The following files comprise this test: -- -- F393A00.A (foundation code) -- C393A06.A -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 19 Dec 94 SAIC Removed RM references from objective text. -- --! with F393A00_1; package C393A06_0 is type Organism is new F393A00_1.Object with private; type Kingdoms is ( Animal, Vegetable, Unspecified ); procedure Swap( A,B: in out Organism ); function Create return Organism; procedure Initialize( The_Entity : in out Organism; In_The_Kingdom : Kingdoms ); function Kingdom( Of_The_Entity : Organism ) return Kingdoms; procedure TC_Check( An_Entity : Organism'Class; In_Kingdom : Kingdoms; Initialized : Boolean ); Incompatible : exception; private type Organism is new F393A00_1.Object with record In_Kingdom : Kingdoms; end record; end C393A06_0; with F393A00_0; package body C393A06_0 is procedure Swap( A,B: in out Organism ) is begin F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A if A.In_Kingdom /= B.In_Kingdom then F393A00_0.TC_Touch( 'X' ); raise Incompatible; else declare T: constant Organism := A; begin A := B; B := T; end; end if; end Swap; function Create return Organism is Widget : Organism; begin F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B Initialize( Widget ); Widget.In_Kingdom := Unspecified; return Widget; end Create; procedure Initialize( The_Entity : in out Organism; In_The_Kingdom : Kingdoms ) is begin F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C F393A00_1.Initialize( F393A00_1.Object( The_Entity ) ); The_Entity.In_Kingdom := In_The_Kingdom; end Initialize; function Kingdom( Of_The_Entity : Organism ) return Kingdoms is begin F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D return Of_The_Entity.In_Kingdom; end Kingdom; procedure TC_Check( An_Entity : Organism'Class; In_Kingdom : Kingdoms; Initialized : Boolean ) is begin if F393A00_1.Initialized( An_Entity ) /= Initialized then F393A00_0.TC_Touch( '-' ); ------------------------------------------- - elsif An_Entity.In_Kingdom /= In_Kingdom then F393A00_0.TC_Touch( '!' ); ------------------------------------------- ! else F393A00_0.TC_Touch( '+' ); ------------------------------------------- + end if; end TC_Check; end C393A06_0; with Report; with C393A06_0; with F393A00_0; with F393A00_1; procedure C393A06 is package Darwin renames C393A06_0; package Tagger renames F393A00_0; package Objects renames F393A00_1; Lion : Darwin.Organism; Tigerlily : Darwin.Organism; Bear : Darwin.Organism'Class := Darwin.Create; Sunflower : Darwin.Organism'Class := Darwin.Create; use type Darwin.Kingdoms; begin -- Main test procedure. Report.Test ("C393A06", "Check that a type that inherits abstract " & "operations but overrides each of these " & "operations is not required to be abstract. " & "Check that objects of the type and its " & "class-wide type may be declared and passed " & "in calls to the overriding subprograms" ); Tagger.TC_Validate( "BaBa", "Declaration Initializations" ); Darwin.Initialize( Lion, Darwin.Animal ); Darwin.Initialize( Tigerlily, Darwin.Vegetable ); Darwin.Initialize( Bear, Darwin.Animal ); Darwin.Initialize( Sunflower, Darwin.Vegetable ); Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" ); Oh_My: begin Darwin.Swap( Lion, Darwin.Organism( Bear ) ); Darwin.Swap( Lion, Tigerlily ); Report.Failed("Exception not raised"); exception when Darwin.Incompatible => null; end Oh_My; Tagger.TC_Validate( "AAX", "Swap sequence" ); if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) ); end if; Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" ); Darwin.TC_Check( Lion, Darwin.Animal, True ); Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True ); Darwin.TC_Check( Bear, Darwin.Animal, True ); Darwin.TC_Check( Sunflower, Darwin.Vegetable, True ); Tagger.TC_Validate( "b+b+b+b+", "Final sequence" ); Report.Result; end C393A06;