llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c9/c940015.a

-- C940015.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.
--*
--
-- TEST OBJECTIVE:
--      Check that the component_declarations of a protected_operation
--      are elaborated in the proper order.
--
-- TEST DESCRIPTION:
--      A discriminated protected object is declared with some
--      components that depend upon the discriminant and some that
--      do not depend upon the discriminant.  All the components
--      are initialized with a function call.  As a side-effect of
--      the function call the parameter passed to the function is
--      recorded in an elaboration order array.  
--      Two objects of the protected type are declared.  The 
--      elaboration order is recorded and checked against the
--      expected order.
--
--
-- CHANGE HISTORY:
--      09 Jan 96   SAIC    Initial Version for 2.1
--      09 Jul 96   SAIC    Addressed reviewer comments.
--      13 Feb 97   PWB.CTA Removed doomed attempt to check per-object
--                          constraint elaborations.
--!


with Report;

procedure C940015 is
    Verbose : constant Boolean := False;
    Do_Display : Boolean := Verbose;
     
    type Index is range 0..10;

    type List is array (1..10) of Integer;
    Last : Natural range 0 .. List'Last := 0;
    E_List : List := (others => 0);

    function Elaborate (Id : Integer) return Index is
    begin
        Last := Last + 1;
        E_List (Last) := Id;
        if Verbose then
            Report.Comment ("Elaborating" & Integer'Image (Id));
        end if;
        return Index(Id mod 10);
    end Elaborate;

    function Elaborate (Id, Per_Obj_Expr : Integer) return Index is
    begin
        return Elaborate (Id);
    end Elaborate;

begin
 
    Report.Test ("C940015", "Check that the component_declarations of a" &
                            " protected object are elaborated in the" &
                            " proper order");
    declare
        -- an unprotected queue type
        type Storage is array (Index range <>) of Integer;
        type Queue (Size, Flag : Index := 1) is
            record
                Head : Index := 1;
                Tail : Index := 1;
                Count : Index := 0;
                Buffer : Storage (1..Size);
            end record;

        -- protected group of queues type
        protected type Prot_Queues (Size : Index := Elaborate (104)) is 
            procedure Clear;
            -- other needed procedures not provided at this time
        private
               -- elaborate at type elaboration
            Fixed_Queue_1    : Queue (3,  
                                      Elaborate (105));
               -- elaborate at type elaboration
            Fixed_Queue_2    : Queue (6,    
                                      Elaborate (107));
        end Prot_Queues;
        protected body Prot_Queues is
            procedure Clear is
            begin 
                Fixed_Queue_1.Count := 0;
                Fixed_Queue_1.Head := 1;
                Fixed_Queue_1.Tail := 1;
                Fixed_Queue_2.Count := 0;
                Fixed_Queue_2.Head := 1;
                Fixed_Queue_2.Tail := 1;
            end Clear;
        end Prot_Queues;
          
        PO1 : Prot_Queues(9);
        PO2 : Prot_Queues;

        Expected_Elab_Order : List := (
           -- from the elaboration of the protected type Prot_Queues
           105, 107,
           -- from the unconstrained object PO2
           104,
           others => 0);
    begin
        for I in List'Range loop
            if E_List (I) /= Expected_Elab_Order (I) then
                Report.Failed ("wrong elaboration order"); 
                Do_Display := True;
            end if;
        end loop;
        if Do_Display then
            Report.Comment ("Expected  Actual");
            for I in List'Range loop
                Report.Comment (
                   Integer'Image (Expected_Elab_Order(I)) &
                   Integer'Image (E_List(I)));
            end loop;
        end if;

        -- make use of the protected objects
        PO1.Clear;
        PO2.Clear;
    end;

    Report.Result;
 
end C940015;