-- cy30001.a -- -- Grant of Unlimited Rights -- -- AdaCore holds unlimited rights in the software and documentation -- contained herein. Unlimited rights are the same as those granted -- by the U.S. Government for older parts of the Ada Conformity -- Assessment Test Suite, and are defined in DFAR 252.227-7013(a)(19). -- By making this public release, AdaCore intends to confer upon all -- recipients unlimited rights equal to those held by the Ada Conformity -- Assessment Authority. 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. ADACORE 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. -- -------------------------------------------------------------------------- --* -- COPYRIGHT: -- AdaCore -- -- AUTHOR: -- Javier Miranda -- -- OBJECTIVE: -- Check AI-230 (Generalized use of anonymous access types) -- -- CHANGE HISTORY: -- 6 FEB 2004 Initial Version --! with Report; with Ada.Tags; procedure CY30001 is package Types is type Animal is tagged null record; function Id (A : Animal) return String; type Horse is new Animal with null record; function Id (A : Horse) return String; type Acc_Horse is access all Horse'Class; type Pig is new Animal with null record; function Id (A : Pig) return String; type Acc_Pig is access all Pig; end Types; package body Types is function Id (A : Animal) return String is begin return "Animal"; end Id; function Id (A : Horse) return String is begin return "Horse"; end Id; function Id (A : Pig) return String is begin return "Pig"; end Id; end Types; use Types; Boxer : Acc_Horse := new Horse; Napoleon : Acc_Pig := new Pig; begin Report.Test ("CY30001", "Anonymous access types (AI-230): Basic tests"); -- ------------------------------------------------------------------- Report.Comment ("Test 1: Array aggregates"); declare Animal_Farm_1 : constant array (1 .. 2) of access Animal'Class := (Boxer, -- Horse Napoleon); -- Pig Animal_Farm_2 : array (1 .. 2) of access Animal'Class; begin Animal_Farm_2 := (Boxer, Napoleon); if Id (Animal_Farm_1 (1).all) /= "Horse" or else Id (Animal_Farm_1 (2).all) /= "Pig" then Report.Failed ("at (1) wrong type"); end if; if Id (Animal_Farm_2 (1).all) /= "Horse" or else Id (Animal_Farm_2 (2).all) /= "Pig" then Report.Failed ("at (2) wrong type"); end if; end; -- ------------------------------------------------------------------- Report.Comment ("Test 2: Record component"); declare type My_Record is record X : access Animal'Class := Boxer; end record; Rec_1 : My_Record; Rec_2 : My_Record := (X => Napoleon); begin if Id (Rec_1.X.all) /= "Horse" then Report.Failed ("default init (wrong type)"); end if; if Id (Rec_2.X.all) /= "Pig" then Report.Failed ("wrong type"); end if; end; -- ------------------------------------------------------------------- Report.Comment ("Test 3: Record discriminant"); declare type My_Record (D : access Animal'Class := Boxer) is record X : access Animal'Class := D; end record; Rec_1 : My_Record; Rec_2 : My_Record := (D => Napoleon, X => Napoleon); begin if Id (Rec_1.D.all) /= "Horse" then Report.Failed ("discriminant (wrong default value)"); end if; if Id (Rec_1.X.all) /= "Horse" then Report.Failed ("component (wrong default value)"); end if; if Id (Rec_2.D.all) /= "Pig" then Report.Failed ("discriminant (wrong value)"); end if; if Id (Rec_2.X.all) /= "Pig" then Report.Failed ("component (wrong value)"); end if; end; -- ------------------------------------------------------------------- Report.Comment ("Test 4: Renamings"); declare Animal_Farm : constant array (Positive range <>) of access Animal'Class := (Boxer, -- Horse Napoleon); -- Pig O1 : access Animal'Class renames Animal_Farm (1); -- test type My_Record is record X : access Horse := Boxer; Y : access Animal'Class := Napoleon; end record; Rec : My_Record; O2 : access Horse renames Rec.X; -- test O3 : access Animal'Class renames Rec.Y; -- test begin if Id (O1.all) /= "Horse" then Report.Failed ("at O1: wrong type"); end if; if Id (O2.all) /= "Horse" then Report.Failed ("at O2: wrong type"); end if; if Id (O3.all) /= "Pig" then Report.Failed ("at O3: wrong type"); end if; end; Report.Result; end CY30001;