Subversion Repositories openrisc_me

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