-- cy100001.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-50217 (limited with clauses). -- Basic tests. -- -- DESCRIPTION: -- Following figure presents an overview of the test structure. -- -- ------------------------------------------------- -- with P, Q; -- procedure CY10001 is -- ... -- end; -- ------------------------------------------------- -- limited with Q; | limited with P; -- package P is | package Q is -- ... | ... -- end P; | end Q; -- ------------------------------------------------- -- with Q; | with P; -- package body P is | package body Q is -- ... | ... -- end P; | end Q; -- ------------------------------------------------- -- -- The specification of packages P and Q contain mutually recursive type -- declarations, built by means of: -- A) Mutually recursive records -- B) Mutually recursive tagged records -- C) Mutually recursive tagged private records -- -- In addition, the test has a suite of initialization subprograms that -- perform the initialization of the access components used to link two -- mutually recursive variables declared with these data types. For each -- data type, following tests are performed: -- -- Case 1: Initialization of mutually recursive variables declared in -- P and Q package specifications. The initialization is carried -- out by a subprogram from the outside. -- -- Case 2: Initialization of mutually recursive variables declared in -- P and Q package specifications. The initialization is carried -- out in the body of package P. -- -- Case 3: Initialization of mutually recursive variables created through -- allocators -- -- CHANGE HISTORY: -- 9 FEB 2004 Initial Version --! with Report; with CY100001P, CY100001Q; use CY100001P, CY100001Q; procedure CY100001 is -- CASE A: Mutually recursive records --------------------------------- procedure Test_Initialize_A1 is -- Case 1: Variables declared in package specifications initialized -- from an external subprogram. begin Report.Comment ("Mutually recursive records (case A1)"); O1_P.Ptr := O1_Q'Access; O1_Q.Ptr := O1_P'Access; if O1_P.Ptr.all.Data /= CY100001Q.Default then Report.Failed ("P_Var: wrong value"); end if; if O1_Q.Ptr.all.Data /= CY100001P.Default then Report.Failed ("Q_Var: wrong value"); end if; end Test_Initialize_A1; -- Test_Initialize_2A can be found in the body of package P. procedure Test_Initialize_A3 is -- Case 3: Mutually recursive variables created through allocators. Ptr_Q : Ptr_TQ; Ptr_P : Ptr_TP; begin Report.Comment ("Mutually recursive records (case A3)"); Ptr_P := new TP; Ptr_Q := new TQ'(Data => 10, Ptr => Ptr_P); Ptr_P.Ptr := Ptr_Q; if Ptr_P.Ptr.all.Data /= 10 then Report.Failed ("Ptr_P: wrong value"); end if; if Ptr_Q.Ptr.all.Data /= CY100001P.Default then Report.Failed ("Ptr_Q: wrong value"); end if; end Test_Initialize_A3; -- CASE B: Mutually recursive tagged records -------------------------- procedure Test_Initialize_B1 is -- Case 1: Variables declared in package specifications initialized -- from an external subprogram. begin Report.Comment ("Mutually recursive records (case B1)"); O2_P.Ptr := O2_Q'Access; O2_Q.Ptr := O2_P'Access; if O2_P.Ptr.all.Data /= CY100001Q.Default then Report.Failed ("P_Var: wrong value"); end if; if O2_Q.Ptr.all.Data /= CY100001P.Default then Report.Failed ("Q_Var: wrong value"); end if; end Test_Initialize_B1; -- Test_Initialize_2A can be found in the body of package P. procedure Test_Initialize_B3 is -- Case 4: Mutually recursive variables created through allocators. Ptr_Q : Ptr_TQC; Ptr_P : Ptr_TPC; begin Report.Comment ("Mutually recursive records (case B3)"); Ptr_P := new TPC; Ptr_Q := new TQC'(Data => 10, Ptr => Ptr_P); Ptr_P.Ptr := Ptr_Q; if Ptr_P.Ptr.all.Data /= 10 then Report.Failed ("Ptr_P: wrong value"); end if; if Ptr_Q.Ptr.all.Data /= CY100001P.Default then Report.Failed ("Ptr_Q: wrong value"); end if; end Test_Initialize_B3; -- CASE C: Mutually recursive tagged private records ------------------ O3_P : aliased TPCP; O3_Q : aliased TQCP; procedure Test_Initialize_C1 is -- Case 1: Variables declared in package specifications initialized -- from an external subprogram. begin Report.Comment ("Mutually recursive records (case C1)"); Set_Ptr (O3_P, O3_Q'Unchecked_Access); Set_Ptr (O3_Q, O3_P'Unchecked_Access); if Ptr_Data (O3_P) /= CY100001Q.Default then Report.Failed ("P_Var: wrong value"); end if; if Ptr_Data (O3_Q) /= CY100001P.Default then Report.Failed ("Q_Var: wrong value"); end if; end Test_Initialize_C1; -- Test_Initialize_2A can be found in the body of package P. procedure Test_Initialize_C3 is -- Case 4: Mutually recursive variables created through allocators. Ptr_Q : Ptr_TQCP; Ptr_P : Ptr_TPCP; begin Report.Comment ("Mutually recursive records (case C3)"); Ptr_P := new TPCP; Ptr_Q := new TQCP; Set_Ptr (Ptr_P.all, Ptr_Q); Set_Ptr (Ptr_Q.all, Ptr_P); if Ptr_Data (Ptr_P.all) /= CY100001Q.Default then Report.Failed ("Ptr_P: wrong value"); end if; if Ptr_Data (Ptr_Q.all) /= CY100001P.Default then Report.Failed ("Ptr_Q: wrong value"); end if; end Test_Initialize_C3; begin Report.Test ("CY100001", "Limited With Clauses (AI-50217): Basic tests"); Test_Initialize_A1; Test_Initialize_A2; Test_Initialize_A3; Report.Comment (""); Test_Initialize_B1; Test_Initialize_B2; Test_Initialize_B3; Report.Comment (""); Test_Initialize_C1; -- Test 2 not required because, being a private type, we can't declare -- the variables in the package specifications. Test_Initialize_C3; Report.Result; end CY100001; -- ---------------------------------------------------------------------------- limited with CY100001Q; package CY100001P is Default : constant Integer := 999; -- CASE A: Mutually recursive records --------------------------------- type Ptr_TQ is access all CY100001Q.TQ; type TP is record Data : Integer := Default; Ptr : Ptr_TQ; end record; O1_P : aliased TP; procedure Test_Initialize_A2; -- Case 2: Variables declared in package specifications (initialized in -- the body of one of the packages where the mutually recursive types -- are declared) -- CASE B: Mutually recursive tagged records --------------------------- type Ptr_TQC is access all CY100001Q.TQC'Class; type TPC is tagged record Data : Integer := Default; Ptr : Ptr_TQC; end record; O2_P : aliased TPC; procedure Test_Initialize_B2; -- Case 2: Variables declared in package specifications (initialized in -- the body of one of the packages where the mutually recursive types -- are declared) -- CASE C: Mutually recursive tagged private records ------------------- type TPCP is tagged private; type Ptr_TQCP is access all CY100001Q.TQCP'Class; procedure Set_Data (X : in out TPCP; Data : Integer); procedure Set_Ptr (X : in out TPCP; Ptr : Ptr_TQCP); function Data (X : TPCP) return Integer; function Ptr (X : TPCP) return Ptr_TQCP; function Ptr_Data (X : TPCP) return Integer; private type TPCP is tagged record Data : Integer := Default; Ptr : Ptr_TQCP; end record; end CY100001P; -- ---------------------------------------------------------------------------- with Report; with CY100001Q; use CY100001Q; package body CY100001P is procedure Test_Initialize_A2 is begin Report.Comment ("Mutually recursive records (case A2)"); O1_P.Ptr := O1_Q'Access; O1_Q.Ptr := O1_P'Access; end Test_Initialize_A2; procedure Test_Initialize_B2 is begin Report.Comment ("Mutually recursive records (case B2)"); O2_P.Ptr := O2_Q'Access; O2_Q.Ptr := O2_P'Access; end Test_Initialize_B2; -- Subprograms of the tagged private type procedure Set_Data (X : in out TPCP; Data : Integer) is begin X.Data := Data; end Set_Data; procedure Set_Ptr (X : in out TPCP; Ptr : Ptr_TQCP) is begin X.Ptr := Ptr; end Set_Ptr; function Data (X : TPCP) return Integer is begin return X.Data; end Data; function Ptr (X : TPCP) return Ptr_TQCP is begin return X.Ptr; end Ptr; function Ptr_Data (X : TPCP) return Integer is begin return CY100001Q.Data (X.Ptr.all); end Ptr_Data; end CY100001P; -- ---------------------------------------------------------------------------- limited with CY100001P; package CY100001Q is Default : constant Integer := 998; -- --------------------------------------------- type Ptr_TP is access all CY100001P.TP; type TQ is record Data : Integer := Default; Ptr : Ptr_TP; end record; O1_Q : aliased TQ; -- --------------------------------------------- type Ptr_TPC is access all CY100001P.TPC'Class; type TQC is tagged record Data : Integer := Default; Ptr : Ptr_TPC; end record; O2_Q : aliased TQC; -- ---------------------------------------------- type TQCP is tagged private; type Ptr_TPCP is access all CY100001P.TPCP'Class; procedure Set_Data (X : in out TQCP; Data : Integer); procedure Set_Ptr (X : in out TQCP; Ptr : Ptr_TPCP); function Data (X : TQCP) return Integer; function Ptr (X : TQCP) return Ptr_TPCP; function Ptr_Data (X : TQCP) return Integer; private type TQCP is tagged record Data : Integer := Default; Ptr : Ptr_TPCP; end record; end CY100001Q; -- ---------------------------------------------------------------------------- with CY100001P; package body CY100001Q is -- Subprograms of the tagged private type procedure Set_Data (X : in out TQCP; Data : Integer) is begin X.Data := Data; end Set_Data; procedure Set_Ptr (X : in out TQCP; Ptr : Ptr_TPCP) is begin X.Ptr := Ptr; end Set_Ptr; function Data (X : TQCP) return Integer is begin return X.Data; end Data; function Ptr (X : TQCP) return Ptr_TPCP is begin return X.Ptr; end Ptr; function Ptr_Data (X : TQCP) return Integer is begin return CY100001P.Data (X.Ptr.all); end Ptr_Data; end CY100001Q;