-- cy30002.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) -- Check renaming declarations plus the new predefined equality operator -- for access types. It is based in the example described in AI-00230.TXT -- -- CHANGE HISTORY: -- 6 FEB 2004 Initial Version --! with Report; with Ada.Tags; procedure CY30002 is package Types is type T is tagged null record; type Rec (D : access String -- test := new String'("")) is record F : access T; -- test G : access T'Class := new T; -- test end record; type Rec_Ptr is access all Rec; type Rec_Ptr2 is access all Rec; Ptr : Rec_Ptr := null; function F (X : access Rec; Y : access Rec) return String; end Types; package body Types is function F (X : access Rec; Y : access Rec) return String is function G (X : access Rec; Y : access Rec) return String is Test_Eq1 : Boolean := X = Y; -- Test "=" Test_Eq2 : Boolean := F.X = X; -- Test "=" begin return ""; end G; Disc : access String renames X.D; -- Renaming test Test_Eq1 : Boolean := X = Ptr; -- Equality Operator test Test_Eq2 : Boolean := Ptr = X; -- Equality Operator test Test_Eq3 : Boolean := X = X; -- Equality Operator test Test_Eq4 : Boolean := X /= Ptr; -- Equality Operator test Test_Eq5 : Boolean := Ptr /= X; -- Equality Operator test Test_Eq6 : Boolean := X /= X; -- Equality Operator test Local_P2 : Rec_Ptr := Rec_Ptr (X); Test_Eq7 : Boolean := X = Y; -- Test "=" begin if Test_Eq1 then Report.Failed ("equality test (1)"); end if; if Test_Eq2 then Report.Failed ("equality test (2)"); end if; if not Test_Eq3 then Report.Failed ("equality test (3)"); end if; if not Test_Eq4 then Report.Failed ("equality test (4)"); end if; if not Test_Eq5 then Report.Failed ("equality test (5)"); end if; if Test_Eq6 then Report.Failed ("equality test (6)"); end if; return Disc.all; end F; end Types; use Types; R1 : aliased Rec; R2 : Rec := (D => new String'("Hello"), F => new T, G => new T); Y : access String renames R2.D; -- test begin Report.Test ("CY30002", "Anonymous access types: Test renaming" & " declarations plus the new predefined equality" & " operator for access types"); if R1.D.all /= "" then Report.Failed ("wrong default value in discriminant"); end if; if R2.D.all /= "Hello" then Report.Failed ("wrong value in discriminant"); end if; if Y.all /= "Hello" then Report.Failed ("wrong value in renamed access"); end if; if F (R1'Access, R1'Access) /= "" then Report.Failed ("wrong default value in discriminant"); end if; begin if F (Ptr, Ptr) /= "" then -- test null; end if; Report.Failed ("access parameter is null"); exception when Constraint_Error => null; -- OK end; -- Overload resolution test 1 declare type Ptr_1 is access all Integer; type Ptr_2 is access all Integer; My_Var : aliased Integer := 4; function F (V : Integer) return Ptr_1 is begin return null; end F; function F return Ptr_2 is begin return My_Var'Access; end F; procedure P (X : access Integer) is begin if F /= X then Report.Failed ("wrong overload resolution"); end if; end P; begin P (My_Var'Access); end; -- Overload resolution test 2 declare type Ptr_1 is access Integer; type Ptr_2 is access Float; O_1 : Ptr_1 := new Integer; O_2 : Ptr_2 := new Float; function F return Ptr_1 is begin return O_1; end F; function F return Ptr_2 is begin return O_2; end F; procedure P (X : access Integer) is begin if F /= X then -- test, should not be ambiguous. Report.Failed ("wrong value"); end if; end P; begin P (O_1); end; Report.Result; end CY30002;