From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/ca/ca11020.a | 238 +++++++++++++++++++++++++++++ 1 file changed, 238 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11020.a (limited to 'gcc/testsuite/ada/acats/tests/ca/ca11020.a') diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11020.a b/gcc/testsuite/ada/acats/tests/ca/ca11020.a new file mode 100644 index 000000000..4949ce9fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11020.a @@ -0,0 +1,238 @@ +-- CA11020.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 body of the generic parent package can depend on one of +-- its own public generic children. +-- +-- TEST DESCRIPTION: +-- A scenario is created that demonstrates the potential of adding a +-- public generic child during code maintenance without distubing a large +-- subsystem. After child is added to the subsystem, a maintainer +-- decides to take advantage of the new functionality and rewrites +-- the parent's body. +-- +-- Declare a bag abstraction in a generic package. Declare a public +-- generic child of this package which adds a generic procedure to the +-- original subsystem. In the parent body, instantiate the public +-- child. Then instantiate the procedure as a child instance of the +-- public child instance. +-- +-- In the main program, declare an instance of parent. Check that the +-- operations in both parent and child packages perform as expected. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Simulates bag application. + +generic + type Element is private; + with function Image (E : Element) return String; + +package CA11020_0 is + + type Bag is limited private; + + procedure Add (E : in Element; To_The_Bag : in out Bag); + + function Bag_Image (B : Bag) return string; + +private + type Node_Type; + type Bag is access Node_Type; + + type Node_Type is + record + The_Element : Element; + + -- Other components in real application, i.e., + -- The_Count : positive; + + Next : Bag; + end record; + +end CA11020_0; + + --==================================================================-- + +-- More operations on Bag. + +generic + +-- Parameters go here. + +package CA11020_0.CA11020_1 is + + -- ... Other declarations. + + generic -- Generic iterator procedure. + with procedure Use_Element (E : in Element); + + procedure Iterate (B : in Bag); -- Called once per element in the bag. + + -- ... Various other operations. + +end CA11020_0.CA11020_1; + + --==================================================================-- + +package body CA11020_0.CA11020_1 is + + procedure Iterate (B : in Bag) is + + -- Traverse each element in the bag. + + Elem : Bag := B; + + begin + while Elem /= null loop + Use_Element (Elem.The_Element); + Elem := Elem.Next; + end loop; + + end Iterate; + +end CA11020_0.CA11020_1; + + --==================================================================-- + +with CA11020_0.CA11020_1; -- Public generic child package. + +package body CA11020_0 is + + ---------------------------------------------------- + -- Parent's body depends on public generic child. -- + ---------------------------------------------------- + + -- Instantiate the public child. + + package MS is new CA11020_1; + + function Bag_Image (B : Bag) return string is + + Buffer : String (1 .. 10_000); + Last : Integer := 0; + + ----------------------------------------------------- + + -- Will be called by the iterator. + + procedure Append_Image (E : in Element) is + Im : constant String := Image (E); + + begin -- Append_Image + if Last /= 0 then -- Insert a comma. + Last := Last + 1; + Buffer (Last) := ','; + end if; + + Buffer (Last + 1 .. Last + Im'Length) := Im; + Last := Last + Im'Length; + + end Append_Image; + + ----------------------------------------------------- + + -- Instantiate procedure Iterate as a child of instance MS. + + procedure Append_All is new MS.Iterate (Use_Element => Append_Image); + + begin -- Bag_Image + + Append_All (B); + + return Buffer (1 .. Last); + + end Bag_Image; + + ----------------------------------------------------- + + procedure Add (E : in Element; To_The_Bag : in out Bag) is + + -- Not a real bag addition. + + Index : Bag := To_The_Bag; + + begin + -- ... Error-checking code omitted for brevity. + + if Index = null then + To_The_Bag := new Node_Type' (The_Element => E, + Next => null); + else + -- Goto the end of the list. + + while Index.Next /= null loop + Index := Index.Next; + end loop; + + -- Add element to the end of the list. + + Index.Next := new Node_Type' (The_Element => E, + Next => null); + end if; + + end Add; + +end CA11020_0; + + --==================================================================-- + +with CA11020_0; -- Bag application. + +with Report; + +procedure CA11020 is + + -- Instantiate the bag application for integer type and attribute + -- Image. + + package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image); + + My_Bag : Bag_Of_Integers.Bag; + +begin + + Report.Test ("CA11020", "Check that body of the generic parent package " & + "can depend on one of its own public generic children"); + + -- Add 10 consecutive integers to the bag. + + for I in 1 .. 10 loop + Bag_Of_Integers.Add (I, My_Bag); + end loop; + + if Bag_Of_Integers.Bag_Image (My_Bag) + /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then + Report.Failed ("Incorrect results"); + end if; + + Report.Result; + +end CA11020; -- cgit v1.2.3