CbC/CbC_gcc: gcc/testsuite/ada/acats/tests/cc/cc50a01.a comparison

comparison gcc/testsuite/ada/acats/tests/cc/cc50a01.a @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+-- CC50A01.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 a formal parameter of a library-level generic unit may be
+--      a formal tagged private type. Check that a nonlimited tagged type may
+--      be passed as an actual. Check that if the formal type is indefinite,
+--      both indefinite and definite types may be passed as actuals.
+--
+-- TEST DESCRIPTION:
+--      The generic package declares a formal tagged private type (this can
+--      be considered the parent "mixin" class). This type is extended in
+--      the generic to provide support for stacks of items of any nonlimited
+--      tagged type. Stacks are modeled as singly linked lists, with the list
+--      nodes being objects of the extended type.
+--
+--      A generic testing procedure pushes items onto a stack, and pops them
+--      back off, verifying the state of the stack at various points along the
+--      way. The push and pop routines exercise functionality important to
+--      tagged types, such as type conversion toward the root of the derivation
+--      class and extension aggregates.
+--
+--      The formal tagged private type has an unknown discriminant part, and
+--      is thus indefinite. This allows both definite and indefinite types
+--      to be passed as actuals. For tagged types, definite implies
+--      nondiscriminated, and indefinite implies discriminated (with known
+--      or unknown discriminants).
+--
+-- TEST FILES:
+--      This test consists of the following files:
+--
+--         FC50A00.A
+--      -> CC50A01.A
+--
+--
+-- CHANGE HISTORY:
+--      06 Dec 94   SAIC    ACVC 2.0
+--      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiations of
+--                          BC50A01_0 to library level.
+--      11 Aug 96   SAIC    ACVC 2.1: Updated prologue. Added pragma
+--                          Elaborate to context clauses for CC50A01_2 & _3.
+--
+--!
+with FC50A00;  -- Tagged (actual) type declarations.
+generic        -- Generic stack abstraction.
+type Item (<>) is tagged private;            -- Formal tagged private type.
+TC_Default_Value : Item;                     -- Needed in View_Top (see
+-- below).
+package CC50A01_0 is
+type Stack is private;
+-- Note that because the actual type corresponding to Item may be
+-- unconstrained, the functions of removing the top item from the stack and
+-- returning the value of the top item of the stack have been separated into
+-- Pop and View_Top, respectively. This is necessary because otherwise the
+-- returned value would have to be an out parameter of Pop, which would
+-- require the user (in the unconstrained case) to create an uninitialized
+-- unconstrained object to serve as the actual, which is illegal.
+procedure Push     (I : in Item; S : in out Stack);
+procedure Pop      (S : in out Stack);
+function  View_Top (S : Stack) return Item;
+function Size_Of (S : Stack) return Natural;
+private
+type Stack_Item;
+type Stack_Ptr is access Stack_Item;
+type Stack_Item is new Item with record      -- Extends formal type.
+Next : Stack_Ptr := null;
+end record;
+type Stack is record
+Top  : Stack_Ptr := null;
+Size : Natural   := 0;
+end record;
+end CC50A01_0;
+--==================================================================--
+package body CC50A01_0 is
+-- Link NewItem in at the top of the stack (the extension aggregate within
+-- the allocator initializes the inherited portion of NewItem to equal I,
+-- and NewItem.Next to point to what S.Top points to).
+procedure Push (I : in Item; S : in out Stack) is
+NewItem : Stack_Ptr;
+begin
+NewItem := new Stack_Item'(I with S.Top);     -- Extension aggregate.
+S.Top   := NewItem;
+S.Size  := S.Size + 1;
+end Push;
+-- Remove item from top of stack. This procedure only updates the state of
+-- the stack; it does not return the value of the popped item. Hence, in
+-- order to accomplish a "true" pop, both View_Top and Pop must be called
+-- consecutively.
+--
+-- If the stack is empty, the Pop is ignored (for simplicity; in a true
+-- application this might be treated as an error condition).
+procedure Pop (S : in out Stack) is
+begin
+if S.Top = null then                          -- Stack is empty.
+null;
+-- Raise exception.
+else
+S.Top  := S.Top.Next;
+S.Size := S.Size - 1;
+-- Deallocate discarded node.
+end if;
+end Pop;
+-- Return the value of the top item on the stack. This procedure only
+-- returns the value; it does not remove the top item from the stack.
+-- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
+-- be called consecutively.
+--
+-- Since items on the stack are of a type (Stack_Item) derived from Item,
+-- which is a (tagged) private type, type conversion toward the root is the
+-- only way to get a value of type Item for return to the caller.
+--
+-- If the stack is empty, View_Top returns a pre-specified default value.
+-- (In a true application, an exception might be raised instead).
+function View_Top (S : Stack) return Item is
+begin
+if S.Top = null then                          -- Stack is empty.
+return TC_Default_Value;                   -- Testing artifice.
+-- Raise exception.
+else
+return Item(S.Top.all);                    -- Type conversion.
+end if;
+end View_Top;
+function Size_Of (S : Stack) return Natural is
+begin
+return (S.Size);
+end Size_Of;
+end CC50A01_0;
+--==================================================================--
+-- The formal package Stacker below is needed to gain access to the
+-- appropriate version of the "generic" type Stack. It is provided with an
+-- explicit actual part in order to restrict the packages that can be passed
+-- as actuals to those which have been instantiated with the same actuals
+-- which this generic procedure has been instantiated with.
+with CC50A01_0;  -- Generic stack abstraction.
+generic
+type Item_Type (<>) is tagged private;       -- Formal tagged private type.
+Default : Item_Type;
+with package Stacker is new CC50A01_0 (Item_Type, Default);
+procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
+--==================================================================--
+--
+-- This generic procedure performs all of the testing of the
+-- stack abstraction.
+--
+with Report;
+procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
+begin
+Stacker.Push (I, S);                    -- Push onto empty stack.
+Stacker.Push (I, S);                    -- Push onto nonempty stack.
+if Stacker.Size_Of (S) /= 2 then
+Report.Failed ("   Wrong stack size after 2 Pushes");
+end if;
+-- Calls to View_Top must initialize a declared object of type Item_Type
+-- because the type may be unconstrained.
+declare
+Buffer1 : Item_Type := Stacker.View_Top (S);
+begin
+Stacker.Pop (S);                     -- Pop item off nonempty stack.
+if Buffer1 /= I then
+Report.Failed ("   Wrong stack item value after 1st Pop");
+end if;
+end;
+declare
+Buffer2 : Item_Type := Stacker.View_Top (S);
+begin
+Stacker.Pop (S);                     -- Pop last item off stack.
+if Buffer2 /= I then
+Report.Failed ("   Wrong stack item value after 2nd Pop");
+end if;
+end;
+if Stacker.Size_Of (S) /= 0 then
+Report.Failed ("   Wrong stack size after 2 Pops");
+end if;
+declare
+Buffer3 : Item_Type := Stacker.View_Top (S);
+begin
+if Buffer3 /= Default then
+Report.Failed ("   Wrong result after Pop of empty stack");
+end if;
+Stacker.Pop (S);                     -- Pop off empty stack.
+end;
+end CC50A01_1;
+--==================================================================--
+with FC50A00;
+with CC50A01_0;
+pragma Elaborate (CC50A01_0);
+package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
+FC50A00.TC_Default_Count);
+--==================================================================--
+with FC50A00;
+with CC50A01_0;
+pragma Elaborate (CC50A01_0);
+package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
+FC50A00.TC_Default_Person);
+--==================================================================--
+with FC50A00;   -- Tagged (actual) type declarations.
+with CC50A01_0; -- Generic stack abstraction.
+with CC50A01_1; -- Generic stack testing procedure.
+with CC50A01_2;
+with CC50A01_3;
+with Report;
+procedure CC50A01 is
+package Count_Stacks  renames CC50A01_2;
+package Person_Stacks renames CC50A01_3;
+procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
+FC50A00.TC_Default_Count,
+Count_Stacks);
+Count_Stack : Count_Stacks.Stack;
+procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
+FC50A00.TC_Default_Person,
+Person_Stacks);
+Person_Stack : Person_Stacks.Stack;
+begin
+Report.Test ("CC50A01", "Check that a formal parameter of a " &
+"library-level generic unit may be a formal tagged " &
+"private type");
+Report.Comment ("Testing definite tagged type..");
+TC_Count_Test  (Count_Stack,  FC50A00.TC_Count_Item);
+Report.Comment ("Testing indefinite tagged type..");
+TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
+Report.Result;
+end CC50A01;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cc/cc50a01.a @ 111:04ced10e8804