URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c9/] [c910003.a] - Rev 867
Go to most recent revision | Compare with Previous | Blame | View Log
-- C910003.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
-- F08630-91-C-0015, 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 task discriminants that have an access subtype may be
-- dereferenced.
--
-- Note that discriminants in Ada 83 never can be dereferenced with
-- selection or indexing, as they cannot have an access type.
--
-- TEST DESCRIPTION:
-- A protected object is defined to create a simple buffer.
-- Two task types are defined, one to put values into the buffer,
-- and one to remove them. The tasks are passed a buffer object as
-- a discriminant with an access subtype. The producer task type includes
-- a discriminant to determine the values to product. The consumer task
-- type includes a value to save the results.
-- Two producer and one consumer tasks are declared, and the results
-- are checked.
--
-- CHANGE HISTORY:
-- 10 Mar 99 RLB Created test.
--
--!
package C910003_Pack is
type Item_Type is range 1 .. 100; -- In a real application, this probably
-- would be a record type.
type Item_Array is array (Positive range <>) of Item_Type;
protected type Buffer is
entry Put (Item : in Item_Type);
entry Get (Item : out Item_Type);
function TC_Items_Buffered return Item_Array;
private
Saved_Item : Item_Type;
Empty : Boolean := True;
TC_Items : Item_Array (1 .. 10);
TC_Last : Natural := 0;
end Buffer;
type Buffer_Access_Type is access Buffer;
PRODUCE_COUNT : constant := 2; -- Number of items to produce.
task type Producer (Buffer_Access : Buffer_Access_Type;
Start_At : Item_Type);
-- Produces PRODUCE_COUNT items. Starts when activated.
type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2);
task type Consumer (Buffer_Access : Buffer_Access_Type;
Results : TC_Item_Array_Access_Type) is
-- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
-- activated.
entry Wait_until_Done;
end Consumer;
end C910003_Pack;
with Report;
package body C910003_Pack is
protected body Buffer is
entry Put (Item : in Item_Type) when Empty is
begin
Empty := False;
Saved_Item := Item;
TC_Last := TC_Last + 1;
TC_Items(TC_Last) := Item;
end Put;
entry Get (Item : out Item_Type) when not Empty is
begin
Empty := True;
Item := Saved_Item;
end Get;
function TC_Items_Buffered return Item_Array is
begin
return TC_Items(1..TC_Last);
end TC_Items_Buffered;
end Buffer;
task body Producer is
-- Produces PRODUCE_COUNT items. Starts when activated.
begin
for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop
Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2);
end loop;
end Producer;
task body Consumer is
-- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
-- activated.
begin
for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop
Buffer_Access.Get (Results (I));
-- Buffer_Access and Results are both dereferenced.
end loop;
-- Check the results (and function call with a prefix dereference).
if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then
Report.Failed ("First item mismatch");
end if;
if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then
Report.Failed ("Second item mismatch");
end if;
accept Wait_until_Done; -- Tell main that we're done.
end Consumer;
end C910003_Pack;
with Report;
with C910003_Pack;
procedure C910003 is
begin -- C910003
Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced");
declare -- encapsulate the test
Buffer_Access : C910003_Pack.Buffer_Access_Type :=
new C910003_Pack.Buffer;
TC_Results : C910003_Pack.TC_Item_Array_Access_Type :=
new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2);
Producer_1 : C910003_Pack.Producer (Buffer_Access, 12);
Producer_2 : C910003_Pack.Producer (Buffer_Access, 23);
Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results);
use type C910003_Pack.Item_Array; -- For /=.
begin
Consumer.Wait_until_Done;
if TC_Results.all /= Buffer_Access.TC_Items_Buffered then
Report.Failed ("Different items buffered than returned - Main");
end if;
if (TC_Results.all /= (12, 14, 23, 25) and
TC_Results.all /= (12, 23, 14, 25) and
TC_Results.all /= (12, 23, 25, 14) and
TC_Results.all /= (23, 12, 14, 25) and
TC_Results.all /= (23, 12, 25, 14) and
TC_Results.all /= (23, 25, 12, 14)) then
-- Above are the only legal results.
Report.Failed ("Wrong results");
end if;
end; -- encapsulation
Report.Result;
end C910003;
Go to most recent revision | Compare with Previous | Blame | View Log