-- cy40007.ada -- -- Grant of Unlimited Rights -- -- Ada Core Technologies Inc. (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: -- Ada Core Technologies, Inc. -- -- AUTHOR: -- Javier Miranda -- -- OBJECTIVE: -- Check AI-287 (Limited Aggregates). -- Check allocators. This test is based on the example described in -- the following paper: -- -- Pascal Leroy. "An Invitation to Ada 2005" -- Proceedings of the 8th Ada-Europe International Conference on -- Reliable Software Technologies. Pages 1-23. LLNCS 2265. -- Springer-Verlag, 2003 -- -- The body of this package D uses allocators with limited aggregates. -- -- CHANGE HISTORY: -- 2 FEB 2004 JM Initial Version -- 13 JAN 2005 RLB Reordered units --! package CY40007D is type Object is limited private; type Ptr is access Object; function New_Object (Option : Natural := 1) return Ptr; -- Depending on the formal, this function returns an object initialized -- with different aggregate values: -- Option 1: returns an object with default values for all components -- Option 2: return an object with the *size* component initialized to -- an arbitrary value -- For any other value it just returns a null access. procedure Do_Check (O : Ptr; Text : String); -- This subprogram checks that the object is available (and thus it was -- well initialized). The text is used as a prefix of the error message -- if the object has a wrong value. private protected type Signature is entry Value (V : out Integer); end Signature; type Tree_Node; type Access_Tree_Node is access Tree_Node; type Tree_Node is record Left, Right : Access_Tree_Node := null; Info : Integer; end record; type Object is limited record Magic : Signature; -- Limited type Size : Natural := 0; Root : Access_Tree_Node := null; end record; end CY40007D; -- ---------------------------------------------------------------------------- with Report; package body CY40007D is protected body Signature is entry Value (V : out Integer) when True is begin V := 9999; end Value; end Signature; function New_Object (Option : Natural := 1) return Ptr is begin if Option = 1 then return new Object'(others => <>); -- test elsif Option = 2 then return new Object'(Magic => <>, -- test Size => 9999, Root => null); else return null; end if; end New_Object; procedure Do_Check (O : Ptr; Text : String) is V : Integer; begin O.Magic.Value (V); -- Check the proper initialization of Sem if V /= 9999 then Report.Failed (Text & ": wrong value"); end if; end Do_Check; end CY40007D; -- ---------------------------------------------------------------------------- with Report; with CY40007D; use CY40007D; procedure CY40007 is O_1 : Ptr := New_Object; O_2 : Ptr := New_Object (Option => 2); begin Report.Test ("CY40007", "Limited Aggregates (AI-287): Check allocators"); Do_Check (O_1, "O_1"); Do_Check (O_2, "O_2"); Report.Result; end CY40007;