diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c393a06.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c393a06.a | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a06.a b/gcc/testsuite/ada/acats/tests/c3/c393a06.a new file mode 100644 index 000000000..c257d5fa0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393a06.a @@ -0,0 +1,201 @@ +-- 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; + |