diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/c9 | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
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.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c9')
256 files changed, 45302 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910001.a b/gcc/testsuite/ada/acats/tests/c9/c910001.a new file mode 100644 index 000000000..416e13ca8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910001.a @@ -0,0 +1,224 @@ +-- C910001.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 tasks may have discriminants. Specifically, check where +-- the subtype of the discriminant is a discrete subtype and where it is +-- an access subtype. Check the case where the default values of the +-- discriminants are used. +-- +-- TEST DESCRIPTION: +-- A task is defined with two discriminants, one a discrete subtype and +-- another that is an access subtype. Tasks are created with various +-- values for discriminants and code within the task checks that these +-- are passed in correctly. One instance of a default is used. The +-- values passed to the task as the discriminants are taken from an +-- array of test data and the values received are checked against the +-- same array. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; + +procedure C910001 is + + + type App_Priority is range 1..10; + Default_Priority : App_Priority := 5; + + type Message_ID is range 1..10_000; + + type TC_Number_of_Messages is range 1..5; + + type TC_rec is record + TC_ID : Message_ID; + A_Priority : App_Priority; + TC_Checked : Boolean; + end record; + + -- This table is used to create the messages and to check them + TC_table : array (1..TC_Number_of_Messages'Last) of TC_Rec := + ( ( 10, 6, false ), + ( 20, 2, false ), + ( 30, 9, false ), + ( 40, 1, false ), + ( 50, Default_Priority, false ) ); + +begin -- C910001 + + Report.Test ("C910001", "Check that tasks may have discriminants"); + + + declare -- encapsulate the test + + type Transaction_Record is + record + ID : Message_ID; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + end record; + -- + type acc_Transaction_Record is access Transaction_Record; + + + task type Message_Task + (In_Message : acc_Transaction_Record := null; + In_Priority : App_Priority := Default_Priority) is + entry Start; + end Message_Task; + type acc_Message_Task is access Message_Task; + -- + -- + task body Message_Task is + This_Message : acc_Transaction_Record := In_Message; + This_Priority : App_Priority := In_Priority; + TC_Match_Found : Boolean := false; + begin + accept Start; + -- In the example envisioned this task would then queue itself + -- upon some Distributor task which would send it off (requeue) to + -- the message processing tasks according to the priority of the + -- message and the current load on the system. For the test we + -- just verify the data passed in as discriminants and exit the task + -- + -- Check for the special case of default discriminants + if This_Message = null then + -- The default In_Message has been passed, check that the + -- default priority was also passed + if This_Priority /= Default_Priority then + Report.Failed ("Incorrect Default Priority"); + end if; + if TC_Table (TC_Number_of_Messages'Last).TC_Checked then + Report.Failed ("Duplicate Default messages"); + else + -- Mark that default has been seen + TC_Table (TC_Number_of_Messages'Last).TC_Checked := True; + end if; + TC_Match_Found := true; + else + -- Check the data against the table + for i in TC_Number_of_Messages loop + if TC_Table(i).TC_ID = This_Message.ID then + -- this is the right slot in the table + if TC_Table(i).TC_checked then + -- Already checked + Report.Failed ("Duplicate Data"); + else + TC_Table(i).TC_checked := true; + end if; + TC_Match_Found := true; + if TC_Table(i).A_Priority /= This_Priority then + Report.Failed ("ID/Priority mismatch"); + end if; + exit; + end if; + end loop; + end if; + + if not TC_Match_Found then + Report.Failed ("No ID match in table"); + end if; + + -- Allow the task to terminate + + end Message_Task; + + + -- The Line Driver task accepts data from an external source and + -- builds them into a transaction record. It then generates a + -- message task. This message "contains" the record and is given + -- a priority according to the contents of the message. The priority + -- and transaction records are passed to the task as discriminants. + -- In this test we use a dummy record. Only the ID is of interest + -- so we pick that and the required priority from an array of + -- test data. We artificially limit the endless driver-loop to + -- the number of messages required for the test and add a special + -- case to check the defaults. + -- + task Driver_Task; + -- + task body Driver_Task is + begin + + -- Create all but one of the required tasks + -- + for i in 1..TC_Number_of_Messages'Last - 1 loop + declare + -- Create a record for the next message + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := + new Message_Task( Next_Transaction, + TC_Table(i).A_Priority ); + + begin + -- Artificially plug the ID with the next from the table + -- In reality the whole record would be built here + Next_Transaction.ID := TC_Table(i).TC_ID; + + -- Ensure the task does not start executing till the + -- transaction record is properly constructed + Next_Message_Task.Start; + + end; -- declare + end loop; + + -- For this subtest create one task with the default discriminants + -- + declare + + -- Create the task + Next_Message_Task : acc_Message_Task := new Message_Task; + + begin + + Next_Message_Task.Start; + + end; -- declare + + + end Driver_Task; + + begin + null; + end; -- encapsulation + + -- Now verify that all the tasks executed and checked in + for i in TC_Number_of_Messages loop + if not TC_Table(i).TC_Checked then + Report.Failed + ("Task" & integer'image(integer (i) ) & " did not verify"); + end if; + end loop; + Report.Result; + +end C910001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c910002.a b/gcc/testsuite/ada/acats/tests/c9/c910002.a new file mode 100644 index 000000000..dc0b9b36b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910002.a @@ -0,0 +1,143 @@ +-- C910002.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 the contents of a task object include the values +-- of its discriminants. +-- Check that selected_component notation can be used to +-- denote a discriminant of a task. +-- +-- TEST DESCRIPTION: +-- This test declares a task type that contains discriminants. +-- Objects of the task type are created with different values. +-- The task type has nested tasks that are used to check that +-- the discriminate values are the expected values. +-- Note that the names of the discriminants in the body of task +-- type DTT denote the current instance of the unit. +-- +-- +-- CHANGE HISTORY: +-- 12 OCT 95 SAIC Initial release for 2.1 +-- 8 MAY 96 SAIC Incorporated Reviewer comments. +-- +--! + + +with Report; +procedure C910002 is + Verbose : constant Boolean := False; +begin + Report.Test ("C910002", + "Check that selected_component notation can be" & + " used to access task discriminants"); + declare + + task type DTT + (IA, IB : Integer; + CA, CB : Character) is + entry Check_Values (First_Int : Integer; + First_Char : Character); + end DTT; + + task body DTT is + Int1 : Integer; + Char1 : Character; + + -- simple nested task to check the character values + task Check_Chars is + entry Start_Check; + end Check_Chars; + task body Check_Chars is + begin + accept Start_Check; + if DTT.CA /= Char1 or + DTT.CB /= Character'Succ (Char1) then + Report.Failed ("character check failed. Expected: '" & + Char1 & Character'Succ (Char1) & + "' but found '" & + DTT.CA & DTT.CB & "'"); + elsif Verbose then + Report.Comment ("char check for " & Char1); + end if; + exception + when others => Report.Failed ("exception in Check_Chars"); + end Check_Chars; + + -- use a discriminated task to check the integer values + task type Check_Ints (First : Integer); + task body Check_Ints is + begin + if DTT.IA /= Check_Ints.First or + IB /= First+1 then + Report.Failed ("integer check failed. Expected:" & + Integer'Image (Check_Ints.First) & + Integer'Image (First+1) & + " but found" & + Integer'Image (DTT.IA) & Integer'Image (IB) ); + elsif Verbose then + Report.Comment ("int check for" & Integer'Image (First)); + end if; + exception + when others => Report.Failed ("exception in Check_Ints"); + end Check_Ints; + begin + accept Check_Values (First_Int : Integer; + First_Char : Character) do + Int1 := First_Int; + Char1 := First_Char; + end Check_Values; + + -- kick off the character check + Check_Chars.Start_Check; + + -- do the integer check + declare + Int_Checker : Check_Ints (Int1); + begin + null; -- let task do its thing + end; + + -- do one test here too + if DTT.IA /= Int1 then + Report.Failed ("DTT check failed. Expected:" & + Integer'Image (Int1) & + " but found:" & + Integer'Image (DTT.IA)); + elsif Verbose then + Report.Comment ("DTT check for" & Integer'Image (Int1)); + end if; + exception + when others => Report.Failed ("exception in DTT"); + end DTT; + + T1a : DTT (1, 2, 'a', 'b'); + T9C : DTT (9, 10, 'C', 'D'); + begin -- test encapsulation + T1a.Check_Values (1, 'a'); + T9C.Check_Values (9, 'C'); + end; + + Report.Result; +end C910002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c910003.a b/gcc/testsuite/ada/acats/tests/c9/c910003.a new file mode 100644 index 000000000..b2e11cef8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910003.a @@ -0,0 +1,185 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004b.ada b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada new file mode 100644 index 000000000..16a17cf32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada @@ -0,0 +1,108 @@ +-- C91004B.ADA + +-- 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 TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN +-- BODY, REFERS TO THE EXECUTING TASK. + +-- TEST USING IDENTIFIER IN ABORT STATEMENT, AS AN EXPRESSION IN +-- A MEMBERSHIP TEST, AND THE PREFIX OF 'CALLABLE AND +-- 'TERMINATED. + +-- HISTORY: +-- WEI 3/ 4/82 CREATED ORIGINAL TEST. +-- RJW 11/13/87 RENAMED TEST FROM C910BDA.ADA. ADDED CHECKS FOR +-- MEMBERSHIP TEST, AND 'CALLABLE AND 'TERMINATED +-- ATTRIBUTES. + +WITH REPORT; USE REPORT; +PROCEDURE C91004B IS + + TYPE I0 IS RANGE 0..1; + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK TYPE TT1 IS + ENTRY E1 (P1 : IN I0; P2 : ARG); + ENTRY BYE; + END TT1; + + SUBTYPE SUB_TT1 IS TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + IF TT1 NOT IN SUB_TT1 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST"); + END IF; + + IF NOT TT1'CALLABLE THEN + FAILED ("INCORRECT RESULTS FOR 'CALLABLE"); + END IF; + + IF TT1'TERMINATED THEN + FAILED ("INCORRECT RESULTS FOR 'TERMINATED"); + END IF; + + ACCEPT E1 (P1 : IN I0; P2 : ARG) DO + IF P1 = 1 THEN + ABORT TT1; + ACCEPT BYE; -- WILL DEADLOCK IF NOT ABORTED. + END IF; + PSPY_NUMB (ARG (P2)); + END E1; + + END TT1; + +BEGIN + + TEST ("C91004B", "TASK IDENTIFIER IN OWN BODY"); + + BEGIN + OBJ_TT1 (1).E1 (1,1); + FAILED ("NO TASKING_ERROR RAISED"); +-- ABORT DURING RENDEVOUS RAISES TASKING ERROR + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + OBJ_TT1 (2).E1 (0,2); + + IF SPYNUMB /= 2 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C91004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004c.ada b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada new file mode 100644 index 000000000..a07543370 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada @@ -0,0 +1,82 @@ +-- C91004C.ADA + +-- 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. +--* +-- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN BODY +-- REFERS TO THE EXECUTING TASK. +-- +-- TEST USING CONDITIONAL ENTRY CALL. + +-- WEI 3/ 4/82 +-- TLB 10/30/87 RENAMED FROM C910BDB.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C91004C IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY BYE; + END TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + + SELECT + TT1.E1; + ELSE + PSPY_NUMB (2); + END SELECT; + + ACCEPT BYE; + END TT1; + +BEGIN + + TEST ("C91004C", "TASK IDENTIFIER IN OWN BODY"); + OBJ_TT1 (1).E1; + OBJ_TT1 (1).BYE; + + IF SPYNUMB /=12 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + ABORT OBJ_TT1 (2); + + RESULT; + +END C91004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91006a.ada b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada new file mode 100644 index 000000000..1217d1459 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada @@ -0,0 +1,82 @@ +-- C91006A.ADA + +-- 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. +--* +-- CHECK THAT IN A TASK SPECIFICATION ENTRY DECLARATIONS ARE ELABORATED +-- WHEN THE SPECIFICATION IS ELABORATED, AND IN TEXTUAL ORDER. + +-- WEI 3/04/82 +-- BHS 7/13/84 +-- TBN 12/17/85 RENAMED FROM C910AHA-B.ADA; +-- ADDED DECLARATIONS OF FIRST AND LAST. +-- PWB 5/15/86 MOVED DECLARATIONS OF FIRST, TASK T1, AND LAST +-- INTO A DECLARE/BEGIN/END BLOCK. + +WITH REPORT; USE REPORT; +PROCEDURE C91006A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + INDEX : INTEGER RANGE 0..5 := 0; + SPYNUMB : STRING(1..5) := (1..5 => ' '); + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + TEMP : STRING(1..2); + BEGIN + TEMP := ARG'IMAGE(DIGT); + INDEX := INDEX + 1; + SPYNUMB(INDEX) := TEMP(2); + RETURN DIGT; + END FINIT_POS; + +BEGIN + TEST ("C91006A", "CHECK THAT IN A TASK SPEC, ELABORATION IS IN " & + "TEXTUAL ORDER"); + DECLARE + + FIRST : INTEGER := FINIT_POS (1); + + TASK T1 IS + ENTRY E2 (NATURAL RANGE 1 .. FINIT_POS (2)); + ENTRY E3 (NATURAL RANGE 1 .. FINIT_POS (3)); + ENTRY E4 (NATURAL RANGE 1 .. FINIT_POS (4)); + END T1; + + LAST : INTEGER := FINIT_POS (5); + + TASK BODY T1 IS + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END; + + IF SPYNUMB /= "12345" THEN + FAILED ("TASK SPEC T1 NOT ELABORATED IN TEXTUAL ORDER"); + COMMENT ("ACTUAL ORDER WAS: " & SPYNUMB); + END IF; + + RESULT; + +END C91006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91007a.ada b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada new file mode 100644 index 000000000..d2b21b302 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada @@ -0,0 +1,97 @@ +-- C91007A.ADA + +-- 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: +-- IF THE ELABORATION OF AN ENTRY DECLARATION RAISES +-- "CONSTRAINT_ERROR", THEN NO TASKS ARE ACTIVATED, AND +-- "TASKING_ERROR" IS NOT RAISED. + +-- HISTORY: +-- LDC 06/17/88 CREATED ORGINAL TEST + +WITH REPORT; +USE REPORT; + +PROCEDURE C91007A IS + + TYPE ENUM IS (TERESA, BRIAN, PHIL, JOLEEN, LYNN, DOUG, JODIE, + VINCE, TOM, DAVE, JOHN, ROSA); + SUBTYPE ENUM_SUB IS ENUM RANGE BRIAN..LYNN; + +BEGIN + TEST("C91007A","IF THE ELABORATION OF AN ENTRY DECLARATION " & + "RAISES 'CONSTRAINT_ERROR', THEN NO TASKS ARE " & + "ACTIVATED, AND 'TASKING_ERROR' IS NOT RAISED"); + + BEGIN + DECLARE + TASK TYPE TSK1; + T1 : TSK1; + TASK BODY TSK1 IS + BEGIN + FAILED("TSK1 WAS ACTIVATED"); + END TSK1; + + + TASK TSK2 IS + ENTRY ENT(ENUM_SUB RANGE TERESA..LYNN); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + FAILED("TASK BODY WAS ACTIVATED"); + END TSK2; + + TASK TSK3; + TASK BODY TSK3 IS + BEGIN + FAILED("TSK3 WAS ACTIVATED"); + END TSK3; + + BEGIN + NULL; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED IN THE " & + "BEGIN BLOCK"); + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR IN THE BEGIN BLOCK"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS RAISED IN " & + "THE BEGIN BLOCK"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION WAS RAISED"); + END; + + RESULT; + +END C91007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92002a.ada b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada new file mode 100644 index 000000000..879cf36b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada @@ -0,0 +1,73 @@ +-- C92002A.ADA + +-- 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. +--* +-- CHECK THAT ASSIGNMENT TO A COMPONENT (FOR WHICH ASSIGNMENT IS +-- AVAILABLE) OF A RECORD CONTAINING A TASK IS AVAILABLE. + +-- JRK 9/17/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C92002A IS + +BEGIN + TEST ("C92002A", "CHECK THAT CAN ASSIGN TO ASSIGNABLE " & + "COMPONENTS OF RECORDS WITH TASK " & + "COMPONENTS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + I : INTEGER := 0; + T : TT; + J : INTEGER := 0; + END RECORD; + + R : RT; + + TASK BODY TT IS + BEGIN + NULL; + END TT; + + BEGIN + + R.I := IDENT_INT (7); + R.J := IDENT_INT (9); + + IF R.I /= 7 AND R.J /= 9 THEN + FAILED ("WRONG VALUE(S) WHEN ASSIGNING TO " & + "INTEGER COMPONENTS OF RECORDS WITH " & + "TASK COMPONENTS"); + END IF; + + END; + + RESULT; +END C92002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92003a.ada b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada new file mode 100644 index 000000000..ff42680b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada @@ -0,0 +1,117 @@ +-- C92003A.ADA + +-- 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. +--* +-- CHECK THAT A TASK CAN BE PASSED AS AN ACTUAL IN OR IN OUT PARAMETER +-- IN A SUBPROGRAM CALL AND THAT THE ACTUAL AND FORMAL PARAMETERS DENOTE +-- THE SAME TASK OBJECT. + +-- JRK 1/17/81 +-- TBN 12/19/85 ADDED IN OUT PARAMETER CASE. +-- PWB 8/04/86 ADDED CHECK THAT FORMAL AND ACTUAL PARAMETERS DENOTE +-- THE SAME TASK OBJECT. + +WITH REPORT; USE REPORT; + +PROCEDURE C92003A IS + +BEGIN + + TEST ("C92003A", "CHECK TASKS PASSED AS ACTUAL IN OR IN OUT " & + "PARAMETERS TO SUBPROGRAMS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + T, S : TT; + + TASK BODY TT IS + SOURCE : INTEGER; + BEGIN + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 1 THEN + FAILED ("EXPECTED 1, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 2 THEN + FAILED ("EXPECTED 2, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 3 THEN + FAILED ("EXPECTED 3, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + END TT; + + PROCEDURE P (T : TT) IS + BEGIN + T.E(2); + END P; + + PROCEDURE Q (S : IN OUT TT) IS + BEGIN + S.E(2); + END Q; + + BEGIN + + T.E(1); -- FIRST CALL TO T.E + P(T); -- SECOND CALL TO T.E + T.E(3); -- THIRD CALL TO T.E + + S.E(1); -- FIRST CALL TO S.E + Q(S); -- SECOND CALL TO S.E + S.E(3); -- THIRD CALL TO S.E + + END; + + RESULT; + +END C92003A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005a.ada b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada new file mode 100644 index 000000000..6766c573e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada @@ -0,0 +1,75 @@ +-- C92005A.ADA + +-- 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. +--* +-- CHECK THAT FOR A NON-SINGLE TASK THE OBJECT VALUE IS SET DURING +-- ELABORATION OF THE CORRESPONDING OBJECT DECLARATION. + +-- WEI 3/ 4/82 +-- JBG 5/25/85 +-- PWB 2/3/86 CORRECTED TEST ERROR; ADDED 'USE' CLAUSE TO MAKE "/=" +-- FOR BIG_INT VISIBLE. + +WITH REPORT, SYSTEM; + USE REPORT; +PROCEDURE C92005A IS +BEGIN + + TEST ("C92005A", "TASK OBJECT VALUE DURING ELABORATION"); + + DECLARE + TASK TYPE TT1; + + OBJ_TT1 : TT1; + + PACKAGE PACK IS + TYPE BIG_INT IS RANGE 0 .. SYSTEM.MAX_INT; + I : BIG_INT; + END PACK; + + PACKAGE BODY PACK IS + BEGIN + I := OBJ_TT1'STORAGE_SIZE; -- O.K. + EXCEPTION + WHEN OTHERS => + FAILED ("TASK OBJECT RAISED EXCEPTION"); + END PACK; + + USE PACK; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + BEGIN + IF PACK.I /= OBJ_TT1'STORAGE_SIZE THEN + COMMENT ("STORAGE SIZE CHANGED AFTER TASK ACTIVATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY STORAGE_SIZE"); + END; + + RESULT; +END C92005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005b.ada b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada new file mode 100644 index 000000000..e5672a7c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada @@ -0,0 +1,72 @@ +-- C92005B.ADA + +-- 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. +--* +-- CHECK THAT FOR A TASK OBJECT CREATED BY AN ALLOCATOR THE +-- OBJECT VALUE IS SET DURING EXECUTION OF THE ALLOCATOR. + +-- WEI 3/ 4/82 +-- JBG 5/25/85 +-- RLB 1/ 7/05 + +WITH REPORT; + USE REPORT; +WITH SYSTEM; +PROCEDURE C92005B IS + TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT; +BEGIN + TEST ("C92005B", "TASK VALUE SET BY EXECUTION OF ALLOCATOR"); + +BLOCK: + DECLARE + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + PACKAGE PACK IS + END PACK; + + PACKAGE BODY PACK IS + POINTER_TT1 : ATT1 := NEW TT1; + I : BIG_INT := POINTER_TT1.ALL'STORAGE_SIZE; + BEGIN + IF NOT EQUAL(INTEGER(I MOD 1024), INTEGER(I MOD 1024)) THEN + FAILED ("UNEXPECTED PROBLEM"); + END IF; + END PACK; + BEGIN + NULL; + EXCEPTION + WHEN PROGRAM_ERROR | CONSTRAINT_ERROR => + FAILED ("TASK OBJECT VALUE NOT SET DURING " & + "EXECUTION OF ALLOCATOR"); + END BLOCK; + + RESULT; + +END C92005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92006a.ada b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada new file mode 100644 index 000000000..f0fd0c8c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada @@ -0,0 +1,93 @@ +-- C92006A.ADA + +-- 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. +--* +-- CHECK THAT TASK OBJECTS CAN BE INTERCHANGED BY ASSIGNMENT OF +-- CORRESPONDING ACCESS TYPE OBJECTS. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C920BIA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C92006A IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + POINTER_TT1_1, POINTER_TT1_2 : ATT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + PROCEDURE PROC (P1, P2 : IN OUT ATT1) IS + -- SWAP TASK OBJECTS P1, P2. + SCRATCH : ATT1; + BEGIN + SCRATCH := P1; + P1 := P2; + P2 := SCRATCH; + + P1.E2; -- ENTRY2 SECOND OBJECT. + P2.E1; -- VICE VERSA. + + END PROC; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END TT1; + +BEGIN + + TEST ("C92006A", "INTERCHANGING TASK OBJECTS"); + POINTER_TT1_1 := NEW TT1; + POINTER_TT1_2 := NEW TT1; + + POINTER_TT1_2.ALL.E1; + PROC (POINTER_TT1_1, POINTER_TT1_2); + POINTER_TT1_2.E2; -- E2 OF FIRST OBJECT +-- EACH ENTRY OF EACH TASK OBJECT SHOULD HAVE BEEN CALLED. + + IF SPYNUMB /= 1212 THEN + FAILED ("FAILURE TO SWAP TASK OBJECTS " & + "IN PROCEDURE PROC"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C92006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c930001.a b/gcc/testsuite/ada/acats/tests/c9/c930001.a new file mode 100644 index 000000000..874518990 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c930001.a @@ -0,0 +1,153 @@ +-- C930001.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 when a dependent task and its master both +-- terminate as a result of a terminate alternative that +-- finalization is performed and that the finalization is +-- performed in the proper order. +-- +-- TEST DESCRIPTION: +-- A controlled type with finalization is used to determine +-- the order in which finalization occurs. The finalization +-- procedure records the identity of the object being +-- finalized. +-- Two tasks, one nested inside the other, both contain +-- objects of the above finalization type. These tasks +-- cooperatively terminate so the termination and finalization +-- order can be noted. +-- +-- +-- CHANGE HISTORY: +-- 08 Jan 96 SAIC ACVC 2.1 +-- 09 May 96 SAIC Addressed Reviewer comments. +-- +--! + + +with Ada.Finalization; +package C930001_0 is + Verbose : constant Boolean := False; + + type Ids is range 0..10; + Finalization_Order : array (Ids) of Ids := (Ids => 0); + Finalization_Cnt : Ids := 0; + + protected Note is + -- serializes concurrent access to Finalization_* above + procedure Done (Id : Ids); + end Note; + + -- Objects of the following type are used to note the order in + -- which finalization occurs. + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Id : Ids; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C930001_0; + + +with Report; +package body C930001_0 is + + protected body Note is + procedure Done (Id : Ids) is + begin + Finalization_Cnt := Finalization_Cnt + 1; + Finalization_Order (Finalization_Cnt) := Id; + end Done; + end Note; + + procedure Finalize (Object : in out Has_Finalization) is + begin + Note.Done (Object.Id); + if Verbose then + Report.Comment ("in Finalize for" & Ids'Image (Object.Id)); + end if; + end Finalize; +end C930001_0; + + +with Report; +with ImpDef; +with C930001_0; use C930001_0; +procedure C930001 is +begin + + Report.Test ("C930001", "Check that dependent tasks are terminated" & + " before the remaining finalization"); + + declare + task Level_1; + task body Level_1 is + V1a : C930001_0.Has_Finalization; -------> 4 + task Level_2 is + entry Not_Taken; + end Level_2; + task body Level_2 is + V2 : C930001_0.Has_Finalization; -------> 2 + begin + V2.Id := 2; + C930001_0.Note.Done (1); -------> 1 + select + accept Not_Taken; + or + terminate; + -- cooperative termination at this point of + -- both tasks + end select; + end Level_2; + + -- 7.6.1(11) requires that V1b be finalized before V1a + V1b : C930001_0.Has_Finalization; -------> 3 + begin + V1a.Id := 4; + V1b.Id := 3; + end Level_1; + begin -- declare + while not Level_1'Terminated loop + delay ImpDef.Switch_To_New_Task; + end loop; + C930001_0.Note.Done (5); -------> 5 + + -- now check the order + for I in Ids range 1..5 loop + if Verbose then + Report.Comment (Ids'Image (I) & + Ids'Image (Finalization_Order (I))); + end if; + if Finalization_Order (I) /= I then + Report.Failed ("Finalization occurred out of order" & + " expected:" & + Ids'Image (I) & + " actual:" & + Ids'Image (Finalization_Order (I))); + end if; + end loop; + end; + + Report.Result; +end C930001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93001a.ada b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada new file mode 100644 index 000000000..3a3b9833b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada @@ -0,0 +1,296 @@ +-- C93001A.ADA + +-- 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. +--* +-- CHECK THAT DECLARED TASK OBJECTS ARE NOT ACTIVATED BEFORE +-- THE END OF THE DECLARATIVE PART. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST ASSUMES THAT ACTIVATION IS A SEQUENTIAL STEP +-- IN THE FLOW OF CONTROL OF THE PARENT (AS IS REQUIRED BY THE +-- ADA RM). IF AN IMPLEMENTATION (ILLEGALLY) ACTIVATES A +-- TASK IN PARALLEL WITH ITS PARENT, THIS TEST +-- IS NOT GUARANTEED TO DETECT THE VIOLATION, DUE TO A +-- RACE CONDITION. + +-- JRK 9/23/81 +-- SPS 11/1/82 +-- SPS 11/21/82 +-- R.WILLIAMS 10/8/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK +-- COMPONENTS OF RECORD TYPES. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93001A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93001A", "CHECK THAT DECLARED TASK OBJECTS ARE NOT " & + "ACTIVATED BEFORE THE END OF THE DECLARATIVE " & + + "PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + I : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I /= 0 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO SOON - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + I : INTEGER := GLOBAL; + BEGIN + IF I /= 0 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO SOON - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + PACKAGE P IS + + TYPE REC IS + RECORD + T : TT; + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : REC; + END RECORD; + R : RT; + I : INTEGER := GLOBAL; + END P; + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + N : P.REC; + T : TT; + M : INTEGER := GLOBAL; + END RECORD; + R : RT; + END Q; + + K : INTEGER := GLOBAL; + + PACKAGE BODY Q IS + BEGIN + IF R.M /= 0 OR R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD R NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.1)" ); + END IF; + END Q; + + BEGIN -- (C) + + IF P.R.M /= 0 OR P.R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORDS NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.2)" ); + END IF; + + IF P.I /= 0 OR K /= 0 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO SOON - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + TYPE ACCI IS ACCESS INTEGER; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + A : ARR; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + RA1 : RAT; + PRIVATE + RA2 : RAT; + END P; + + PACKAGE BODY P IS + RA3 : RAT; + I : INTEGER := GLOBAL; + BEGIN + IF RA1.M.G /= GOOD OR RA1.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M.G /= GOOD OR RA2.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA3.M.G /= GOOD OR RA3.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA3 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF I /= 0 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE SPEC OR BODY WAS ACTIVATED " & + "TOO SOON - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TYPE REC IS + RECORD + B : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + C :CHARACTER :=CHARACTER'VAL (GLOBAL); + END RECORD; + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : REC; + T : TT; + N : REC; + END RECORD; + AR : ARRAY (1..1) OF RT; + I : INTEGER := GLOBAL; + BEGIN + IF AR (1).M.B /= FALSE OR AR (1).M.C /= ASCII.NUL OR + AR (1).N.B /= FALSE OR AR (1).N.C /= ASCII.NUL THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RT NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (E)" ); + END IF; + + IF I /= 0 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO SOON - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93002a.ada b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada new file mode 100644 index 000000000..a9999ad2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada @@ -0,0 +1,231 @@ +-- C93002A.ADA + +-- 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. +--* +-- CHECK THAT DECLARED TASK OBJECTS ARE ACTIVATED BEFORE EXECUTION +-- OF THE FIRST STATEMENT FOLLOWING THE DECLARATIVE PART. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- JRK 9/28/81 +-- SPS 11/1/82 +-- SPS 11/21/82 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93002A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93002A", "CHECK THAT DECLARED TASK OBJECTS ARE " & + "ACTIVATED BEFORE EXECUTION OF THE FIRST " & + "STATEMENT FOLLOWING THE DECLARATIVE PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RT IS + RECORD + A : ARR; + END RECORD; + R : RT; + END P; + + PACKAGE BODY P IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C1)"); + END IF; + END P; + + BEGIN -- (C1) + + NULL; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + T : TT; + END RECORD; + R : RT; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARR; + END RECORD; + END P; + + PACKAGE BODY P IS + RA : RAT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93003a.ada b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada new file mode 100644 index 000000000..48dced34e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada @@ -0,0 +1,351 @@ +-- C93003A.ADA + +-- 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. +--* +-- CHECK THAT ACTIVATION OF TASKS CREATED BY ALLOCATORS PRESENT IN A +-- DECLARATIVE PART TAKES PLACE DURING ELABORATION OF THE +-- CORRESPONDING DECLARATION. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) AN ARRAY OF TASK ALLOCATOR, IN A FUNCTION. +-- (C) A RECORD OF TASK ALLOCATOR, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 9/28/81 +-- SPS 11/11/82 +-- SPS 11/21/82 +-- RJW 8/4/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK COMPONENTS +-- OF RECORD TYPES. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93003A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93003A", "CHECK THAT ACTIVATION OF TASKS CREATED BY " & + "ALLOCATORS PRESENT IN A DECLARATIVE PART " & + "TAKES PLACE DURING ELABORATION OF THE " & + "CORRESPONDING DECLARATION"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + TYPE A IS ACCESS TT; + T1 : A := NEW TT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + T2 : A := NEW TT; + I2 : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A SIMPLE TASK ALLOCATOR IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE A_T IS ARRAY (1 .. 1) OF TT; + TYPE A IS ACCESS A_T; + A1 : A := NEW A_T; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + A2 : A := NEW A_T; + I2 : INTEGER := GLOBAL; + + BEGIN + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF TASK ALLOCATOR IN A " & + "FUNCTION WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + + TYPE INTREC IS + RECORD + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : INTREC; + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END P; + + BEGIN -- (C1) + + IF P.R1.M /= 0 OR P.R1.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.R2.M /= 0 OR P.R2.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.I1 /= 1 OR P.I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE - (C1)"); + END IF; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J1 : INTEGER; + PRIVATE + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + TYPE ACCI IS ACCESS INTEGER; + + TYPE RT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + T : TT; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J2 : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END Q; + + PACKAGE BODY Q IS + BEGIN + IF R1.M.G /= GOOD OR R1.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF R2.M.G /= GOOD OR R2.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE ARR IS ARRAY (1 .. 1) OF TT; + TYPE INTARR IS ARRAY (1 .. 1) OF INTEGER; + + TYPE RAT IS + RECORD + M : INTARR := (1 => GLOBAL); + A : ARR; + N : INTARR := (1 => GLOBAL); + END RECORD; + END P; + + PACKAGE BODY P IS + + TYPE A IS ACCESS RAT; + + RA1 : A := NEW RAT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + RA2 : A := NEW RAT; + I2 : INTEGER := GLOBAL; + + BEGIN + IF RA1.M (1) /= 0 OR RA1.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M (1) /= 0 OR RA2.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK ALLOCATOR IN " & + "A PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + N : CHARACTER := CHARACTER'VAL (GLOBAL); + END RECORD; + + TYPE ART IS ARRAY (1 .. 1) OF RT; + TYPE A IS ACCESS ART; + + AR1 : A := NEW ART; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + AR2 : A := NEW ART; + I2 : INTEGER := GLOBAL; + + BEGIN + IF AR1.ALL (1).M /= FALSE OR + AR1.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF AR2.ALL (1).M /= FALSE OR + AR2.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK ALLOCATOR IN " & + "A TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93003A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004a.ada b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada new file mode 100644 index 000000000..688bec139 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada @@ -0,0 +1,67 @@ +-- C93004A.ADA + +-- 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. +--* +-- CHECK THAT A TASK BECOMES COMPLETED WHEN AN EXCEPTION OCCURS DURING +-- ITS ACTIVATION. + +-- WEI 3/ 4/82 + +WITH REPORT; + USE REPORT; +PROCEDURE C93004A IS +BEGIN + + TEST ("C93004A", "TASK COMPLETION CAUSED BY EXCEPTION"); + +BLOCK: + DECLARE + TYPE I0 IS RANGE 0..1; + + TASK T1 IS + ENTRY BYE; + END T1; + + TASK BODY T1 IS + SUBTYPE I1 IS I0 RANGE 0 .. 2; -- CONSTRAINT ERROR. + BEGIN + ACCEPT BYE; + END T1; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + IF NOT T1'TERMINATED THEN + FAILED ("TASK NOT TERMINATED"); + T1.BYE; + END IF; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END BLOCK; + + RESULT; + +END C93004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004b.ada b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada new file mode 100644 index 000000000..0b140f59c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada @@ -0,0 +1,132 @@ +-- C93004B.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR + +-- JEAN-PIERRE ROSEN 09-MAR-1984 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93004B IS + +BEGIN + TEST("C93004B", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..1) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS BEFORE + END START_T1; -- ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(1)).E; + FAILED ("RENDEZVOUS COMPLETED - T1BIS"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1BIS"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(1)).E; -- ARR_T2(1) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; +END C93004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004c.ada b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada new file mode 100644 index 000000000..bb4d68b5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada @@ -0,0 +1,136 @@ +-- C93004C.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- IF SEVERAL TASKS FAIL THEIR ACTIVATION, ONLY ONE TASKING_ERROR IS +-- RAISED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR + +-- JEAN-PIERRE ROSEN 09-MAR-1984 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93004C IS + +BEGIN + TEST("C93004C", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; + +END C93004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004d.ada b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada new file mode 100644 index 000000000..40eb01fba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada @@ -0,0 +1,152 @@ +-- C93004D.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THIS TEST CHECKS THE CASE IN WHICH SOME OF THE OTHER TASKS ARE +-- PERHAPS ACTIVATED BEFORE THE EXCEPTION OCCURS AND SOME TASKS ARE +-- PERHAPS ACTIVATED AFTER. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING FOR ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR. + +-- R. WILLIAMS 8/6/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C93004D IS + + +BEGIN + TEST ( "C93004D", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING ACTIVATION OF A TASK, OTHER TASKS " & + "ARE NOT AFFECTED. IN THIS TEST, SOME OF THE " & + "TASKS ARE PERHAPS ACTIVATED BEFORE THE " & + "EXCEPTION OCCURS AND SOME PERHAPS AFTER" ); + + + DECLARE + + TASK T0 IS + ENTRY E; + END T0; + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + TASK BODY T0 IS + BEGIN + ACCEPT E; + END T0; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW + -- TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN -- T0, ARR_T2 (1 .. 4), T3 ACTIVATED HERE. + + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T0 OR T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; +END C93004D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004f.ada b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada new file mode 100644 index 000000000..9267d3ec8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada @@ -0,0 +1,130 @@ +-- C93004F.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- THIS TESTS CHECKS THE CASE IN WHICH THE TASKS ARE CREATED BY THE +-- ALLOCATION OF A RECORD OF TASKS OR AN ARRAY OF TASKS. + +-- R. WILLIAMS 8/7/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C93004F IS + +BEGIN + TEST ( "C93004F", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING THE ACTIVATION OF A TASK, OTHER " & + "TASKS ARE UNAFFECTED. IN THIS TEST, THE " & + "TASKS ARE CREATED BY THE ALLOCATION OF A " & + "RECORD OR AN ARRAY OF TASKS" ); + + DECLARE + + TASK TYPE T IS + ENTRY E; + END T; + + TASK TYPE TT; + + TASK TYPE TX IS + ENTRY E; + END TX; + + TYPE REC IS + RECORD + TR : T; + END RECORD; + + TYPE ARR IS ARRAY (IDENT_INT (1) .. IDENT_INT (1)) OF T; + + TYPE RECX IS + RECORD + TTX1 : TX; + TTT : TT; + TTX2 : TX; + END RECORD; + + TYPE ACCR IS ACCESS REC; + AR : ACCR; + + TYPE ACCA IS ACCESS ARR; + AA : ACCA; + + TYPE ACCX IS ACCESS RECX; + AX : ACCX; + + TASK BODY T IS + BEGIN + ACCEPT E; + END T; + + TASK BODY TT IS + BEGIN + AR.TR.E; + EXCEPTION + WHEN OTHERS => + FAILED ( "TASK AR.TR NOT ACTIVE" ); + END TT; + + TASK BODY TX IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "TX ACTIVATED OK" ); + END IF; + END TX; + + BEGIN + AR := NEW REC; + AA := NEW ARR; + AX := NEW RECX; + + FAILED ( "TASKING_ERROR NOT RAISED IN MAIN" ); + + AA.ALL (1).E; -- CLEAN UP. + + EXCEPTION + WHEN TASKING_ERROR => + + BEGIN + AA.ALL (1).E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "AA.ALL (1) NOT ACTIVATED" ); + END; + + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN MAIN" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + +END C93004F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005a.ada b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada new file mode 100644 index 000000000..95626f688 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada @@ -0,0 +1,130 @@ +-- C93005A.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK +-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + +-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A +-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + +-- JEAN-PIERRE ROSEN 3/9/84 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005A IS + +BEGIN + TEST("C93005A", "EXCEPTIONS RAISED IN A DECLARATIVE PART " & + "CONTAINING TASKS"); + + BEGIN + + DECLARE + TASK TYPE T1 IS -- CHECKS THAT T2 TERMINATES. + END T1; + + TYPE AT1 IS ACCESS T1; + + TASK T2 IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END T2; + + PACKAGE RAISE_IT IS + END RAISE_IT; + + TASK BODY T2 IS + BEGIN + FAILED ("T2 ACTIVATED"); + -- IN CASE OF FAILURE + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T3 TERMINATES. + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T2.E; + FAILED ("RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T3; + BEGIN + NULL; + END; + + T2.E; --T2 IS NOW TERMINATED + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY RAISE_IT IS + PT1 : AT1 := NEW T1; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED ("PACKAGE DIDN'T RAISE EXCEPTION"); + END IF; + END RAISE_IT; + + BEGIN -- CAN'T LEAVE BLOCK UNTIL T1, T2, AND T3 ARE TERM. + FAILED ("EXCEPTION NOT RAISED"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN MAIN PROGRAM"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-1"); + END; + + RESULT; + +END C93005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005b.ada b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada new file mode 100644 index 000000000..1b621c0de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada @@ -0,0 +1,273 @@ +-- C93005B.ADA + +-- 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. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK +-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + +-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A +-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + +-- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR +-- ACTIVATION WHEN THE EXCEPTION OCCURS. + +-- R. WILLIAMS 8/7/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C93005B IS + + +BEGIN + TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " & + "DECLARATIVE PART, A TASK DECLARED IN THE " & + "SAME DECLARATIVE PART BECOMES TERMINATED. " & + "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " & + "ACTIVATION WHEN THE EXCEPTION OCCURS" ); + + BEGIN + + DECLARE + TASK TYPE TA IS -- CHECKS THAT TX TERMINATES. + END TA; + + TYPE ATA IS ACCESS TA; + + TASK TYPE TB IS -- CHECKS THAT TY TERMINATES. + END TB; + + TYPE TBREC IS + RECORD + TTB: TB; + END RECORD; + + TASK TX IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TX; + + TASK BODY TA IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TAB + -- TERMINATES. + TASK TAB IS + END TAB; + + TASK BODY TAB IS + BEGIN + TX.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TAB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TAB" ); + END TAB; + BEGIN + NULL; + END; + + TX.E; --TX IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TA" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TA" ); + END TA; + + PACKAGE RAISE_IT IS + TASK TY IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TY; + END RAISE_IT; + + TASK BODY TB IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TBB + -- TERMINATES. + TASK TBB IS + END TBB; + + TASK BODY TBB IS + BEGIN + RAISE_IT.TY.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TBB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TBB" ); + END TBB; + BEGIN + NULL; + END; + + RAISE_IT.TY.E; -- TY IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TB" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TB" ); + END TB; + + PACKAGE START_TC IS END START_TC; + + TASK BODY TX IS + BEGIN + FAILED ( "TX ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TX; + + PACKAGE START_TZ IS + TASK TZ IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TZ; + END START_TZ; + + PACKAGE BODY START_TC IS + TBREC1 : TBREC; -- CHECKS THAT TY TERMINATES. + + TASK TC IS -- CHECKS THAT TZ TERMINATES. + END TC; + + TASK BODY TC IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TCB + -- TERMINATES. + + TASK TCB IS + END TCB; + + TASK BODY TCB IS + BEGIN + START_TZ.TZ.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT " & + "ERROR - TCB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL " & + "EXCEPTION - TCB" ); + END TCB; + BEGIN + NULL; + END; + + START_TZ.TZ.E; -- TZ IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - TC" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TC" ); + END TC; + END START_TC; -- TBREC1 AND TC ACTIVATED HERE. + + PACKAGE BODY RAISE_IT IS + NTA : ATA := NEW TA; -- NTA.ALL ACTIVATED HERE. + + TASK BODY TY IS + BEGIN + FAILED ( "TY ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TY; + + PACKAGE XCEPTION IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + END XCEPTION; + + USE XCEPTION; + + BEGIN -- TY WOULD BE ACTIVATED HERE. + + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" ); + END IF; + END RAISE_IT; + + PACKAGE BODY START_TZ IS + TASK BODY TZ IS + BEGIN + FAILED ( "TZ ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TZ; + END START_TZ; -- TZ WOULD BE ACTIVATED HERE. + + BEGIN -- TX WOULD BE ACTIVATED HERE. + -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM. + + FAILED ( "EXCEPTION NOT RAISED" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ( "TASKING_ERROR IN MAIN PROGRAM" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + +END C93005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005c.ada b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada new file mode 100644 index 000000000..87322ee91 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada @@ -0,0 +1,250 @@ +-- C93005C.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 1: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE +-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); + +with Impdef; + +PACKAGE C93005C_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005C_PK1; + + +PACKAGE BODY C93005C_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005C_PK1; + +WITH REPORT, C93005C_PK1; +USE REPORT, C93005C_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005C IS + + +BEGIN + + TEST("C93005C", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 1: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); +B1: DECLARE + X : MNT; + BEGIN +B2: BEGIN +B3: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + M2 : ACC_MNT := NEW MNT; + + PACKAGE RAISES_EXCEPTION IS + T2 : UNACTIVATED; + M3 : ACC_MNT := NEW MNT; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION + END RAISES_EXCEPTION; + USE RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B3; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("SUBTEST 1 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B2"); + END B2; + END B1; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005d.ada b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada new file mode 100644 index 000000000..70925a1f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada @@ -0,0 +1,289 @@ +-- C93005D.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 2: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE +-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. +-- OTHER TASKS HAVE BEEN QUEUED ON THE TASKS' ENTRIES. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. +-- ADDED PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +with Impdef; + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005D_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005D_PK1; + + +PACKAGE BODY C93005D_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005D_PK1; + +WITH C93005D_PK1; USE C93005D_PK1; +PRAGMA ELABORATE (C93005D_PK1); +GENERIC + T1 : IN OUT UNACTIVATED; +PACKAGE C93005D_ENQUEUE IS + PROCEDURE REQUIRE_BODY; +END; + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C93005D_ENQUEUE IS + + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T1.E; + FAILED ("ENQUEUED CALLER DID NOT GET EXCEPTION"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED"); + END T3; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN -- T3 CALLS T1 HERE + DELAY 1.0 * Impdef.One_Second; -- ENSURE THAT T3 EXECUTES +END C93005D_ENQUEUE; + +WITH REPORT, C93005D_PK1, C93005D_ENQUEUE; +USE REPORT, C93005D_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005D IS + + +BEGIN + + TEST("C93005D", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 2: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); + COMMENT(" OTHER TASKS HAVE BEEN ENQUEUED ON THE TASKS' ENTRIES"); +B21: DECLARE + X : MNT; + BEGIN +B22: BEGIN +B23: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + Y : ACC_MNT := NEW MNT; + + PACKAGE HAS_UNACTIVATED IS + T2 : UNACTIVATED; + Z : ACC_MNT := NEW MNT; + PACKAGE ENQUEUE1 IS NEW C93005D_ENQUEUE(T1); + PACKAGE ENQUEUE2 IS NEW C93005D_ENQUEUE(T2); + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION. + -- TERMINATES T1 AND T2 AND INDIRECTLY THE 2 T3'S + END HAS_UNACTIVATED; + USE HAS_UNACTIVATED; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B23; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 2 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B22"); + END B22; + END B21; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005e.ada b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada new file mode 100644 index 000000000..c5d6e29e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada @@ -0,0 +1,247 @@ +-- C93005E.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 3: TASKS IN PACKAGE SPECIFICATION. +-- THE TASKS DON'T DEPEND ON THE PACKAGE SPECIFICATION. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005E_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005E_PK1; + +with Impdef; +PACKAGE BODY C93005E_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005E_PK1; + +WITH REPORT, C93005E_PK1; +USE REPORT, C93005E_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005E IS + + +BEGIN + + TEST("C93005E", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 3: TASK IN DECL PART OF PACKAGE SPEC"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B31: DECLARE + X : MNT; + BEGIN +B32: BEGIN +B33: DECLARE + PACKAGE RAISES_EXCEPTION IS + TYPE ACC_MNT IS ACCESS MNT; + Y : ACC_MNT := NEW MNT; + PTR : ACC_BAD_REC := NEW BAD_REC; + END RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B33; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 3 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B32"); + END B32; + END B31; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005f.ada b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada new file mode 100644 index 000000000..c6d6aeb17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada @@ -0,0 +1,255 @@ +-- C93005F.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 4: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DEPEND ON THE +-- DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. +-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005F_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005F_PK1; + +with Impdef; +PACKAGE BODY C93005F_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005F_PK1; + +WITH REPORT, C93005F_PK1; +USE REPORT, C93005F_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005F IS + + +BEGIN + + TEST("C93005F", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 4: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); +B41: DECLARE + X : MNT; + BEGIN +B42: DECLARE + TYPE LOCAL_ACC IS ACCESS BAD_REC; + Y : MNT; + PTR : LOCAL_ACC; + + TYPE ACC_MNT IS ACCESS MNT; + Z : ACC_MNT; + + BEGIN + Z := NEW MNT; + PTR := NEW BAD_REC; + IF PTR.I /= REPORT.IDENT_INT(0) THEN + FAILED ("EXCEPTION NOT RAISED, VALUE CHANGED"); + ELSE + FAILED ("EXCEPTION NOT RAISED, CONSTRAINT IGNORED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B42"); + END B42; + + COMMENT("SUBTEST 4: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B41; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005g.ada b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada new file mode 100644 index 000000000..c46a7309d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada @@ -0,0 +1,245 @@ +-- C93005G.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 5: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DON'T DEPEND +-- ON THE DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005G_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005G_PK1; + +with Impdef; +PACKAGE BODY C93005G_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005G_PK1; + +WITH REPORT, C93005G_PK1; +USE REPORT, C93005G_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005G IS + + +BEGIN + + TEST("C93005G", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 5: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B51: DECLARE + X : MNT; + BEGIN +B52: DECLARE + Y : MNT; + PTR : ACC_BAD_REC; + BEGIN + PTR := NEW BAD_REC; + FAILED ("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B52"); + END B52; + + COMMENT ("SUBTEST 5: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B51; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005h.ada b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada new file mode 100644 index 000000000..6641347b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada @@ -0,0 +1,250 @@ +-- C93005H.ADA + +-- 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. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 6: TASK IN STATEMENT PART OF PACKAGE AND THE TASKS DON'T DEPEND +-- ON THE PACKAGE SPECIFICATION. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005H_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005H_PK1; + +with Impdef; +PACKAGE BODY C93005H_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005H_PK1; + +WITH REPORT, C93005H_PK1; +USE REPORT, C93005H_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005H IS + + +BEGIN + + TEST("C93005H", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 6: TASK IN STATEMENT PART OF PACKAGE"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B61: DECLARE + X : MNT; + + PACKAGE P IS + Y : MNT; + END P; + + PACKAGE BODY P IS + PTR : ACC_BAD_REC; + Z : MNT; + BEGIN + PTR := NEW BAD_REC; + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN P"); + END P; + + BEGIN + COMMENT ("SUBTEST 6: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B61; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93006a.ada b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada new file mode 100644 index 000000000..81954f247 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada @@ -0,0 +1,69 @@ +-- C93006A.ADA + +-- 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. +--* +-- CHECK THAT A TASK OBJECT DECLARED IN A LIBRARY PACKAGE SPEC IS +-- ACTIVATED EVEN IF THE PACKAGE HAS NO BODY. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C93006A0 IS + TASK TYPE TT IS + ENTRY E; + END; +END C93006A0; + +PACKAGE BODY C93006A0 IS + TASK BODY TT IS + BEGIN + ACCEPT E; + END; +END C93006A0; + +WITH C93006A0; USE C93006A0; +PRAGMA ELABORATE(C93006A0); +PACKAGE C93006A1 IS + T : TT; +END C93006A1; + +with Impdef; +WITH REPORT, C93006A1, SYSTEM; +USE REPORT, C93006A1, SYSTEM; +PROCEDURE C93006A IS +BEGIN + + TEST("C93006A", "CHECK ACTIVATION OF TASK DECLARED IN PACKAGE " & + "SPECIFICATION"); + + SELECT + T.E; + OR + DELAY 60.0 * Impdef.One_Second; + FAILED("RENDEZVOUS NOT ACCEPTED WITHIN 60 SECONDS"); + END SELECT; + + RESULT; +END C93006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93007a.ada b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada new file mode 100644 index 000000000..9653d662e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada @@ -0,0 +1,113 @@ +-- C93007A.ADA + +-- 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 IF AN ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS +-- BODY HAS BEEN ELABORATED, THE TASK IS COMPLETED AND "PROGRAM_ +-- ERROR" (RATHER THAN "TASKING_ERROR") IS RAISED. + +-- HISTORY: +-- DHH 03/16/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C93007A IS + +BEGIN + + TEST("C93007A", "CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE " & + "A TASK BEFORE ITS BODY HAS BEEN ELABORATED, " & + "THE TASK IS COMPLETED AND ""PROGRAM_ERROR"" " & + "(RATHER THAN ""TASKING_ERROR"") IS RAISED"); + + DECLARE + TASK TYPE PROG_ERR IS + ENTRY START; + END PROG_ERR; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + PACKAGE P IS + OBJ : REC; + END P; + + PACKAGE BODY P IS + BEGIN + FAILED("EXCEPTION NOT RAISED - 1"); + OBJ.B.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + FAILED("EXCEPTION NOT RAISED - 2"); + OBJ.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("ACCESS TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("ACCESS UNEXPECTED EXCEPTION RAISED"); + END; + + TASK BODY PROG_ERR IS + BEGIN + ACCEPT START DO + IF TRUE THEN + COMMENT("IRRELEVANT"); + END IF; + END START; + END PROG_ERR; + BEGIN + NULL; + END; -- DECLARE + + RESULT; + +EXCEPTION + WHEN PROGRAM_ERROR => + FAILED("PROGRAM_ERROR RAISED AT INCORRECT POSITION"); + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + +END C93007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008a.ada b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada new file mode 100644 index 000000000..633d17dbc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada @@ -0,0 +1,108 @@ +-- C93008A.ADA + +-- 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. +--* +-- CHECK THAT FOR A TASK CREATED BY AN OBJECT DECLARATION, EXECUTION +-- DOES NOT PROCEED IN PARALLEL WITH ACTIVATION. + +-- R.WILLIAMS 8/20/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C93008A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK T IS + ENTRY FINIT_POS (DIGT : IN ARG); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT FINIT_POS (DIGT : IN ARG) DO + SPYNUMB := 10*SPYNUMB+DIGT; + END FINIT_POS; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + +BEGIN + + TEST ("C93008A", "CHECK THAT EXECUTION DOES NOT PROCEED IN " & + "PARALLEL WITH ACTIVATION OF A TASK CREATED " & + "BY AN OBJECT DECLARATION"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK TT2; + + T1 : TT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(1); + END DUMMY; + BEGIN + NULL; + END TT1; + + TASK BODY TT2 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(2); + END DUMMY; + BEGIN + NULL; + END TT2; + + + BEGIN -- TASKS ACTIVATED NOW. + + IF SPYNUMB = 12 OR SPYNUMB = 21 THEN + NULL; + ELSE + FAILED ("TASKS NOT ACTIVATED PROPERLY - SPYNUMB HAS " & + "ACTUAL VALUE OF: " & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + +END C93008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008b.ada b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada new file mode 100644 index 000000000..2853acd4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada @@ -0,0 +1,103 @@ +-- C93008B.ADA + +-- 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. +--* +-- CHECK THAT AFTER CREATION OF A TASK OBJECT BY AN ALLOCATOR, ANY +-- OPERATION INVOLVING THE RESULT DELIVERED BY THE ALLOCATOR IS +-- EXECUTED ONLY AFTER THE ACTIVATION OF THE TASK HAS COMPLETED. + +-- WEI 3/ 4/82 +-- TBN 12/20/85 RENAMED FROM C930AJA-B.ADA. ADDED DELAY STATEMENT +-- DURING TASK ACTIVATION. +-- RJW 4/11/86 ADDED PACKAGE DUMMY. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C93008B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + +BEGIN + + TEST ("C93008B", "USE OF RESULT AFTER CREATION OF " & + "A TASK BY ALLOCATOR"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + TYPE ARRAY_ATT1 IS ARRAY (NATURAL RANGE 2 .. 3) OF ATT1; + MY_ARRAY : ARRAY_ATT1; + POINTER_TT1 : ATT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + DECLARE + IDUMMY1 : NATURAL := FINIT_POS (1); + BEGIN + NULL; + END; + END DUMMY; + BEGIN + NULL; + END TT1; + + BEGIN + + MY_ARRAY := (2 => NEW TT1, 3 => NULL); -- TASK ACTIVATED NOW. + POINTER_TT1 := MY_ARRAY (FINIT_POS (2)); + + MY_ARRAY (FINIT_POS (3)) := POINTER_TT1; + + IF SPYNUMB /= 123 THEN + IF SPYNUMB = 132 OR SPYNUMB = 13 OR + SPYNUMB = 12 OR SPYNUMB = 1 OR + SPYNUMB = 0 + THEN + FAILED ("TASK ACTIVATION RIGHT IN TIME, " & + "BUT OTHER ERROR"); + ELSE + FAILED ("RESULT OF ALLOCATOR ACCESSED BEFORE " & + "TASK ACTIVATION HAS COMPLETED"); + END IF; + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + +END C93008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940001.a b/gcc/testsuite/ada/acats/tests/c9/c940001.a new file mode 100644 index 000000000..2bc1a9ffd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940001.a @@ -0,0 +1,212 @@ +-- C940001.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 protected object provides coordinated access to +-- shared data. Check that it can be used to sequence a number of tasks. +-- Use the protected object to control a single token for which three +-- tasks compete. Check that only one task is running at a time and that +-- all tasks get a chance to run sometime. +-- +-- TEST DESCRIPTION: +-- Declare a protected type with two entries. A task may call the Take +-- entry to get a token which allows it to continue processing. If it +-- has the token, it may call the Give entry to return it. The tasks +-- implement a discipline whereby only the task with the token may be +-- active. The test does not require any specific order for the tasks +-- to run. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Jul 96 SAIC Fixed spelling nits. +-- +--! + +package C940001_0 is + + type Token_Type is private; + True_Token : constant Token_Type; -- Create a deferred constant in order + -- to provide a component init for the + -- protected object + + protected type Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type); + entry Give (T : in out Token_Type); + private + Token : Token_Type := True_Token; + end Token_Mgr_Prot_Unit; + + function Init_Token return Token_Type; -- call to initialize an + -- object of Token_Type + function Token_Value (T : Token_Type) return Boolean; + -- call to inspect the value of an + -- object of Token_Type +private + type Token_Type is new boolean; + True_Token : constant Token_Type := true; +end C940001_0; + +--=================================================================-- + +package body C940001_0 is + protected body Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type) when Token = true is + begin -- Calling task will Take the token, so + T := Token; -- check first that token_mgr owns the + Token := false; -- token to give, then give it to caller + end Take; + + entry Give (T : in out Token_Type) when Token = false is + begin -- Calling task will Give the token back, + if T = true then -- so first check that token_mgr does not + Token := T; -- own the token, then check that the task has + T := false; -- the token to give, then take it from the + end if; -- task + -- if caller does not own the token, then + end Give; -- it falls out of the entry body with no + end Token_Mgr_Prot_Unit; -- action + + function Init_Token return Token_Type is + begin + return false; + end Init_Token; + + function Token_Value (T : Token_Type) return Boolean is + begin + return Boolean (T); + end Token_Value; + +end C940001_0; + +--===============================================================-- + +with Report; +with ImpDef; +with C940001_0; + +procedure C940001 is + + type TC_Int_Type is range 0..2; + -- range is very narrow so that erroneous execution may + -- raise Constraint_Error + + type TC_Artifact_Type is record + TC_Int : TC_Int_Type := 1; + Number_of_Accesses : integer := 0; + end record; + + TC_Artifact : TC_Artifact_Type; + + Sequence_Mgr : C940001_0.Token_Mgr_Prot_Unit; + + procedure Bump (Item : in out TC_Int_Type) is + begin + Item := Item + 1; + exception + when Constraint_Error => + Report.Failed ("Incremented without corresponding decrement"); + when others => + Report.Failed ("Bump raised Unexpected Exception"); + end Bump; + + procedure Decrement (Item : in out TC_Int_Type) is + begin + Item := Item - 1; + exception + when Constraint_Error => + Report.Failed ("Decremented without corresponding increment"); + when others => + Report.Failed ("Decrement raised Unexpected Exception"); + end Decrement; + + --==============-- + + task type Network_Node_Type; + + task body Network_Node_Type is + + Slot_for_Token : C940001_0.Token_Type := C940001_0.Init_Token; + + begin + + -- Ask for token - if request is not granted, task will be queued + Sequence_Mgr.Take (Slot_for_Token); + + -- Task now has token and may perform its work + + --==========================-- + -- in this case, the work is to ensure that the test results + -- are the expected ones! + --==========================-- + Bump (TC_Artifact.TC_Int); -- increment when request is granted + TC_Artifact.Number_Of_Accesses := + TC_Artifact.Number_Of_Accesses + 1; + if not C940001_0.Token_Value ( Slot_for_Token) then + Report.Failed ("Incorrect results from entry Take"); + end if; + + -- give a chance for other tasks to (incorrectly) run + delay ImpDef.Minimum_Task_Switch; + + Decrement (TC_Artifact.TC_Int); -- prepare to return token + + -- Task has completed its work and will return token + + Sequence_Mgr.Give (Slot_for_Token); -- return token to sequence manager + + if c940001_0.Token_Value (Slot_for_Token) then + Report.Failed ("Incorrect results from entry Give"); + end if; + + exception + when others => Report.Failed ("Unexpected exception raised in task"); + + end Network_Node_Type; + + --==============-- + +begin + + Report.Test ("C940001", "Check that a protected object can control " & + "tasks by coordinating access to shared data"); + + declare + Node_1, Node_2, Node_3 : Network_Node_Type; + -- declare three tasks which will compete for + -- a single token, managed by Sequence Manager + + begin -- tasks start + null; + end; -- wait for all tasks to terminate before reporting result + + if TC_Artifact.Number_of_Accesses /= 3 then + Report.Failed ("Not all tasks got through"); + end if; + + Report.Result; + +end C940001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940002.a b/gcc/testsuite/ada/acats/tests/c9/c940002.a new file mode 100644 index 000000000..420f54440 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940002.a @@ -0,0 +1,309 @@ +-- C940002.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 protected object provides coordinated access to shared +-- data. Check that it can implement a semaphore-like construct using a +-- parameterless procedure which allows a specific maximum number of tasks +-- to run and excludes all others +-- +-- TEST DESCRIPTION: +-- Implement a counting semaphore type that can be initialized to a +-- specific number of available resources. Declare an entry for +-- requesting a resource and a procedure for releasing it. Declare an +-- object of this type, initialized to two resources. Declare and start +-- three tasks each of which asks for a resource. Verify that only two +-- resources are granted and that the last task in is queued. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C940002_0 is + -- Semaphores + + protected type Semaphore_Type (Resources_Available : Integer :=1) is + entry Request; + procedure Release; + function Available return Integer; + private + Currently_Available : Integer := Resources_Available; + end Semaphore_Type; + + Max_Resources : constant Integer := 2; + Resource : Semaphore_Type (Max_Resources); + +end C940002_0; + -- Semaphores; + + + --========================================================-- + + +package body C940002_0 is + -- Semaphores + + protected body Semaphore_Type is + + entry Request when Currently_Available >0 is -- when granted, secures + begin -- a resource + Currently_Available := Currently_Available - 1; + end Request; + + procedure Release is -- when called, releases + begin -- a resource + Currently_Available := Currently_Available + 1; + end Release; + + function Available return Integer is -- returns number of + begin -- available resources + return Currently_Available; + end Available; + + end Semaphore_Type; + +end C940002_0; + -- Semaphores; + + + --========================================================-- + + +package C940002_1 is + -- Task_Pkg + + task type Requesting_Task is + entry Done; -- call on Done instructs the task + end Requesting_Task; -- to release resource + + type Task_Ptr is access Requesting_Task; + + protected Counter is + procedure Increment; + procedure Decrement; + function Number return integer; + private + Count : Integer := 0; + end Counter; + + protected Hold_Lock is + procedure Lock; + procedure Unlock; + function Locked return Boolean; + private + Lock_State : Boolean := true; -- starts out locked + end Hold_Lock; + + +end C940002_1; + -- Task_Pkg + + + --========================================================-- + + +with Report; +with C940002_0; + -- Semaphores; + +package body C940002_1 is + -- Task_Pkg is + + protected body Counter is + + procedure Increment is + begin + Count := Count + 1; + end Increment; + + procedure Decrement is + begin + Count := Count - 1; + end Decrement; + + function Number return Integer is + begin + return Count; + end Number; + + end Counter; + + + protected body Hold_Lock is + + procedure Lock is + begin + Lock_State := true; + end Lock; + + procedure Unlock is + begin + Lock_State := false; + end Unlock; + + function Locked return Boolean is + begin + return Lock_State; + end Locked; + + end Hold_Lock; + + + task body Requesting_Task is + begin + C940002_0.Resource.Request; -- request a resource + -- if resource is not available, + -- task will be queued to wait + Counter.Increment; -- add to count of resources obtained + Hold_Lock.Unlock; -- and unlock Lock - system is stable; + -- status may now be queried + + accept Done do -- hold resource until Done is called + C940002_0.Resource.Release; -- release the resource and + Counter.Decrement; -- note release + end Done; + + exception + when others => Report.Failed ("Unexpected Exception in Requesting_Task"); + end Requesting_Task; + +end C940002_1; + -- Task_Pkg; + + + --========================================================-- + + +with Report; +with ImpDef; +with C940002_0, + -- Semaphores, + C940002_1; + -- Task_Pkg; + +procedure C940002 is + + package Semaphores renames C940002_0; + package Task_Pkg renames C940002_1; + + Ptr1, + Ptr2, + Ptr3 : Task_Pkg.Task_Ptr; + Num : Integer; + + procedure Spinlock is + begin + -- loop until unlocked + while Task_Pkg.Hold_Lock.Locked loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Task_Pkg.Hold_Lock.Lock; + end Spinlock; + +begin + + Report.Test ("C940002", "Check that a protected record can be used to " & + "control access to resources"); + + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Wrong initial conditions"); + end if; + + Ptr1 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- One resource assigned to task 1 + -- One resource still available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Ptr2 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- Task 2 waiting for call to Done + -- Resources held by tasks 1 and 2 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + Ptr3 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be denied and task queued to wait for + -- next available resource + + + Ptr1.all.Done; -- Task 1 releases resource and lock + -- Resource should be given to queued task + Spinlock; -- ensure that resource is released + + + -- Task 1 holds no resource + -- One resource still assigned to task 2 + -- One resource assigned to task 3 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Ptr2.all.Done; -- Task 2 releases resource and lock + -- No outstanding request for resource + + -- Tasks 1 and 2 hold no resources + -- One resource assigned to task 3 + -- One resource available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Ptr3.all.Done; -- Task 3 releases resource and lock + + -- All resources released + -- All tasks terminated (or close) + -- Two resources available + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + Report.Result; + +end C940002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940004.a b/gcc/testsuite/ada/acats/tests/c9/c940004.a new file mode 100644 index 000000000..059c97f41 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940004.a @@ -0,0 +1,416 @@ +-- C940004.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 a protected record can be used to control access to +-- resources (data internal to the protected record). +-- +-- TEST DESCRIPTION: +-- Declare a resource descriptor tagged type. Extend the type and +-- use the extended type in a protected data structure. +-- Implement a binary semaphore type. Declare an entry for +-- requesting a specific resource and an procedure for releasing the +-- same resource. Declare an object of this (protected) type. +-- Declare and start three tasks each of which asks for a resource +-- when directed to. Verify that resources are properly allocated +-- and deallocated. +-- +-- +-- CHANGE HISTORY: +-- +-- 12 DEC 93 SAIC Initial PreRelease version +-- 23 JUL 95 SAIC Second PreRelease version +-- 16 OCT 95 SAIC ACVC 2.1 +-- 13 MAR 03 RLB Fixed race condition in test. +-- +--! + +package C940004_0 is +-- Resource_Pkg + + type ID_Type is new Integer range 0..10; + type User_Descriptor_Type is tagged record + Id : ID_Type := 0; + end record; + +end C940004_0; -- Resource_Pkg + +--============================-- +-- no body for C940004_0 +--=============================-- + +with C940004_0; -- Resource_Pkg + +-- This generic package implements a semaphore to control a single resource + +generic + + type Generic_Record_Type is new C940004_0.User_Descriptor_Type + with private; + +package C940004_1 is +-- Generic_Semaphore_Pkg + -- generic package extends the tagged formal generic + -- type with some implementation relevant details, and + -- it provides a semaphore with operations that work + -- on that type + type User_Rec_Type is new Generic_Record_Type with private; + + protected type Semaphore_Type is + function TC_Count return Integer; + entry Request (R : in out User_Rec_Type); + procedure Release (R : in out User_Rec_Type); + private + In_Use : Boolean := false; + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean; + +private + + type User_Rec_Type is new Generic_Record_Type with record + Access_To_Resource : boolean := false; + end record; + +end C940004_1; -- Generic_Semaphore_Pkg + +--===================================================-- + +package body C940004_1 is +-- Generic_Semaphore_Pkg + + protected body Semaphore_Type is + + function TC_Count return Integer is + begin + return Request'Count; + end TC_Count; + + entry Request (R : in out User_Rec_Type) + when not In_Use is + begin + In_Use := true; + R.Access_To_Resource := true; + end Request; + + procedure Release (R : in out User_Rec_Type) is + begin + In_Use := false; + R.Access_To_Resource := false; + end Release; + + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean is + begin + return R.Access_To_Resource; + end Has_Access; + +end C940004_1; -- Generic_Semaphore_Pkg + +--=============================================-- + +with Report; +with C940004_0; -- Resource_Pkg, +with C940004_1; -- Generic_Semaphore_Pkg; + +package C940004_2 is +-- Printer_Mgr_Pkg + + -- Instantiate the generic to get code to manage a single printer; + -- User processes contend for the printer, asking for it by a call + -- to Request, and relinquishing it by a call to Release + + -- This package extends a tagged type to customize it for the printer + -- in question, then it uses the type to instantiate the generic and + -- declare a semaphore specific to the particular resource + + package Resource_Pkg renames C940004_0; + + type User_Desc_Type is new Resource_Pkg.User_Descriptor_Type with record + New_Details : Integer := 0; -- for example + end record; + + package Instantiation is new C940004_1 -- Generic_Semaphore_Pkg + (Generic_Record_Type => User_Desc_Type); + + Printer_Access_Mgr : Instantiation.Semaphore_Type; + + +end C940004_2; -- Printer_Mgr_Pkg + +--============================-- +-- no body for C940004_2 +--============================-- + +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg; + +package C940004_3 is +-- User_Task_Pkg + +-- This package models user tasks that will request and release +-- the printer + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + + task type User_Task_Type (ID : Resource_Pkg.ID_Type) is + entry Get_Printer; -- instructs task to request resource + + entry Release_Printer -- instructs task to release printer + (Descriptor : in out Printer_Mgr_pkg.Instantiation.User_Rec_Type); + + --==================-- + -- Test management machinery + --==================-- + entry TC_Get_Descriptor -- returns descriptor + (Descriptor : out Printer_Mgr_Pkg.Instantiation.User_Rec_Type); + + end User_Task_Type; + + --==================-- + -- Test management machinery + --==================-- + TC_Times_Obtained : Integer := 0; + TC_Times_Released : Integer := 0; + +end C940004_3; -- User_Task_Pkg; + +--==============================================-- + +with Report; +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg, + +package body C940004_3 is +-- User_Task_Pkg + + task body User_Task_Type is + D : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + begin + D.Id := ID; + ----------------------------------- + Main: + loop + select + accept Get_Printer; + Printer_Mgr_Pkg.Printer_Access_Mgr.Request (D); + -- request resource; if resource is not available, + -- task will be queued to wait + --===================-- + -- Test management machinery + --===================-- + TC_Times_Obtained := TC_Times_Obtained + 1; + -- when request granted, note it and post a message + + or + accept Release_Printer (Descriptor : in out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Printer_Mgr_Pkg.Printer_Access_Mgr.Release (D); + -- release the resource, note its release + TC_Times_Released := TC_Times_Released + 1; + Descriptor := D; + end Release_Printer; + exit Main; + + or + accept TC_Get_Descriptor (Descriptor : out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Descriptor := D; + end TC_Get_Descriptor; + + end select; + end loop main; + + exception + when others => Report.Failed ("exception raised in User_Task"); + end User_Task_Type; + +end C940004_3; -- User_Task_Pkg; + +--==========================================================-- + +with Report; +with ImpDef; + +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg, +with C940004_3; -- User_Task_Pkg; + +procedure C940004 is + Verbose : constant Boolean := False; + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + package User_Task_Pkg renames C940004_3; + + Task1 : User_Task_Pkg.User_Task_Type (1); + Task2 : User_Task_Pkg.User_Task_Type (2); + Task3 : User_Task_Pkg.User_Task_Type (3); + + User_Rec_1, + User_Rec_2, + User_Rec_3 : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + +begin + + Report.Test ("C940004", "Check that a protected record can be used to " & + "control access to resources"); + + if (User_Task_Pkg.TC_Times_Obtained /= 0) + or (User_Task_Pkg.TC_Times_Released /= 0) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Get_Printer; -- ask for resource + -- request for resource should be granted + Task1.TC_Get_Descriptor (User_Rec_1);-- wait here 'til task gets resource + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task queued to wait + + -- Task 1 still waiting to accept Release_Printer, still holds resource + -- Task 2 queued on Semaphore.Request + + -- Ensure that Task2 is queued before continuing to make checks and queue + -- Task3. We use a for loop here to avoid hangs in broken implementations. + for TC_Cnt in 1 .. 20 loop + exit when Printer_Mgr_Pkg.Printer_Access_Mgr.TC_Count >= 1; + delay Impdef.Minimum_Task_Switch; + end loop; + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) then + Report.Failed ("Resource assigned to task 2"); + end if; + + Task3.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task 3 queued on Semaphore.Request + + Task1.Release_Printer (User_Rec_1);-- task 1 releases resource + -- released resource should be given to + -- queued task 2. + + Task2.TC_Get_Descriptor (User_Rec_2);-- wait here for task 2 + + -- Task 1 has released resource and completed + -- Task 2 has seized the resource + -- Task 3 is queued on Semaphore.Request + + if (User_Task_Pkg.TC_Times_Obtained /= 2) + or (User_Task_Pkg.TC_Times_Released /= 1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) then + Report.Failed ("Resource not properly released/assigned" & + " to task 2"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + end if; + end if; + + Task2.Release_Printer (User_Rec_2);-- task 2 releases resource + + -- task 3 is released from queue, and is given resource + + Task3.TC_Get_Descriptor (User_Rec_3);-- wait for task 3 + + if (User_Task_Pkg.TC_Times_Obtained /= 3) + or (User_Task_Pkg.TC_Times_Released /= 2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released/assigned " & + "to task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + end if; + + Task3.Release_Printer (User_Rec_3);-- task 3 releases resource + + if (User_Task_Pkg.TC_Times_Obtained /=3) + or (User_Task_Pkg.TC_Times_Released /=3) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released by task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + + end if; + + -- Ensure that all tasks have terminated before reporting the result + while not (Task1'terminated + and Task2'terminated + and Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C940004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940005.a b/gcc/testsuite/ada/acats/tests/c9/c940005.a new file mode 100644 index 000000000..47a97bf2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940005.a @@ -0,0 +1,370 @@ +-- C940005.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 the body of a protected function can have internal calls +-- to other protected functions and that the body of a protected +-- procedure can have internal calls to protected procedures and to +-- protected functions. +-- +-- TEST DESCRIPTION: +-- Simulate a meter at a freeway on-ramp which, when real-time sensors +-- determine that the freeway is becoming saturated, triggers stop lights +-- which control the access of vehicles to prevent further saturation. +-- Each on-ramp is represented by a protected object - in this case only +-- one is shown (Test_Ramp). The routines to sample and alter the states +-- of the various sensors, to queue the vehicles on the meter and to +-- release them are all part of the protected object and can be shared +-- by various tasks. Apart from the function/procedure tests this example +-- has a mix of other tasking features. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1 +-- +--! + + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C940005 is + +begin + + Report.Test ("C940005", "Check internal calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Multiplier : integer := 1; -- changed half way through + TC_Expected_Passage_Total : constant integer := 486; + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task; + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier task. One is created for each vehicle arriving at the ramp + task type Vehicle; + type acc_Vehicle is access Vehicle; + + --================================================================ + protected Test_Ramp is + function Next_Ramp_in_Overload return Load_Factor; + function Local_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + function Freeway_Breakdown return Boolean; + function Meter_in_use_State return Boolean; + procedure Set_Local_Overload; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + -- ::::::::: many routines are not shown (for example none of the + -- clears, none of the real-time-sensor handlers) + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := false; + Fwy_Break_State : Boolean := false; + + + Ramp_Count : integer range 0..20 := 0; + Ramp_Count_Threshold : integer := 15; + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + Next_Ramp_State : Load_Factor := Clear_Level; + -- :::: other Sample Point states not shown + + TC_Passage_Total : integer := 0; + end Test_Ramp; + --================================================================ + protected body Test_Ramp is + + procedure Start_Meter is + begin + Meter_in_Use := True; + null; -- stub :::: trigger the metering hardware + end Start_Meter; + + -- External call for Meter_in_Use + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload is + begin + Local_State := Local_Overload_wt; + if not Meter_in_Use then + Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE + end if; + end Set_Local_Overload; + + --::::: Set/Clear routines for all the other sensors not shown + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + function Next_Ramp_in_Overload return Load_Factor is + begin + return Next_Ramp_State; + end Next_Ramp_in_Overload; + + -- :::::::: other overload factor states not shown + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload -- EACH IS A CALL OF A + -- + :::: others -- FUNCTION FROM WITHIN + + Next_Ramp_in_Overload; -- A FUNCTION + end Freeway_Overload; + + -- Freeway Breakdown is defined as traffic moving < 5mph + function Freeway_Breakdown return Boolean is + begin + return Fwy_Break_State; + end Freeway_Breakdown; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + TC_Pass_Point : constant integer := 22; + begin + Ramp_Count := Ramp_Count + 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_Count > Ramp_Count_Threshold then + null; -- :::: stub, trigger surface street notification + end if; + end Add_Meter_Queue; + -- + procedure Subtract_Meter_Queue is + TC_Pass_Point : constant integer := 24; + begin + Ramp_Count := Ramp_Count - 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + TC_Pass_Point : constant integer := 23; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL + -- FUNCTION + -- FROM WITHIN PROCEDURE + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Test_Ramp; + --================================================================ + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival is + Next_Vehicle_Task: acc_Vehicle := new Vehicle; + TC_Pass_Point : constant integer := 3; + begin + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; + end New_arrival; + + + -- Carrier task. One is created for each vehicle arriving at the ramp + task body Vehicle is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Test_Ramp.Meter_in_Use_State then + Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Test_Ramp.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Test_Ramp.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Test_Ramp.TC_Passage ( TC_Pass_Point_3 ); -- note passage thru here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + begin + While not Control.Stop loop + delay until Pulse_Time; + Test_Ramp.Time_Pulse_Received; -- causes INTERNAL CALLS + -- :::::::::: and to all the others + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- First simulate calls to the protected functions and procedures + -- from without the protected object + -- + -- CALL FUNCTIONS + if Test_Ramp.Local_Overload /= Clear_Level then + Report.Failed ("External Call to Local_Overload incorrect"); + end if; + if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then + Report.Failed ("External Call to Next_Ramp_in_Overload incorrect"); + end if; + if Test_Ramp.Freeway_Overload /= Clear_Level then + Report.Failed ("External Call to Freeway_Overload incorrect"); + end if; + + -- Now Simulate the arrival of a vehicle to verify path through test + New_Arrival; + delay Pulse_Time_Delta*2; -- allow it to pass through the complex + + TC_Multiplier := 5; -- change the weights for the paths for the next + -- part of the test + + -- Simulate a real-time sensor reporting overload + Test_Ramp.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + + -- CALL FUNCTIONS again + if Test_Ramp.Local_Overload /= Minimum_Level then + Report.Failed ("External Call to Local_Overload incorrect - 2"); + end if; + if Test_Ramp.Freeway_Overload /= Minimum_Level then + Report.Failed ("External Call to Freeway_Overload incorrect -2"); + end if; + + -- Now Simulate the arrival of another vehicle again causing + -- INTERNAL CALLS but following different paths (queuing on the + -- meter etc.) + New_Arrival; + delay Pulse_Time_Delta*2; -- allow it to pass through the complex + + Control.Stop_Now; -- finish test + + if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + Report.Result; + +end C940005; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940006.a b/gcc/testsuite/ada/acats/tests/c9/c940006.a new file mode 100644 index 000000000..36e6c9171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940006.a @@ -0,0 +1,223 @@ +-- C940006.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 the body of a protected function can have external calls +-- to other protected functions and that the body of a protected +-- procedure can have external calls to protected procedures and to +-- protected functions. +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case two protected objects are used but only a +-- minimum of routines are shown in each. Both objects are hard coded +-- and detail two adjacent on-ramps (Ramp_31 & Ramp_32) with routines in +-- each which use external calls to the other. + +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; + +procedure C940006 is + +begin + + Report.Test ("C940006", "Check external calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + -- + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 3; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_31 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + procedure Downstream_Ramps; + function Get_DSR_Accumulate return Load_Factor; + + private + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + -- Accumulated load for next three downstream ramps + DSR_Accumulate : Load_Factor := Clear_Level; + + end Ramp_31; + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_32 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + + private + + Local_State : Load_Factor := Clear_Level; + + end Ramp_32; + --================================================================ + protected body Ramp_31 is + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload (Sensor_Level : Load_Factor) is + begin + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + null; --::::: (see Ramp_32 for this code) + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_32.Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload + -- + :::: others + + Next_Ramp_Overload; + end Freeway_Overload; + + -- Snapshot the states of the next three downstream ramps + procedure Downstream_Ramps is + begin + DSR_Accumulate := Ramp_32.Local_Overload; -- EXTERNAL FUNCTION + -- :::: + Ramp_33.Local_Overload -- FROM PROCEDURE + -- :::: + Ramp_34.Local_Overload + end Downstream_Ramps; + + -- Get last snapshot + function Get_DSR_Accumulate return Load_Factor is + begin + return DSR_Accumulate; + end Get_DSR_Accumulate; + + end Ramp_31; + --================================================================ + protected body Ramp_32 is + + function Local_Overload return Load_Factor is + begin + return Local_State; + end; + + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_31.Notify; + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + end Ramp_32; + --================================================================ + + + + begin -- declare + + -- Test driver. This is ALL test control code + -- Simulate calls to the protected functions and procedures + -- from without the protected object, these will, in turn make the + -- external calls. + + -- Check initial conditions, exercising the simple calls + if not (Ramp_31.Local_Overload = Clear_Level and + Ramp_31.Next_Ramp_Overload = Clear_Level and + Ramp_31.Freeway_Overload = Clear_Level) and + Ramp_32.Local_Overload = Clear_Level then + Report.Failed ("Initial Calls provided unexpected Results"); + end if; + + -- Simulate real-time sensors reporting overloads at a hardware level + Ramp_31.Set_Local_Overload (1); + Ramp_32.Set_Local_Overload (3); + + Ramp_31.Downstream_Ramps; -- take the current snapshot + + if not (Ramp_31.Local_Overload = Minimum_Level and + Ramp_31.Get_DSR_Accumulate = Moderate_Level and + Ramp_31.Freeway_Overload = Serious_Level) then + Report.Failed ("Secondary Calls provided unexpected Results"); + end if; + + end; -- declare + + Report.Result; + +end C940006; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a new file mode 100644 index 000000000..41e80f4e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940007.a @@ -0,0 +1,427 @@ +-- C940007.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 the body of a protected function declared as an object of a +-- given type can have internal calls to other protected functions and +-- that a protected procedure in such an object can have internal calls +-- to protected procedures and to protected functions. +-- +-- TEST DESCRIPTION: +-- Simulate a meter at a freeway on-ramp which, when real-time sensors +-- determine that the freeway is becoming saturated, triggers stop lights +-- which control the access of vehicles to prevent further saturation. +-- Each on-ramp is represented by a protected object of the type Ramp. +-- The routines to sample and alter the states of the various sensors, to +-- queue the vehicles on the meter and to release them are all part of +-- the protected object and can be shared by various tasks. Apart from +-- the function/procedure tests this example has a mix of other tasking +-- features. In this test two objects representing two adjacent ramps +-- are created from the same type. The same "traffic" is simulated for +-- each ramp. The results should be identical. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop +-- with a protected object. +-- ACVC 2.0.1 +-- +--! + + +with Report; +with ImpDef; +with Ada.Calendar; + + +procedure C940007 is + +begin + + Report.Test ("C940007", "Check internal calls of protected functions" & + " and procedures in objects declared as a type"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Expected_Passage_Total : integer := 486; + + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task; + + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + -- + task type Vehicle_32; -- For Ramp_32 + type acc_Vehicle_32 is access Vehicle_32; + + --================================================================ + protected type Ramp is + function Next_Ramp_in_Overload return Load_Factor; + function Local_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + function Freeway_Breakdown return Boolean; + function Meter_in_Use_State return Boolean; + procedure Set_Local_Overload; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + -- ::::::::: many routines are not shown (for example none of the + -- clears, none of the real-time-sensor handlers) + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := false; + Fwy_Break_State : Boolean := false; + + + Ramp_Count : integer range 0..20 := 0; + Ramp_Count_Threshold : integer := 15; + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + Next_Ramp_State : Load_Factor := Clear_Level; + -- :::: other Sample Point states not shown + + TC_Multiplier : integer := 1; -- changed half way through + TC_Passage_Total : integer := 0; + end Ramp; + --================================================================ + protected body Ramp is + + procedure Start_Meter is + begin + Meter_in_Use := True; + null; -- stub :::: trigger the metering hardware + end Start_Meter; + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload is + begin + Local_State := Local_Overload_wt; + if not Meter_in_Use then + Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE + end if; + -- Change the weights for the paths for the next part of the test + TC_Multiplier :=5; + end Set_Local_Overload; + + --::::: Set/Clear routines for all the other sensors not shown + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + function Next_Ramp_in_Overload return Load_Factor is + begin + return Next_Ramp_State; + end Next_Ramp_in_Overload; + + -- :::::::: other overload factor states not shown + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload -- EACH IS A CALL OF A + -- + :::: others -- FUNCTION FROM WITHIN + + Next_Ramp_in_Overload; -- A FUNCTION + end Freeway_Overload; + + -- Freeway Breakdown is defined as traffic moving < 5mph + function Freeway_Breakdown return Boolean is + begin + return Fwy_Break_State; + end Freeway_Breakdown; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + TC_Pass_Point : constant integer := 22; + begin + Ramp_Count := Ramp_Count + 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_Count > Ramp_Count_Threshold then + null; -- :::: stub, trigger surface street notification + end if; + end Add_Meter_Queue; + -- + procedure Subtract_Meter_Queue is + TC_Pass_Point : constant integer := 24; + begin + Ramp_Count := Ramp_Count - 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + TC_Pass_Point : constant integer := 23; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL FUNCTN + -- FROM WITHIN PROCEDURE + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Ramp; + --================================================================ + + -- Now create two Ramp objects from this type + Ramp_31 : Ramp; + Ramp_32 : Ramp; + + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 3; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_31.Meter_in_Use_State then + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival_32 is + Next_Vehicle_Task_32 : acc_Vehicle_32 := new Vehicle_32; + TC_Pass_Point : constant integer := 3; + begin + Ramp_32.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_32; + + + -- Carrier task. One is created for each vehicle arriving at Ramp_32 + task body Vehicle_32 is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Ramp_32.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_32.Meter_in_Use_State then + Ramp_32.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Ramp_32.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Ramp_32.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Ramp_32.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_32; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + begin + While not Control.Stop loop + delay until Pulse_Time; + Ramp_31.Time_Pulse_Received; -- CALL OF PROCEDURE CAUSES + Ramp_32.Time_Pulse_Received; -- INTERNAL CALLS + -- :::::::::: and to all the others + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- First simulate calls to the protected functions and procedures + -- from without the protected object + -- + -- CALL FUNCTIONS + if not ( Ramp_31.Local_Overload = Clear_Level and + Ramp_31.Next_Ramp_in_Overload = Clear_Level and + Ramp_31.Freeway_Overload = Clear_Level ) then + Report.Failed ("Initial Calls to Ramp_31 incorrect"); + end if; + if not ( Ramp_32.Local_Overload = Clear_Level and + Ramp_32.Next_Ramp_in_Overload = Clear_Level and + Ramp_32.Freeway_Overload = Clear_Level ) then + Report.Failed ("Initial Calls to Ramp_32 incorrect"); + end if; + + -- Now Simulate the arrival of a vehicle at each ramp to verify + -- basic paths through the test + New_Arrival_31; + New_Arrival_32; + delay Pulse_Time_Delta*2; -- allow them to pass through the complex + + -- Simulate real-time sensors reporting overload + Ramp_31.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + Ramp_32.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + + -- CALL FUNCTIONS again + if not ( Ramp_31.Local_Overload = Minimum_Level and + Ramp_31.Freeway_Overload = Minimum_Level ) then + Report.Failed ("Secondary Calls to Ramp_31 incorrect"); + end if; + if not ( Ramp_32.Local_Overload = Minimum_Level and + Ramp_32.Freeway_Overload = Minimum_Level ) then + Report.Failed ("Secondary Calls to Ramp_32 incorrect"); + end if; + + -- Now Simulate the arrival of another vehicle at each ramp again causing + -- INTERNAL CALLS but following different paths (queuing on the + -- meter etc.) + New_Arrival_31; + New_Arrival_32; + delay Pulse_Time_Delta*2; -- allow them to pass through the complex + + Control.Stop_Now; -- finish test + + if not (TC_Expected_Passage_Total = Ramp_31.TC_Get_Passage_Total and + TC_Expected_Passage_Total = Ramp_32.TC_Get_Passage_Total) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + Report.Result; + +end C940007; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940010.a b/gcc/testsuite/ada/acats/tests/c9/c940010.a new file mode 100644 index 000000000..c4a670552 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940010.a @@ -0,0 +1,269 @@ +-- C940010.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 if an exception is raised during the execution of an +-- entry body it is propagated back to the caller +-- +-- TEST DESCRIPTION: +-- Use a small fragment of code from the simulation of a freeway meter +-- used in c940007. Create three individual tasks which will be queued on +-- the entry as the barrier is set. Release them one at a time. A +-- procedure which is called within the entry has been modified for this +-- test to raise a different exception for each pass through. Check that +-- all expected exceptions are raised and propagated. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C940010 is + + TC_Failed_1 : Boolean := false; + +begin + + Report.Test ("C940010", "Check that an exception raised in an entry " & + "body is propagated back to the caller"); + + declare -- encapsulate the test + + TC_Defined_Error : Exception; -- User defined exception + TC_Expected_Passage_Total : constant integer := 669; + TC_Int : constant integer := 5; + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + + + --================================================================ + protected Ramp_31 is + + function Meter_in_Use_State return Boolean; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + entry Wait_at_Meter; + procedure Pulse; + -- + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Current_Exception return integer; + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := true; -- TC: set true for this test + -- + TC_Multiplier : integer := 1; + TC_Passage_Total : integer := 0; + -- Use this to cycle through the required exceptions + TC_Current_Exception : integer range 0..3 := 0; + + end Ramp_31; + --================================================================ + protected body Ramp_31 is + + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Current_Exception return integer is + begin + return TC_Current_Exception; + end TC_Get_Current_Exception; + + + ----------------- + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Simulate the effects of the regular signal pulse + procedure Pulse is + begin + Release_one_Vehicle := true; + end Pulse; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + begin + null; --::: stub + end Add_Meter_Queue; + + -- TC: This routine has been modified to raise the required + -- exceptions + procedure Subtract_Meter_Queue is + TC_Pass_Point1 : constant integer := 10; + TC_Pass_Point2 : constant integer := 20; + TC_Pass_Point3 : constant integer := 30; + TC_Pass_Point9 : constant integer := 1000; -- error + begin + -- Cycle through the required exceptions, one per call + TC_Current_Exception := TC_Current_Exception + 1; + case TC_Current_Exception is + when 1 => + TC_Passage (TC_Pass_Point1); -- note passage through here + raise Storage_Error; -- PREDEFINED EXCEPTION + when 2 => + TC_Passage (TC_Pass_Point2); -- note passage through here + raise TC_Defined_Error; -- USER DEFINED EXCEPTION + when 3 => + TC_Passage (TC_Pass_Point3); -- note passage through here + -- RUN TIME EXCEPTION (Constraint_Error) + -- Add the value 3 to 5 then try to assign it to an object + -- whose range is 0..3 - this causes the exception. + -- Disguise the values which cause the Constraint_Error + -- so that the optimizer will not eliminate this code + -- Note: the variable is checked at the end to ensure + -- that the actual assignment is attempted. Also note + -- the value remains at 3 as the assignment does not + -- take place. This is the value that is checked at + -- the end of the test. + -- Otherwise the optimizer could decide that the result + -- of the assignment was not used so why bother to do it? + TC_Current_Exception := + Report.Ident_Int (TC_Current_Exception) + + Report.Ident_Int (TC_Int); + when others => + -- Set flag for Report.Failed which cannot be called from + -- within a Protected Object + TC_Failed_1 := True; + end case; + + TC_Passage ( TC_Pass_Point9 ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- Example of entry with barriers and persistent signal + TC_Pass_Point : constant integer := 2; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- Call procedure from within entry body + end Wait_at_Meter; + + end Ramp_31; + --================================================================ + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_Point_1 : constant integer := 100; + TC_Pass_Point_2 : constant integer := 200; + TC_Pass_Point_3 : constant integer := 300; + begin + if Ramp_31.Meter_in_Use_State then + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- Call a protected procedure + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- Call a protected entry + Report.Failed ("Exception not propagated back"); + end if; + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when Storage_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage + when TC_Defined_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + when Constraint_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 1; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Create three independent tasks which will queue themselves on the + -- entry. Each task will get a different exception + New_Arrival_31; + New_Arrival_31; + New_Arrival_31; + + delay ImpDef.Clear_Ready_Queue; + + -- Set the barrier condition of the entry true, releasing one task + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or + -- Note: We are not really interested in this next check. It is + -- here to ensure the earlier statements which raised the + -- Constraint_Error are not optimized out + (Ramp_31.TC_Get_Current_Exception /= 3) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Bad path through Subtract_Meter_Queue"); + end if; + + Report.Result; + +end C940010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940011.a b/gcc/testsuite/ada/acats/tests/c9/c940011.a new file mode 100644 index 000000000..65228666c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940011.a @@ -0,0 +1,175 @@ +-- C940011.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, in the body of a protected object created by the execution +-- of an allocator, external calls to other protected objects via +-- the access type are correctly performed +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case an array of access types is built with pointers +-- to successive ramps. The external calls within the protected +-- objects are made via the index into the array. Routines which refer +-- to the "previous" ramp and the "next" ramp are exercised. (Note: The +-- first and last ramps are assumed to be dummies and no first/last +-- condition code is included) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; + + +procedure C940011 is + + type Ramp; + type acc_Ramp is access Ramp; + + subtype Ramp_Index is integer range 1..4; + + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp is + + procedure Set_Index (Index : Ramp_Index); + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + function Local_Overload return Load_Factor; + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + + private + + This_Ramp : Ramp_Index; + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + + -- Build a set of Ramp objects and an array of pointers to them + -- + Ramp_Array : array (Ramp_Index) of acc_Ramp := (Ramp_Index => new Ramp); + + --================================================================ + protected body Ramp is + + procedure Set_Index (Index : Ramp_Index) is + begin + This_Ramp := Index; + end Set_Index; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_Array(This_Ramp - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_Array(This_Ramp + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + + --================================================================ + + +begin + + + Report.Test ("C940011", "Protected Objects created by allocators: " & + "external calls via access types"); + + -- Initialize each Ramp + for i in Ramp_Index loop + Ramp_Array(i).Set_Index (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + Report.Result; + +end C940011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940012.a b/gcc/testsuite/ada/acats/tests/c9/c940012.a new file mode 100644 index 000000000..d4bd2079c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940012.a @@ -0,0 +1,174 @@ +-- C940012.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 protected object can have discriminants +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case an array of access types is built with pointers +-- to successive ramps. Each ramp has its Ramp_Number specified by +-- discriminant and this corresponds to the index in the array. The test +-- checks that the ramp numbers are assigned as expected then uses calls +-- to procedures within the objects (ramps) to verify external calls to +-- ensure the structures are valid. The external references within the +-- protected objects are made via the index into the array. Routines +-- which refer to the "previous" ramp and the "next" ramp are exercised. +-- (Note: The first and last ramps are assumed to be dummies and no +-- first/last condition code is included) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; + + +procedure C940012 is + + type Ramp_Index is range 1..4; + + type Ramp; + type a_Ramp is access Ramp; + + Ramp_Array : array (Ramp_Index) of a_Ramp; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp (Ramp_In : Ramp_Index) is + + function Ramp_Number return Ramp_Index; + function Local_Overload return Load_Factor; + function Next_Ramp_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + + private + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + protected body Ramp is + + function Ramp_Number return Ramp_Index is + begin + return Ramp_In; + end Ramp_Number; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + Ramp_Array(Ramp_In - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- Get next ramp's current state + return Ramp_Array(Ramp_In + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + --================================================================ + +begin + + + Report.Test ("C940012", "Check that a protected object " & + "can have discriminants"); + + -- Build the ramps and populate the ramp array + for i in Ramp_Index loop + Ramp_Array(i) := new Ramp (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Check the assignment of the index + for i in Ramp_Index loop + if Ramp_Array(i).Ramp_Number /= i then + Report.Failed ("Ramp_Number assignment incorrect"); + end if; + end loop; + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + + Report.Result; + +end C940012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940013.a b/gcc/testsuite/ada/acats/tests/c9/c940013.a new file mode 100644 index 000000000..58d34bc96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940013.a @@ -0,0 +1,379 @@ +-- C940013.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 items queued on a protected entry are handled FIFO and that +-- the 'count attribute of that entry reflects the length of the queue. +-- +-- TEST DESCRIPTION: +-- Use a small subset of the freeway ramp simulation shown in other +-- tests. With the timing pulse off (which prevents items from being +-- removed from the queue) queue up a small number of calls. Start the +-- timing pulse and, at the first execution of the entry code, check the +-- 'count attribute. Empty the queue. Pass the items being removed from +-- the queue to the Ramp_Sensor_01 task; there check that the items are +-- arriving in FIFO order. Check the final 'count value +-- +-- Send another batch of items at a rate which will, if the delay timing +-- of the implementation is reasonable, cause the queue length to +-- fluctuate in both directions. Again check that all items arrive +-- FIFO. At the end check that the 'count returned to zero reflecting +-- the empty queue. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C940013 is + + TC_Failed_1 : Boolean := false; + +begin + + Report.Test ("C940013", "Check that queues on protected entries are " & + "handled FIFO and that 'count is correct"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + TC_Expected_Passage_Total : constant integer := 624; + + -- For this test give each vehicle an integer ID incremented + -- by one for each successive vehicle. In reality this would be + -- a more complex alpha-numeric ID assigned at pickup time. + type Vehicle_ID is range 1..5000; + Next_ID : Vehicle_ID := Vehicle_ID'first; + + -- In reality this would be about 5 seconds. The default value of + -- this constant in the implementation defined package is similar + -- but could, of course be considerably different - it would not + -- affect the test + -- + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier task. One is created for each vehicle arriving at the ramp + task type Vehicle is + entry Get_ID (Input_ID : in Vehicle_ID); + end Vehicle; + type acc_Vehicle is access Vehicle; + + task Ramp_Sensor_01 is + entry Accept_Vehicle (Input_ID : in Vehicle_ID); + entry TC_First_Three_Handled; + entry TC_All_Done; + end Ramp_Sensor_01; + + protected Pulse_State is + procedure Start_Pulse; + procedure Stop_Pulse; + function Pulsing return Boolean; + private + State : Boolean := false; -- start test will pulse off + end Pulse_State; + + protected body Pulse_State is + + procedure Start_Pulse is + begin + State := true; + end Start_Pulse; + + procedure Stop_Pulse is + begin + State := false; + end Stop_Pulse; + + function Pulsing return Boolean is + begin + return State; + end Pulsing; + + end Pulse_State; + + --================================================================ + protected Test_Ramp is + + function Meter_in_use_State return Boolean; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Count return integer; + + private + + Release_One_Vehicle : Boolean := false; + -- For this test have Meter_in_Use already set + Meter_in_Use : Boolean := true; + + TC_Wait_at_Meter_First : Boolean := true; + TC_Entry_Queue_Count : integer := 0; -- 'count of Wait_at_Meter + TC_Passage_Total : integer := 0; + TC_Pass_Point_WAM : integer := 23; + + end Test_Ramp; + --================================================================ + protected body Test_Ramp is + + -- External call for Meter_in_Use + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totalling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total + Pass_Point; + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Count return integer is + begin + return TC_Entry_Queue_Count; + end TC_Get_Count; + + + -- Here each Vehicle task queues itself awaiting release + -- + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + begin + -- + TC_Passage ( TC_Pass_Point_WAM ); -- note passage + -- For this test three vehicles are queued before the first + -- is released. If the queueing mechanism is working correctly + -- the first time we pass through here the entry'count should + -- reflect this + if TC_Wait_at_Meter_First then + if Wait_at_Meter'count /= 2 then + TC_Failed_1 := true; + end if; + TC_Wait_at_Meter_First := false; + end if; + TC_Entry_Queue_Count := Wait_at_Meter'count; -- note for later + + Release_One_Vehicle := false; -- Consume the signal + null; -- stub ::: Decrement count of number of vehicles on ramp + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Minimum_Level; -- for this version of the + Freeway_Breakdown : Boolean := false; -- test, freeway is Minimum + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Test_Ramp; + --================================================================ + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival is + Next_Vehicle_Task: acc_Vehicle := new Vehicle; + TC_Pass_Point : constant integer := 3; + begin + Next_ID := Next_ID + 1; + Next_Vehicle_Task.Get_ID(Next_ID); + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; + end New_arrival; + + + -- Carrier task. One is created for each vehicle arriving at the ramp + task body Vehicle is + This_ID : Vehicle_ID; + TC_Pass_Point_2 : constant integer := 21; + begin + accept Get_ID (Input_ID : in Vehicle_ID) do + This_ID := Input_ID; + end Get_ID; + + if Test_Ramp.Meter_in_Use_State then + Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage + null; -- stub::: Increment count of number of vehicles on ramp + Test_Ramp.Wait_at_Meter; -- Queue on the meter entry + end if; + + -- Call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + -- Each sensor will requeue the call to the next thus this + -- rendezvous will only be completed as the vehicle is released + -- by the last sensor on the ramp. + Ramp_Sensor_01.Accept_Vehicle (This_ID); + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle; + + task body Ramp_Sensor_01 is + TC_Pass_Point : constant integer := 31; + This_ID : Vehicle_ID; + TC_Last_ID : Vehicle_ID := Vehicle_ID'first; + begin + loop + select + accept Accept_Vehicle (Input_ID : in Vehicle_ID) do + null; -- stub:::: match up with next Real-Time notification + -- from the sensor. Requeue to next ramp sensor + This_ID := Input_ID; + + -- The following is all Test_Control code + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage + -- The items arrive in the order they are taken from + -- the Wait_at_Meter entry queue + if ( This_ID - TC_Last_ID ) /= 1 then + -- The tasks are being queued (or unqueued) in the + -- wrong order + Report.Failed + ("Queueing on the Wait_at_Meter queue failed"); + end if; + TC_Last_ID := This_ID; -- for the next check + if TC_Last_ID = 4 then + -- rendezvous with the test driver + accept TC_First_Three_Handled; + elsif TC_Last_ID = 9 then + -- rendezvous with the test driver + accept TC_All_Done; + end if; + end Accept_Vehicle; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Ramp_Sensor_01"); + end Ramp_Sensor_01; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + begin + While not Pulse_State.Pulsing loop + -- Starts up in the quiescent state + delay ImpDef.Minimum_Task_Switch; + end loop; + Pulse_Time := Ada.Calendar.Clock; + While Pulse_State.Pulsing loop + delay until Pulse_Time; + Test_Ramp. Time_Pulse_Received; -- Transmit pulse to test_ramp + -- :::::::::: and to all the other ramps + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Arrange to queue three vehicles on the Wait_at_Meter queue. The + -- timing pulse is quiescent so the queue will build + for i in 1..3 loop + New_Arrival; + end loop; + + delay Pulse_Time_Delta; -- ensure all is settled + + Pulse_State.Start_Pulse; -- Start the timing pulse, the queue will + -- be serviced + + -- wait here until the first three are complete + Ramp_Sensor_01.TC_First_Three_Handled; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Intermediate Wait_at_Entry'count is incorrect"); + end if; + + -- generate new arrivals at a rate that will make the queue increase + -- and decrease "randomly" + for i in 1..5 loop + New_Arrival; + delay Pulse_Time_Delta/2; + end loop; + + -- wait here till all have been handled + Ramp_Sensor_01.TC_All_Done; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Final Wait_at_Entry'count is incorrect"); + end if; + + Pulse_State.Stop_Pulse; -- finish test + + + if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then + Report.Failed ("Unexpected paths taken"); + end if; + + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Wait_at_Meter'count incorrect"); + end if; + + Report.Result; + +end C940013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940014.a b/gcc/testsuite/ada/acats/tests/c9/c940014.a new file mode 100644 index 000000000..0eb53ea51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940014.a @@ -0,0 +1,177 @@ +-- C940014.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 as part of the finalization of a protected object +-- each call remaining on an entry queue of the objet is removed +-- from its queue and Program_Error is raised at the place of +-- the corresponding entry_call_statement. +-- +-- TEST DESCRIPTION: +-- The example in 9.4(20a-20f);6.0 demonstrates how to cause a +-- protected object to finalize while tasks are still waiting +-- on its entry queues. The first part of this test mirrors +-- that example. The second part of the test expands upon +-- the example code to add an object with finalization code +-- to the protected object. The finalization code should be +-- executed after Program_Error is raised in the callers left +-- on the entry queues. +-- +-- +-- CHANGE HISTORY: +-- 08 Jan 96 SAIC Initial Release for 2.1 +-- 10 Jul 96 SAIC Incorporated Reviewer comments to fix race +-- condition. +-- +--! + + +with Ada.Finalization; +package C940014_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C940014_0; + + +with Report; +with ImpDef; +package body C940014_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; +end C940014_0; + + + +with Report; +with ImpDef; +with Ada.Finalization; +with C940014_0; + +procedure C940014 is + Verbose : constant Boolean := C940014_0.Verbose; + +begin + + Report.Test ("C940014", "Check that the finalization of a protected" & + " object results in program_error being raised" & + " at the point of the entry call statement for" & + " any tasks remaining on any entry queue"); + + First_Check: declare + -- example from ARM 9.4(20a-f);6.0 with minor mods + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- First_Check + begin + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in First_Check"); + exception + when Program_Error => + if Verbose then + Report.Comment ("ARM Example passed"); + end if; + when others => + Report.Failed ("wrong exception in First_Check"); + end; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + private + Component : C940014_0.Has_Finalization; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- Second_Check + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in Second_Check"); + exception + when Program_Error => + if C940014_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization"); + elsif Verbose then + Report.Comment ("Second_Check passed"); + end if; + when others => + Report.Failed ("Wrong exception in Second_Check"); + end Second_Check; + + + Report.Result; + +end C940014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940015.a b/gcc/testsuite/ada/acats/tests/c9/c940015.a new file mode 100644 index 000000000..92a6699c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940015.a @@ -0,0 +1,149 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940016.a b/gcc/testsuite/ada/acats/tests/c9/c940016.a new file mode 100644 index 000000000..2226eefb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940016.a @@ -0,0 +1,211 @@ +-- C940016.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 an Unchecked_Deallocation of a protected object +-- performs the required finalization on the protected object. +-- +-- TEST DESCRIPTION: +-- Test that finalization takes place when an Unchecked_Deallocation +-- deallocates a protected object with queued callers. +-- Try protected objects that have no other finalization code and +-- protected objects with user defined finalization. +-- +-- +-- CHANGE HISTORY: +-- 16 Jan 96 SAIC ACVC 2.1 +-- 10 Jul 96 SAIC Fixed race condition noted by reviewers. +-- +--! + + +with Ada.Finalization; +package C940016_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C940016_0; + + +with Report; +with ImpDef; +package body C940016_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; +end C940016_0; + + + +with Report; +with Ada.Finalization; +with C940016_0; +with Ada.Unchecked_Deallocation; +with ImpDef; + +procedure C940016 is + Verbose : constant Boolean := C940016_0.Verbose; + +begin + + Report.Test ("C940016", "Check that Unchecked_Deallocation of a" & + " protected object finalizes the" & + " protected object"); + + First_Check: declare + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task"); + exception + when Program_Error => + Ok := True; + if Verbose then + Report.Comment ("Blocker received Program_Error"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker"); + end Blocker; + + begin -- First_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + Component : C940016_0.Has_Finalization; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task 2"); + exception + when Program_Error => + Ok := True; + if C940016_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization 2"); + elsif Verbose then + Report.Comment ("Blocker received Program_Error 2"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker 2"); + end Blocker; + + begin -- Second_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed 2"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + if not C940016_0.Finalization_Occurred then + Report.Failed ("user defined finalization didn't happen"); + end if; + end Second_Check; + + + Report.Result; + +end C940016; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001a.ada b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada new file mode 100644 index 000000000..e23a3b86d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada @@ -0,0 +1,259 @@ +-- C94001A.ADA + +-- 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. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY OBJECT +-- DECLARATIONS IS NOT TERMINATED UNTIL ALL DEPENDENT TASKS BECOME +-- TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/2/81 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 8/22/86 REVISED; ADDED CASES THAT EXIT BY RAISING AN +-- EXCEPTION. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001A IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + +BEGIN + TEST ("C94001A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + -------------------------------------------------- + + RESULT; +END C94001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001b.ada b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada new file mode 100644 index 000000000..e3e2edaa3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada @@ -0,0 +1,268 @@ +-- C94001B.ADA + +-- 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. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY AN OBJECT +-- DECLARATION OF LIMITED PRIVATE TYPE IS NOT TERMINATED UNTIL ALL +-- DEPENDENT TASKS BECOME TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- TBN 8/22/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001B IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TYPE TT IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER); + PRIVATE + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + END P; + + PACKAGE BODY P IS + + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + END P; + + USE P; + + +BEGIN + TEST ("C94001B", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY AN OBJECT DECLARATION OF LIMITED " & + "PRIVATE TYPE IS NOT TERMINATED UNTIL ALL " & + "DEPENDENT TASKS BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + CALL_ENTRY (T, IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + CALL_ENTRY (T, IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(3)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(5)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(6)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; +END C94001B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001c.ada b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada new file mode 100644 index 000000000..1d0625559 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada @@ -0,0 +1,267 @@ +-- C94001C.ADA + +-- 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. +--* +-- CHECK THAT A UNIT WITH INDIRECT DEPENDENT TASKS CREATED BY OBJECT +-- DECLARATIONS IS NOT TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS +-- BECOME TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A BLOCK CONTAINING A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) A FUNCTION CONTAINING AN ARRAY OF TASK OBJECT, IN A +-- FUNCTION. +-- (E, F) A TASK CONTAINING AN ARRAY OF RECORD OF TASK OBJECT, +-- IN A TASK BODY. +-- CASES (B, D, F) EXIT BY RAISING AN EXCEPTION. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- TBN 8/25/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001C IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + +BEGIN + TEST ("C94001C", "CHECK THAT A UNIT WITH INDIRECT DEPENDENT " & + "TASKS CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + + BEGIN -- (A) + + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + END; + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + BEGIN -- (B) + GLOBAL := IDENT_INT (0); + + BEGIN + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(3)); + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (C) + OBJ_INT := F1; + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (D) + GLOBAL := IDENT_INT (0); + OBJ_INT := F1; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + DELAY_COUNT : INTEGER := 0; + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(5)); + END TSK; + + BEGIN + NULL; + END OUT_TSK; + + BEGIN -- (E) + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Long_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 5"); + END IF; + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE + DELAY_COUNT : INTEGER := 0; + + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(6)); + RAISE MY_EXCEPTION; + END TSK; + + BEGIN + RAISE MY_EXCEPTION; + END OUT_TSK; + + BEGIN + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Long_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 6"); + END IF; + END; + + RESULT; +END C94001C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001e.ada b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada new file mode 100644 index 000000000..4ab502cd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada @@ -0,0 +1,81 @@ +-- C94001E.ADA + +-- 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. +--* +-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY +-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. +-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. +-- VERSION WITH EXCEPTION HANDLER. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C940AGA-B.ADA +-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + +WITH REPORT; + USE REPORT; +PROCEDURE C94001E IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + +BEGIN + + TEST ("C94001E", "TASK COMPLETION BY EXCEPTION"); + +BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + IF OBJ_I1 /= I1(IDENT_INT(0)) THEN + PSPY_NUMB (1); + ELSE + PSPY_NUMB (2); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("OTHER EXCEPTION RAISED"); + END T1; + + BEGIN + NULL; + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C94001E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001f.ada b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada new file mode 100644 index 000000000..82adc32f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada @@ -0,0 +1,80 @@ +-- C94001F.ADA + +-- 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. +--* +-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY +-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. +-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. +-- VERSION WITHOUT EXCEPTION HANDLER. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C940AGB-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C94001F IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + +BEGIN + + TEST ("C94001F", "TASK COMPLETION BY EXCEPTION -- NO HANDLER"); + +BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + PSPY_NUMB (1); + END T1; + + BEGIN + NULL; -- WAIT FOR TERMINATION. + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("PROPAGATED CONSTRAINT_ERROR OUT OF TASK"); + WHEN TASKING_ERROR => + FAILED ("RAISED TASKING_ERROR"); + WHEN OTHERS => + FAILED ("RAISED OTHER EXCEPTION"); + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION IN SEQUENCE " & + "OF STATEMENTS"); + END IF; + + RESULT; + +END C94001F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001g.ada b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada new file mode 100644 index 000000000..294bb53a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada @@ -0,0 +1,124 @@ +-- C94001G.ADA + +-- 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. +--* +-- CHECK THAT A COMPLETED TASK WITH DEPENDENT TASKS TERMINATES WHEN +-- A L L DEPENDENT TASKS HAVE TERMINATED. + +-- WEI 3/ 4/82 +-- JBG 4/2/84 +-- JWC 6/28/85 RENAMED FROM C940AIA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C94001G IS + + PACKAGE SPY IS -- PROVIDE PROTECTED ACCESS TO SPYNUMB + SUBTYPE ARG IS NATURAL RANGE 0..9; + FUNCTION SPYNUMB RETURN NATURAL; -- READ + FUNCTION FINIT_POS (DIGT : IN ARG) RETURN NATURAL; -- WRITE + PROCEDURE PSPY_NUMB (DIGT : IN ARG); -- WRITE + END SPY; + + USE SPY; + + PACKAGE BODY SPY IS + + TASK GUARD IS + ENTRY READ (NUMB : OUT NATURAL); + ENTRY WRITE (NUMB : IN NATURAL); + END GUARD; + + TASK BODY GUARD IS + SPYNUMB : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT READ (NUMB : OUT NATURAL) DO + NUMB := SPYNUMB; + END READ; + OR ACCEPT WRITE (NUMB : IN NATURAL) DO + SPYNUMB := 10*SPYNUMB+NUMB; + END WRITE; + OR TERMINATE; + END SELECT; + END LOOP; + END GUARD; + + FUNCTION SPYNUMB RETURN NATURAL IS + TEMP : NATURAL; + BEGIN + GUARD.READ (TEMP); + RETURN TEMP; + END SPYNUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + GUARD.WRITE (DIGT); + RETURN DIGT; + END FINIT_POS; + + PROCEDURE PSPY_NUMB (DIGT : IN ARG) IS + BEGIN + GUARD.WRITE (DIGT); + END PSPY_NUMB; + END SPY; + +BEGIN + TEST ("C94001G", "TERMINATION WHEN ALL DEPENDENT TASKS " & + "HAVE TERMINATED"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK BODY TT1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + END TT1; + + TASK T1 IS + END T1; + + TASK BODY T1 IS + OBJ_TT1_1, OBJ_TT1_2, OBJ_TT1_3 : TT1; + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END BLOCK; -- WAIT HERE FOR TERMINATION. + + IF SPYNUMB /= 111 THEN + FAILED ("TASK T1 TERMINATED BEFORE " & + "ALL DEPENDENT TASKS HAVE TERMINATED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C94001G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002a.ada b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada new file mode 100644 index 000000000..6db8f962b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada @@ -0,0 +1,331 @@ +-- C94002A.ADA + +-- 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. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY (LOCAL) +-- ALLOCATORS DOES NOT TERMINATE UNTIL ALL DEPENDENT TASKS ARE +-- TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (C, D) A RECORD OF TASK ALLOCATOR, IN A FUNCTION. +-- (E, F) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/2/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 8/25/86 REDUCED DELAYS; ADDED LIMITED PRIVATE TYPES; +-- INCLUDED EXITS BY RAISING AN EXCEPTION. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002A IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TASK TYPE T1 IS + ENTRY E (I : INTEGER); + END T1; + TYPE T2 IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER); + PRIVATE + TASK TYPE T2 IS + ENTRY E (I : INTEGER); + END T2; + END P; + + PACKAGE BODY P IS + TASK BODY T1 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END T1; + + TASK BODY T2 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; + GLOBAL := LOCAL; + END T2; + + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + END P; + + USE P; + + +BEGIN + TEST ("C94002A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY (LOCAL) ALLOCATORS DOES NOT " & + "TERMINATE UNTIL ALL DEPENDENT TASKS " & + "ARE TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + BEGIN -- (A) + DECLARE + TYPE A_T IS ACCESS T1; + A : A_T; + BEGIN + IF EQUAL (3, 3) THEN + A := NEW T1; + A.ALL.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END IF; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 1"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + TYPE A_T IS ACCESS T2; + A : A_T; + BEGIN -- (B) + IF EQUAL (3, 3) THEN + A := NEW T2; + CALL_ENTRY (A.ALL, IDENT_INT(2)); + END IF; + END; -- (B) + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T1; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T.E (IDENT_INT(3)); + END LOOP; + RETURN 0; + END F; + BEGIN -- (C) + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T2; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T, IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + RETURN 0; + END F; + BEGIN -- (D) + I := F; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T1; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T(1).E (IDENT_INT(5)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 5"); + END IF; + + IF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T2; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T(1), IDENT_INT(6)); + END LOOP; + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 6"); + END IF; + + IF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; +END C94002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002b.ada b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada new file mode 100644 index 000000000..1f226f7c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada @@ -0,0 +1,208 @@ +-- C94002B.ADA + +-- 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. +--* +-- CHECK THAT A MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL ACCESS +-- TYPE MAY TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS TO +-- TERMINATE. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 1/20/86 REPLACED WITH C94006A-B.ADA AFTER LOWERING THE DELAY +-- VALUES, AND MODIFYING THE COMMENTS. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002B IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002B", "CHECK THAT A MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE MAY TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + END IF; + + A1.ALL.E; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + END IF; + + AR1.T.E; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + END IF; + + ARA1.T(1).E; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94002B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002d.ada b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada new file mode 100644 index 000000000..372fac0bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada @@ -0,0 +1,74 @@ +-- C94002D.ADA + +-- 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. +--* +-- CHECK THAT A TASK DOES N O T DEPEND ON A UNIT IF IT IS DESIGNATED +-- BY A LOCAL ACCESS VARIABLE (OF THIS UNIT) WHOSE TYPE IS DECLARED +-- OUTSIDE THIS UNIT. + +-- WEI 3/ 4/82 +-- JBG 2/20/84 +-- TBN 11/25/85 RENAMED FROM C940ACB-B.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C94002D IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + OUTER_TT1 : ATT1; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1; + ACCEPT E2; + END TT1; + +BEGIN + TEST ("C94002D", "DEPENDENCY IS INDEPENDENT OF WHERE ACCESS " & + "VARIABLE IS DECLARED"); + +BLOCK1 : + DECLARE + POINTER_TT1 : ATT1 := NEW TT1; + BEGIN + OUTER_TT1 := POINTER_TT1; + POINTER_TT1.ALL.E1; + END BLOCK1; -- MAY DEADLOCK HERE IF INCORRECT DEPENDENCY + -- RULE IS IMPLEMENTED. + + IF OUTER_TT1.ALL'TERMINATED THEN + FAILED ("NON-DEPENDENT TASK IS TERMINATED " & + "IMMEDIATELY AFTER ENCLOSING UNIT HAS " & + "BEEN COMPLETED"); + END IF; + + OUTER_TT1.E2; -- RELEASE TASK + + RESULT; + +END C94002D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002e.ada b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada new file mode 100644 index 000000000..940fd3289 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada @@ -0,0 +1,207 @@ +-- C94002E.ADA + +-- 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. +--* +-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS +-- TO TERMINATE. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 1/20/86 RENAMED FROM C94006A-B.ADA. LOWERED THE DELAY VALUES +-- AND MODIFIED THE COMMENTS. +-- JRK 5/1/86 IMPROVED ERROR RECOVERY LOGIC. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002E IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002E", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94002E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002f.ada b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada new file mode 100644 index 000000000..47f0b4df2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada @@ -0,0 +1,227 @@ +-- C94002F.ADA + +-- 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. +--* +-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS +-- TO TERMINATE IF AN EXCEPTION IS RAISED AND HANDLED IN THE +-- NON-MASTER UNIT. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- TBN 1/20/86 +-- JRK 5/1/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION HANDLING. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002F IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002F", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED AND " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + --------------------------------------------------------------- + + RESULT; +END C94002F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002g.ada b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada new file mode 100644 index 000000000..1b6108fe5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada @@ -0,0 +1,350 @@ +-- C94002G.ADA + +-- 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 NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED +-- TASKS TO TERMINATE IF AN EXCEPTION IS RAISED BUT NOT HANDLED IN +-- THE NON-MASTER UNIT. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY, NOT +-- DURING RENDEZVOUS. +-- (D) A LIMITED PRIVATE TASK ALLOCATOR, IN A TASK BODY, DURING +-- RENDEZVOUS. + +-- HISTORY: +-- TBN 01/20/86 CREATED ORIGINAL TEST. +-- JRK 05/01/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION +-- HANDLING. ADDED CASE (D). +-- BCB 09/24/87 ADDED A RETURN STATEMENT TO THE HANDLER FOR OTHERS +-- IN FUNCTION F, CASE B. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002G IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002G", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED BUT NOT " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + END; + + ABORT A1.ALL; + + EXCEPTION + WHEN MY_EXCEPTION => + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - " & + "(A)"); + ELSE A1.ALL.E; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + IF A1 /= NULL THEN + ABORT A1.ALL; + END IF; + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR1 := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + END P; + + BEGIN + P; + ABORT AR1.T; + RETURN 0; + EXCEPTION + WHEN MY_EXCEPTION => + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (B)"); + ELSE AR1.T.E; + END IF; + RETURN 0; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + IF AR1 /= NULL THEN + ABORT AR1.T; + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; -- NOT PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + PACKAGE PKG IS + TYPE LPT IS LIMITED PRIVATE; + PROCEDURE CALL (X : LPT); + PROCEDURE KILL (X : LPT); + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN; + PRIVATE + TYPE LPT IS NEW TT; + END PKG; + + USE PKG; + + TYPE ALPT IS ACCESS LPT; + ALP1 : ALPT; + + PACKAGE BODY PKG IS + PROCEDURE CALL (X : LPT) IS + BEGIN + X.E; + END CALL; + + PROCEDURE KILL (X : LPT) IS + BEGIN + ABORT X; + END KILL; + + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN IS + BEGIN + RETURN X'TERMINATED; + END TERMINATED; + END PKG; + + TASK TSK1 IS + ENTRY ENT1 (ALP : OUT ALPT); + ENTRY DIE; + END TSK1; + + TASK BODY TSK1 IS + ALP2 : ALPT; + BEGIN + ALP2 := NEW LPT; -- INITIATE TASK ALP2.ALL. + CALL (ALP2.ALL); + ACCEPT ENT1 (ALP : OUT ALPT) DO + ALP := ALP2; + END ENT1; + ACCEPT DIE DO + RAISE MY_EXCEPTION; -- PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (D)"); + END DIE; + END TSK1; + + BEGIN + TSK1.ENT1 (ALP1); -- ALP1.ALL BECOMES ALIAS FOR ALP2.ALL. + TSK1.DIE; + FAILED ("MY_EXCEPTION WAS NOT PROPOGATED TO CALLING " & + "TASK - (D)"); + KILL (ALP1.ALL); + ABORT TSK1; + EXCEPTION + WHEN MY_EXCEPTION => + WHILE NOT TSK1'TERMINATED AND + LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (D)"); + END IF; + + IF TERMINATED (ALP1.ALL) THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (D)"); + ELSE CALL (ALP1.ALL); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (D)"); + IF ALP1 /= NULL THEN + KILL (ALP1.ALL); + END IF; + ABORT TSK1; + END TSK; + + BEGIN -- (D) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (D)"); + END IF; + + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C94002G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004a.ada b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada new file mode 100644 index 000000000..b895f8c87 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada @@ -0,0 +1,95 @@ +-- C94004A.ADA + +-- 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. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE A: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN +-- PROGRAM. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004A-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004A-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004A_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + +END C94004A_PKG; + +WITH C94004A_PKG; USE C94004A_PKG; +PRAGMA ELABORATE (C94004A_PKG); +PACKAGE C94004A_TASK IS + T : TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004A_TASK; +PROCEDURE C94004A IS + + +BEGIN + TEST ("C94004A", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004A_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004A_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004b.ada b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada new file mode 100644 index 000000000..3a578fd8b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada @@ -0,0 +1,97 @@ +-- C94004B.ADA + +-- 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. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE B: ACCESS TO TASK TYPE DECLARED IN LIBRARY PACKAGE; TASK +-- ACTIVATED IN MAIN PROGRAM. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004B-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004B-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004B_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004B_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004B_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + +END C94004B_PKG; + +WITH C94004B_PKG; USE C94004B_PKG; +PRAGMA ELABORATE (C94004B_PKG); +PACKAGE C94004B_TASK IS + TYPE ACC_TASK IS ACCESS C94004B_PKG.TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004B_TASK; WITH C94004B_PKG; +PROCEDURE C94004B IS + + T : C94004B_TASK.ACC_TASK; + +BEGIN + TEST ("C94004B", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T := NEW C94004B_PKG.TT; + T.E; -- ALLOW TASK TO PROCEED. + IF T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004c.ada b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada new file mode 100644 index 000000000..321bfee72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada @@ -0,0 +1,104 @@ +-- C94004C.ADA + +-- 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. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE C: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN PROGRAM +-- AND WAITING AT A SELECTIVE WAIT WITH TERMINATE. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004C-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004C-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004C_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004C_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004C_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + -- USE LOOP FOR SELECTIVE WAIT WITH TERMINATE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + -- FAILS IF JOB HANGS UP WITHOUT TERMINATING. + END TT; + +END C94004C_PKG; + +WITH C94004C_PKG; USE C94004C_PKG; +PRAGMA ELABORATE (C94004C_PKG); +PACKAGE C94004C_TASK IS + T : TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004C_TASK; +PROCEDURE C94004C IS + + +BEGIN + TEST ("C94004C", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004C_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004C_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005a.ada b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada new file mode 100644 index 000000000..71c5846f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada @@ -0,0 +1,90 @@ +-- C94005A.ADA + +-- 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. +--* +-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, A MAIN +-- PROGRAM THAT DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR +-- TERMINATION OF SUCH OBJECTS. + +-- THIS TEST CONTAINS RACE CONDITIONS. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005A_PKG. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94005A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94005A_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PACKAGE BODY C94005A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (0); + BEGIN + ACCEPT E; + FOR J IN 1..60 LOOP + I := IDENT_INT (I); + DELAY 1.0 * Impdef.One_Second; + END LOOP; + RESULT; -- FAILURE IF THIS MESSAGE IS NOT WRITTEN. + END TT; + +END C94005A_PKG; + + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94005A_PKG; +PROCEDURE C94005A IS + + T : C94005A_PKG.TT; + + +BEGIN + TEST ("C94005A", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, A MAIN PROGRAM THAT " & + "DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR " & + "TERMINATION OF SUCH OBJECTS"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T.E; + + IF T'TERMINATED THEN + COMMENT ("TEST INCONCLUSIVE BECAUSE TASK T PREMATURELY " & + "TERMINATED"); + END IF; + + -- TASK T SHOULD WRITE THE RESULT MESSAGE. + +END C94005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005b.ada b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada new file mode 100644 index 000000000..2a481b313 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada @@ -0,0 +1,168 @@ +-- C94005B.ADA + +-- 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. +--* +-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, ANY +-- BLOCKS, SUBPROGRAMS, OR TASKS THAT DECLARE OBJECTS OF THAT TYPE +-- DO WAIT FOR TERMINATION OF SUCH OBJECTS. +-- SUBTESTS ARE: +-- (A) IN A MAIN PROGRAM BLOCK. +-- (B) IN A LIBRARY FUNCTION. +-- (C) IN A MAIN PROGRAM TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005B_PKG. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94005B_PKG IS + + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + +END C94005B_PKG; + +with Impdef; +PACKAGE BODY C94005B_PKG IS + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 60.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + +END C94005B_PKG; + + +WITH REPORT; USE REPORT; +WITH C94005B_PKG; USE C94005B_PKG; +FUNCTION F RETURN INTEGER IS + + T : TT; + +BEGIN + + T.E (IDENT_INT(2)); + RETURN 0; + +END F; + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94005B_PKG; USE C94005B_PKG; +WITH F; +PROCEDURE C94005B IS + + +BEGIN + TEST ("C94005B", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, ANY BLOCKS, SUBPROGRAMS, OR " & + "TASKS THAT DECLARE OBJECTS OF THAT TYPE DO " & + "WAIT FOR TERMINATION OF SUCH OBJECTS"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - (A)"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + I : INTEGER; + + BEGIN -- (B) + + I := F ; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + T : TT; + BEGIN + T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED LOOP + DELAY 0.1 * Impdef.One_Second; + END LOOP; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94006a.ada b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada new file mode 100644 index 000000000..cac5fc6e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada @@ -0,0 +1,136 @@ +-- C94006A.ADA + +-- 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. +--* +-- CHECK THAT A DECLARATION THAT RENAMES A TASK DOES NOT CREATE A NEW +-- MASTER FOR THE TASK. + +-- TBN 9/17/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94006A IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + SELECT + ACCEPT E; + OR + DELAY 30.0 * Impdef.One_Long_Second; + END SELECT; + END TT; + + +BEGIN + TEST ("C94006A", "CHECK THAT A DECLARATION THAT RENAMES A TASK " & + "DOES NOT CREATE A NEW MASTER FOR THE TASK"); + + ------------------------------------------------------------------- + DECLARE + T1 : TT; + BEGIN + DECLARE + RENAME_TASK : TT RENAMES T1; + BEGIN + NULL; + END; + IF T1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 1"); + ELSE + T1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + T2 : TT; + + PACKAGE P IS + Q : TT RENAMES T2; + END P; + + PACKAGE BODY P IS + BEGIN + NULL; + END P; + + USE P; + BEGIN + IF Q'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 2"); + ELSE + Q.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P1 : ACC_TT; + BEGIN + DECLARE + RENAME_ACCESS : ACC_TT RENAMES P1; + BEGIN + RENAME_ACCESS := NEW TT; + END; + IF P1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 3"); + ELSE + P1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P2 : ACC_TT; + + PACKAGE Q IS + RENAME_ACCESS : ACC_TT RENAMES P2; + END Q; + + PACKAGE BODY Q IS + BEGIN + RENAME_ACCESS := NEW TT; + END Q; + + USE Q; + BEGIN + IF RENAME_ACCESS'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 4"); + ELSE + RENAME_ACCESS.E; + END IF; + END; + + RESULT; +END C94006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007a.ada b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada new file mode 100644 index 000000000..e0a2c3f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada @@ -0,0 +1,270 @@ +-- C94007A.ADA + +-- 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 TASK THAT IS DECLARED IN A NON-LIBRARY PACKAGE +-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, +-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, +-- OR TASK BODY. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A VISIBLE PART, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A PRIVATE PART, IN A FUNCTION. +-- (C) AN ARRAY OF RECORD OF TASK OBJECT, IN A PACKAGE BODY, +-- IN A TASK BODY. + +-- HISTORY: +-- JRK 10/13/81 +-- SPS 11/21/82 +-- DHH 09/07/88 REVISED HEADER, ADDED EXCEPTION HANDLERS ON OUTER +-- BLOCKS, AND ADDED CASE TO INSURE THAT LEAVING A +-- PACKAGE VIA AN EXCEPTION WOULD NOT ABORT TASKS. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94007A IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + +BEGIN + TEST ("C94007A", "CHECK THAT A TASK THAT IS DECLARED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END T; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + A : ARRAY (1..1) OF TT; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - B"); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + AR : ARRAY (1..1) OF RT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - C"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + GLOBAL : INTEGER := IDENT_INT(5); + + BEGIN -- (D) + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + + TASK T1 IS + END T1; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + ACCEPT E DO + RAISE CONSTRAINT_ERROR; + END E; + END T; + + TASK BODY T1 IS + BEGIN + DELAY 120.0 * Impdef.One_Second; + GLOBAL := IDENT_INT(1); + END T1; + + BEGIN + T.E; + + END PKG; + USE PKG; + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("TASK NOT COMPLETED"); + END IF; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - D"); + END; -- (D) + + RESULT; +END C94007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007b.ada b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada new file mode 100644 index 000000000..87e45b352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada @@ -0,0 +1,224 @@ +-- C94007B.ADA + +-- 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. +--* +-- CHECK THAT A TASK THAT IS ALLOCATED IN A NON-LIBRARY PACKAGE +-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, +-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, +-- OR TASK BODY. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A VISIBLE PART, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A PRIVATE PART, IN A FUNCTION. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY, +-- IN A TASK BODY. + +-- JRK 10/16/81 +-- SPS 11/2/82 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94007B IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + +BEGIN + TEST ("C94007B", "CHECK THAT A TASK THAT IS ALLOCATED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + TYPE A_T IS ACCESS TT; + A : A_T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + A := NEW TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + TYPE ART IS ACCESS RT; + + AR : ART; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + AR := NEW RT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F ; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + T : ARR; + END RECORD; + + TYPE ARAT IS ACCESS RAT; + + ARA : ARAT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + ARA := NEW RAT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94007B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008a.ada b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada new file mode 100644 index 000000000..90b31d315 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada @@ -0,0 +1,61 @@ +-- C94008A.ADA + +-- 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. +--* +-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE +-- DOES N O T TERMINATE WHILE THE UNIT THE TASK DEPENDS ON +-- HAS NOT COMPLETED ITS EXECUTION. + +-- WEI 3/ 4/82 +-- TBN 11/25/85 RENAMED FROM C940BAA-B.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C94008A IS +BEGIN + TEST ("C94008A", "TERMINATION WHILE WAITING AT " & + "AN OPEN TERMINATE ALTERNATIVE"); + +BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END T1; + BEGIN -- BLOCK1 + IF T1'TERMINATED THEN + FAILED ("TASK T1 TERMINATED BEFORE OUTER UNIT HAS " & + "BEEN LEFT"); + END IF; + END BLOCK1; + + RESULT; + +END C94008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008b.ada b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada new file mode 100644 index 000000000..e72d4890e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada @@ -0,0 +1,81 @@ +-- C94008B.ADA + +-- 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. +--* +-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE +-- DOES N O T TERMINATE UNTIL ALL OTHER TASKS DEPENDING ON THE SAME +-- UNIT EITHER ARE TERMINATED OR ARE WAITING AT AN OPEN TERMINATE. + +-- WEI 3/ 4/82 +-- TBN 11/25/85 RENAMED FROM C940BBA-B.ADA. + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C94008B IS +BEGIN + TEST ("C94008B", "TERMINATION WHILE WAITING AT AN OPEN TERMINATE"); + +BLOCK1 : + DECLARE + + TASK TYPE TT1 IS + ENTRY E1; + END TT1; + + NUMB_TT1 : CONSTANT NATURAL := 3; + DELAY_TIME : DURATION := 0.0; + ARRAY_TT1 : ARRAY (1 .. NUMB_TT1) OF TT1; + + TASK BODY TT1 IS + BEGIN + DELAY_TIME := DELAY_TIME + 1.0 * Impdef.One_Second; + DELAY DELAY_TIME; + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TOO EARLY TERMINATION OF " & + "TASK TT1 INDEX" & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END TT1; + + BEGIN -- BLOCK1. + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TERMINATION BEFORE OUTER " & + "UNIT HAS BEEN LEFT OF TASK TT1 INDEX " & + INTEGER'IMAGE(I)); + END IF; + END LOOP; + END BLOCK1; + + RESULT; + +END C94008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008c.ada b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada new file mode 100644 index 000000000..fb2eee97f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada @@ -0,0 +1,265 @@ +-- C94008C.ADA + +-- 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. +--* +-- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH +-- NESTED TASKS. + +-- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT +-- CONTAINS TASKS. + +-- JEAN-PIERRE ROSEN 24 FEBRUARY 1984 +-- JRK 4/7/86 +-- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94008C IS + + +-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES + GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; + PACKAGE SHARED IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; + END SHARED; + + PACKAGE BODY SHARED IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; + BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END SHARE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + + BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE + END SHARED; + + PACKAGE EVENTS IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); + END EVENTS; + + PACKAGE COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); + END COUNTER; + + PACKAGE BODY COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; + END COUNTER; + + PACKAGE BODY EVENTS IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + + END EVENTS; + + USE EVENTS, COUNTER; + + PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0); + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + +BEGIN -- C94008C + + TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE"); + + DECLARE + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + + TASK T3 IS + ENTRY E3; + END T3; + + TASK BODY T3 IS + BEGIN + SELECT + ACCEPT E3; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + EVENT ('D'); + END T3; + + BEGIN -- T2 + + SELECT + ACCEPT E2; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Long_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 1 "); + END IF; + + EVENT ('C'); + T1.E1; + T3.E3; + END T2; + + BEGIN -- T1; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + EVENT ('B'); + TERMINATE_COUNT.SET (0); + T2.E2; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + SELECT + ACCEPT E1; + OR TERMINATE; -- ONLY THIS ONE EVER CHOSEN. + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END T1; + + BEGIN + + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS. + + IF TERMINATE_COUNT.GET /= 3 THEN + DELAY 20.0 * Impdef.One_Long_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 3 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 2"); + END IF; + + EVENT ('A'); + T1.E1; + + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK"); + END; + + IF TRACE.GET.TRACE /= "ABCD" THEN + FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE); + END IF; + + RESULT; +END C94008C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008d.ada b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada new file mode 100644 index 000000000..15ca61618 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada @@ -0,0 +1,235 @@ +-- C94008D.ADA + +-- 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. +--* +-- CHECK CORRECT OPERATION OF SELECT WITH TERMINATE ALTERNATIVE WHEN +-- EXECUTED FROM AN INNER BLOCK WITH OUTER DEPENDING TASKS. + +-- JEAN-PIERRE ROSEN 03-MAR-84 +-- JRK 4/7/86 +-- JBG 9/4/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT/SUBUNIT +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES +GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; +PACKAGE SHARED_C94008D IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; +END SHARED_C94008D; + +PACKAGE BODY SHARED_C94008D IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS SEPARATE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + +BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE +END SHARED_C94008D; + +PACKAGE EVENTS_C94008D IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); +END EVENTS_C94008D; + +PACKAGE COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); +END COUNTER_C94008D; + +PACKAGE BODY COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; +END COUNTER_C94008D; + +PACKAGE BODY EVENTS_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + +END EVENTS_C94008D; + +SEPARATE (SHARED_C94008D) +TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; +BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED_C94008D.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED_C94008D.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; +END SHARE; + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +WITH SHARED_C94008D, COUNTER_C94008D, EVENTS_C94008D; +USE COUNTER_C94008D, EVENTS_C94008D; +PROCEDURE C94008D IS + + PACKAGE TRACE IS + NEW SHARED_C94008D (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS + NEW SHARED_C94008D (INTEGER, INTEGER, 0); + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + +BEGIN + TEST ("C94008D", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE FROM AN INNER BLOCK"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DECLARE + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH"); + END IF; + + IF T1'TERMINATED OR NOT T1'CALLABLE THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + + EVENT ('A'); + + SELECT + ACCEPT E2; + OR TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T2"); + END T2; + + BEGIN + BEGIN + EVENT ('B'); + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END; + END; + END T1; + + BEGIN + EVENT ('C'); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RECEIVED IN MAIN"); + END; + + IF TRACE.GET.TRACE(3) = '.' OR TRACE.GET.TRACE(4) /= '.' THEN + FAILED ("ALL EVENTS NOT PROCESSED CORRECTLY"); + END IF; + + COMMENT ("EXECUTION ORDER WAS " & TRACE.GET.TRACE); + + RESULT; +END C94008D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94010a.ada b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada new file mode 100644 index 000000000..3fe4bd6f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada @@ -0,0 +1,243 @@ +-- C94010A.ADA + +-- 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. +--* +-- CHECK THAT IF A GENERIC UNIT HAS A FORMAL LIMITED PRIVATE TYPE AND +-- DECLARES AN OBJECT OF THAT TYPE (OR HAS A SUBCOMPONENT OF THAT TYPE), +-- AND IF THE UNIT IS INSTANTIATED WITH A TASK TYPE OR AN OBJECT HAVING +-- A SUBCOMPONENT OF A TASK TYPE, THEN THE USUAL RULES APPLY TO THE +-- INSTANTIATED UNIT, NAMELY: +-- A) IF THE GENERIC UNIT IS A SUBPROGRAM, CONTROL CANNOT LEAVE THE +-- SUBPROGRAM UNTIL THE TASK CREATED BY THE OBJECT DECLARATION IS +-- TERMINATED. + +-- THIS TEST CONTAINS RACE CONDITIONS AND SHARED VARIABLES. + +-- TBN 9/22/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94010A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PRIVATE + TASK TYPE LIM_PRI_TASK IS + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + END P; + + TASK BODY TT IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PROCEDURE PROC (A : INTEGER); + + PROCEDURE PROC (A : INTEGER) IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + FUNCTION FUNC (A : INTEGER) RETURN INTEGER; + + FUNCTION FUNC (A : INTEGER) RETURN INTEGER IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 1; + END FUNC; + + +BEGIN + TEST ("C94010A", "CHECK TERMINATION RULES FOR INSTANTIATIONS OF " & + "GENERIC SUBPROGRAM UNITS WHICH CREATE TASKS"); + + ------------------------------------------------------------------- + DECLARE + PROCEDURE PROC1 IS NEW PROC (TT); + BEGIN + PROC1 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + DELAY 35.0; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC2 IS NEW PROC (REC); + BEGIN + PROC2 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC3 IS NEW PROC (LIM_PRI_TASK); + BEGIN + PROC3 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 3"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC4 IS NEW PROC (LIM_REC); + BEGIN + PROC4 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC1 IS NEW FUNC (TT); + BEGIN + A := FUNC1 (1); + FAILED ("EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC2 IS NEW FUNC (REC); + BEGIN + A := FUNC2 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC3 IS NEW FUNC (LIM_PRI_TASK); + BEGIN + A := FUNC3 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 7"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC4 IS NEW FUNC (LIM_REC); + BEGIN + A := FUNC4 (1); + FAILED ("EXCEPTION NOT RAISED - 8"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 8"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 8"); + END; + + ------------------------------------------------------------------- + + RESULT; +END C94010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94011a.ada b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada new file mode 100644 index 000000000..c504f0692 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada @@ -0,0 +1,268 @@ +-- C94011A.ADA + +-- 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. +--* +-- CHECK THAT IF A FORMAL ACCESS TYPE OF A GENERIC UNIT DESIGNATES A +-- FORMAL LIMITED PRIVATE TYPE, THEN WHEN THE UNIT IS INSTANTIATED WITH +-- A TASK TYPE OR A TYPE HAVING A SUBCOMPONENT OF A TASK TYPE, THE +-- MASTER FOR ANY TASKS ALLOCATED WITHIN THE INSTANTIATED UNIT IS +-- DETERMINED BY THE ACTUAL PARAMETER. + +-- TBN 9/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C94011A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PROCEDURE E (T : LIM_PRI_TASK); + PRIVATE + TASK TYPE LIM_PRI_TASK IS + ENTRY E; + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + + PROCEDURE E (T : LIM_PRI_TASK) IS + BEGIN + T.E; + END E; + END P; + + TASK BODY TT IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PROCEDURE PROC (A : OUT ACC_T); + + PROCEDURE PROC (A : OUT ACC_T) IS + BEGIN + A := NEW T; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + FUNCTION FUNC RETURN ACC_T; + + FUNCTION FUNC RETURN ACC_T IS + BEGIN + RETURN NEW T; + END FUNC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PACKAGE PAC IS + PTR_T : ACC_T := NEW T; + END PAC; + +BEGIN + TEST ("C94011A", "CHECK THAT IF A FORMAL ACCESS TYPE OF A " & + "GENERIC UNIT DESIGNATES A FORMAL LIMITED " & + "PRIVATE TYPE, THEN WHEN THE UNIT IS " & + "INSTANTIATED, THE MASTER FOR ANY TASKS " & + "ALLOCATED WITHIN THE INSTANTIATED UNIT IS " & + "DETERMINED BY THE ACTUAL PARAMETER"); + + ------------------------------------------------------------------- + DECLARE + TYPE ACC_TT IS ACCESS TT; + ACC1 : ACC_TT; + PROCEDURE PROC1 IS NEW PROC (TT, ACC_TT); + BEGIN + PROC1 (ACC1); + ACC1.E; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 1"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + END IF; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + DECLARE + TYPE ACC_REC IS ACCESS REC; + A : ACC_REC; + FUNCTION FUNC1 IS NEW FUNC (REC, ACC_REC); + BEGIN + A := FUNC1; + A.B.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 2"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_TT IS ACCESS LIM_PRI_TASK; + BEGIN + DECLARE + A : ACC_LIM_TT; + FUNCTION FUNC2 IS NEW FUNC (LIM_PRI_TASK, + ACC_LIM_TT); + BEGIN + A := FUNC2; + E (A.ALL); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 3"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + ACC2 : ACC_LIM_REC; + PROCEDURE PROC2 IS NEW PROC (LIM_REC, ACC_LIM_REC); + BEGIN + PROC2 (ACC2); + E (ACC2.B); + END; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 4"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_TT IS ACCESS TT; + PACKAGE PAC1 IS NEW PAC (TT, ACC_TT); + USE PAC1; + BEGIN + PTR_T.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 5"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + PACKAGE PAC2 IS NEW PAC (LIM_REC, ACC_LIM_REC); + USE PAC2; + BEGIN + E (PTR_T.B); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 6"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + END IF; + + ------------------------------------------------------------------- + + RESULT; +END C94011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94020a.ada b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada new file mode 100644 index 000000000..4a5037ecd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada @@ -0,0 +1,111 @@ +-- C94020A.ADA + +-- 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. +--* +-- CHECK THAT THE CONDITIONS FOR TERMINATION ARE RECOGNIZED WHEN THE +-- LAST MISSING TASK TERMINATES DUE TO AN ABORT + +-- JEAN-PIERRE ROSEN 08-MAR-1984 +-- JBG 6/1/84 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C94020A IS + + TASK TYPE T2 IS + END T2; + + TASK TYPE T3 IS + ENTRY E; + END T3; + + TASK BODY T2 IS + BEGIN + COMMENT("T2"); + END; + + TASK BODY T3 IS + BEGIN + COMMENT("T3"); + SELECT + ACCEPT E; + OR TERMINATE; + END SELECT; + FAILED("T3 EXITED SELECT OR TERMINATE"); + END; + +BEGIN + + TEST ("C94020A", "TEST OF TASK DEPENDENCES, TERMINATE, ABORT"); + + DECLARE + TASK TYPE T1 IS + END T1; + + V1 : T1; + TYPE A_T1 IS ACCESS T1; + + TASK BODY T1 IS + BEGIN + ABORT T1; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T1 NOT ABORTED"); + END; + + BEGIN + DECLARE + V2 : T2; + A1 : A_T1; + BEGIN + DECLARE + V3 : T3; + TASK T4 IS + END T4; + TASK BODY T4 IS + TASK T41 IS + END T41; + TASK BODY T41 IS + BEGIN + COMMENT("T41"); + ABORT T4; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T41 NOT ABORTED"); + END; + BEGIN --T4 + COMMENT("T4"); + END; + BEGIN + COMMENT("BLOC 3"); + END; + COMMENT("BLOC 2"); + A1 := NEW T1; + END; + COMMENT("BLOC 1"); + EXCEPTION + WHEN OTHERS => FAILED("SOME EXCEPTION RAISED"); + END; + + RESULT; + +END C94020A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940a03.a b/gcc/testsuite/ada/acats/tests/c9/c940a03.a new file mode 100644 index 000000000..22876d26b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940a03.a @@ -0,0 +1,350 @@ +-- C940A03.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 protected object provides coordinated access to +-- shared data. Check that it can implement a semaphore-like construct +-- controlling access to shared data through procedure parameters to +-- allow a specific maximum number of tasks to run and exclude all +-- others. +-- +-- TEST DESCRIPTION: +-- Declare a resource descriptor tagged type. Extend the type and +-- use the extended type in a protected data structure. +-- Implement a counting semaphore type that can be initialized to a +-- specific number of available resources. Declare an entry for +-- requesting a specific resource and an procedure for releasing the +-- same resource it. Declare an object of this (protected) type, +-- initialized to two resources. Declare and start three tasks each +-- of which asks for a resource. Verify that only two resources are +-- granted and that the last task in is queued. +-- +-- This test models a multi-user operating system that allows a limited +-- number of logins. Users requesting login are modeled by tasks. +-- +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F940A00 +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +package C940A03_0 is + --Resource_Pkg + + -- General type declarations that will be extended to model available + -- logins + + type Resource_ID_Type is range 0..10; + type Resource_Type is tagged record + Id : Resource_ID_Type := 0; + end record; + +end C940A03_0; + --Resource_Pkg + +--======================================-- +-- no body for C940A3_0 +--======================================-- + +with F940A00; -- Interlock_Foundation +with C940A03_0; -- Resource_Pkg; + +package C940A03_1 is + -- Semaphores + + -- Models a counting semaphore that will allow up to a specific + -- number of logins + -- Users (tasks) request a login slot by calling the Request_Login + -- entry and logout by calling the Release_Login procedure + + Max_Logins : constant Integer := 2; + + + type Key_Type is range 0..100; + -- When a user requests a login, an + -- identifying key will be returned + Init_Key : constant Key_Type := 0; + + type Login_Record_Type is new C940A03_0.Resource_Type with record + Key : Key_Type := Init_Key; + end record; + + + protected type Login_Semaphore_Type (Resources_Available : Integer :=1) is + + entry Request_Login (Resource_Key : in out Login_Record_Type); + procedure Release_Login; + function Available return Integer; -- how many logins are available? + private + Logins_Avail : Integer := Resources_Available; + Next_Key : Key_Type := Init_Key; + + end Login_Semaphore_Type; + + Login_Semaphore : Login_Semaphore_Type (Max_Logins); + + --====== machinery for the test, not the model =====-- + TC_Control_Message : F940A00.Interlock_Type; + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer; + + +end C940A03_1; + -- Semaphores; + +--=========================================================-- + +package body C940A03_1 is + -- Semaphores is + + protected body Login_Semaphore_Type is + + entry Request_Login (Resource_Key : in out Login_Record_Type) + when Logins_Avail > 0 is + begin + Next_Key := Next_Key + 1; -- login process returns a key + Resource_Key.Key := Next_Key; -- to the requesting user + Logins_Avail := Logins_Avail - 1; + end Request_Login; + + procedure Release_Login is + begin + Logins_Avail := Logins_Avail + 1; + end Release_Login; + + function Available return Integer is + begin + return Logins_Avail; + end Available; + + end Login_Semaphore_Type; + + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer is + begin + return Integer (Login_Rec.Key); + end TC_Key_Val; + +end C940A03_1; + -- Semaphores; + +--=========================================================-- + +with C940A03_0; -- Resource_Pkg, +with C940A03_1; -- Semaphores; + +package C940A03_2 is + -- Task_Pkg + + package Semaphores renames C940A03_1; + + task type User_Task_Type is + + entry Login (user_id : C940A03_0.Resource_Id_Type); + -- instructs the task to ask for a login + entry Logout; -- instructs the task to release the login + --=======================-- + -- this entry is used to get information to verify test operation + entry Get_Status (User_Record : out Semaphores.Login_Record_Type); + + end User_Task_Type; + +end C940A03_2; + -- Task_Pkg + +--=========================================================-- + +with Report; +with C940A03_0; -- Resource_Pkg, +with C940A03_1; -- Semaphores, +with F940A00; -- Interlock_Foundation; + +package body C940A03_2 is + -- Task_Pkg + + -- This task models a user requesting a login from the system + -- For control of this test, we can ask the task to login, logout, or + -- give us the current user record (containing login information) + + task body User_Task_Type is + Rec : Semaphores.Login_Record_Type; + begin + loop + select + accept Login (user_id : C940A03_0.Resource_Id_Type) do + Rec.Id := user_id; + end Login; + + Semaphores.Login_Semaphore.Request_Login (Rec); + -- request a resource; if resource is not available, + -- task will be queued to wait + + --== following is test control machinery ==-- + F940A00.Counter.Increment; + Semaphores.TC_Control_Message.Post; + -- after resource is obtained, post message + + or + accept Logout do + Semaphores.Login_Semaphore.Release_Login; + -- release the resource + --== test control machinery ==-- + F940A00.Counter.Decrement; + end Logout; + exit; + + or + accept Get_Status (User_Record : out Semaphores.Login_Record_Type) do + User_Record := Rec; + end Get_Status; + + end select; + end loop; + + exception + when others => Report.Failed ("Exception raised in model user task"); + end User_Task_Type; + +end C940A03_2; + -- Task_Pkg + +--=========================================================-- + +with Report; +with ImpDef; +with C940A03_1; -- Semaphores, +with C940A03_2; -- Task_Pkg, +with F940A00; -- Interlock_Foundation; + +procedure C940A03 is + + package Semaphores renames C940A03_1; + package Users renames C940A03_2; + + Task1, Task2, Task3 : Users.User_Task_Type; + User_Rec : Semaphores.Login_Record_Type; + +begin -- Tasks start here + + Report.Test ("C940A03", "Check that a protected object can coordinate " & + "shared data access using procedure parameters"); + + if F940A00.Counter.Number /=0 then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Login (1); -- request resource; request should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + -- Task 1 waiting for call to Logout + -- Others still available + Task1.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) + or (Semaphores.TC_Key_Val (User_Rec) /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Login (2); -- Request for resource should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + Task2.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 2) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + + Task3.Login (3); -- request for resource should be denied + -- and task queued + + + -- Tasks 1 and 2 holds resources + -- and are waiting for a call to Logout + -- Task 3 is queued + + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) then + Report.Failed ("Resource incorrectly assigned to task 3"); + end if; + + Task1.Logout; -- released resource should be given to + -- queued task + Semaphores.TC_Control_Message.Consume; + -- wait for confirming message from task + + -- Task 1 holds no resources + -- and is terminated (or will soon) + -- Tasks 2 and 3 hold resources + -- and are waiting for a call to Logout + + Task3.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 3) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Task2.Logout; -- no outstanding request for released + -- resource + -- Tasks 1 and 2 hold no resources + -- Task 3 holds a resource + -- and is waiting for a call to Logout + + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Task3.Logout; + + -- all resources have been returned + -- all tasks have terminated or will soon + + if (F940A00.Counter.Number /=0) + or (Semaphores.Login_Semaphore.Available /=2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + -- Ensure all tasks have terminated before calling Result + while not (Task1'terminated and + Task2'terminated and + Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C940A03; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95008a.ada b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada new file mode 100644 index 000000000..4343e651b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada @@ -0,0 +1,426 @@ +-- C95008A.ADA + +-- 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. +--* +-- CHECK THAT THE EXCEPTION CONSTRAINT_ERROR IS RAISED FOR AN +-- OUT-OF-RANGE INDEX VALUE WHEN REFERENCING AN ENTRY FAMILY, +-- EITHER IN AN ACCEPT_STATEMENT OR IN AN ENTRY_CALL. + +-- SUBTESTS ARE: +-- (A) INTEGER TYPE, STATIC LOWER BOUND, NO PARAMETERS. +-- (B) CHARACTER TYPE, DYNAMIC UPPER BOUND, NO PARAMETERS. +-- (C) BOOLEAN TYPE, STATIC NULL RANGE, NO PARAMETERS. +-- (D) USER-DEFINED ENUMERATED TYPE, DYNAMIC LOWER BOUND, ONE +-- PARAMETER. +-- (E) DERIVED INTEGER TYPE, DYNAMIC NULL RANGE, ONE PARAMETER. +-- (F) DERIVED USER-DEFINED ENUMERATED TYPE, STATIC UPPER BOUND, +-- ONE PARAMETER. + +-- JRK 11/4/81 +-- JBG 11/11/84 +-- SAIC 11/14/95 fixed test for 2.0.1 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C95008A IS + + C_E_NOT_RAISED : BOOLEAN; + WRONG_EXC_RAISED : BOOLEAN; + +BEGIN + TEST ("C95008A", "OUT-OF-RANGE ENTRY FAMILY INDICES IN " & + "ACCEPT_STATEMENTS AND ENTRY_CALLS"); + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (A) + + TASK T IS + ENTRY E (1..10); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (0); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (A) + + SELECT + T.E (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + EXCEPTION -- (A) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + END; -- (A) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (B) + + TASK T IS + ENTRY E (CHARACTER RANGE 'A'..'Y'); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (IDENT_CHAR('Z')); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (B) + + SELECT + T.E (IDENT_CHAR('Z')); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + EXCEPTION -- (B) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + END; -- (B) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (C) + + TASK T IS + ENTRY E (TRUE..FALSE); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (FALSE); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (C) + + SELECT + T.E (TRUE); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + EXCEPTION -- (C) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + END; -- (C) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (D) + + TYPE ET IS (E0, E1, E2); + DLB : ET := ET'VAL (IDENT_INT(1)); -- E1. + + TASK T IS + ENTRY E (ET RANGE DLB..E2) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (E0) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (D) + + SELECT + T.E (E0) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + EXCEPTION -- (D) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + END; -- (D) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (E) + + TYPE D_I IS NEW INTEGER; + SUBTYPE DI IS D_I RANGE 3 .. D_I(IDENT_INT(2)); + + TASK T IS + ENTRY E (DI) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_I(3)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (E) + + SELECT + T.E (D_I(2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + EXCEPTION -- (E) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + END; -- (E) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (F) + + TYPE ET IS (E0, E1, E2); + TYPE D_ET IS NEW ET; + + TASK T IS + ENTRY E (D_ET RANGE E0..E1) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_ET'(E2)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (F) + + SELECT + T.E (D_ET'(E2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + EXCEPTION -- (F) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + END; -- (F) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + -------------------------------------------------- + + RESULT; +END C95008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95009a.ada b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada new file mode 100644 index 000000000..30830e96c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada @@ -0,0 +1,121 @@ +-- C95009A.ADA + +-- 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. +--* +-- CHECK THAT A TASK OBJECT CAN CALL ENTRIES OF OTHER TASKS. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JRK 8/3/84 + +WITH REPORT; USE REPORT; +PROCEDURE C95009A IS + + V1 : INTEGER := 0; + V2 : INTEGER := 0; + + PI : INTEGER := 0; + PO : INTEGER := 0; + +BEGIN + TEST ("C95009A", "CHECK THAT A TASK OBJECT CAN CALL ENTRIES " & + "OF OTHER TASKS"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T1 IS + ENTRY E1N; + ENTRY EF1P (INT) (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2P (I : INTEGER); + ENTRY EF2N (INT); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + V1 := 1; + ACCEPT E1N; + V1 := 2; + AT2.E2P (1); + V1 := 3; + ACCEPT EF1P (2) (I : OUT INTEGER) DO + I := 2; + END EF1P; + V1 := 4; + AT2.EF2N (IDENT_INT(3)); + V1 := 5; + END T1; + + TASK BODY T2T IS + BEGIN + V2 := 1; + T1.E1N; + V2 := 2; + ACCEPT E2P (I : INTEGER) DO + PI := I; + END E2P; + V2 := 3; + T1.EF1P (2) (PO); + V2 := 4; + ACCEPT EF2N (1+IDENT_INT(2)); + V2 := 5; + END T2T; + + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + AT2 := NEW T2T; + END DUMMY; + + BEGIN + NULL; + END; + + IF V1 /= 5 THEN + FAILED ("TASK T1 ONLY REACHED V1 = " & INTEGER'IMAGE(V1)); + END IF; + + IF V2 /= 5 THEN + FAILED ("TASK AT2 ONLY REACHED V2 = " & INTEGER'IMAGE(V2)); + END IF; + + IF PI /= 1 THEN + FAILED ("ENTRY IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + + IF PO /= 2 THEN + FAILED ("ENTRY OUT PARAMETER NOT PASSED CORRECTLY"); + END IF; + + RESULT; +END C95009A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95010a.ada b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada new file mode 100644 index 000000000..362956058 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada @@ -0,0 +1,82 @@ +-- C95010A.ADA + +-- 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. +--* +-- CHECK THAT A TASK MAY CONTAIN MORE THAN ONE ACCEPT_STATEMENT +-- FOR AN ENTRY. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C95010A IS + + V : INTEGER := 0; + +BEGIN + TEST ("C95010A", "CHECK THAT A TASK MAY CONTAIN MORE THAN " & + "ONE ACCEPT_STATEMENT FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + ACCEPT E; + V := 2; + ACCEPT E; + V := 3; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 5; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 7; + END T; + + BEGIN + + T.E; + T.E; + T.EF (2) (4); + T.EF (2) (6); + + END; + + IF V /= 7 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; +END C95010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95011a.ada b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada new file mode 100644 index 000000000..1e91a847c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada @@ -0,0 +1,67 @@ +-- C95011A.ADA + +-- 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. +--* +-- CHECK THAT A TASK NEED NOT CONTAIN ANY ACCEPT_STATEMENTS FOR AN +-- ENTRY. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C95011A IS + + V : INTEGER := 0; + +BEGIN + TEST ("C95011A", "CHECK THAT A TASK NEED NOT CONTAIN ANY " & + "ACCEPT_STATEMENTS FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + END T; + + BEGIN + + NULL; + + END; + + IF V /= 1 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; +END C95011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95012a.ada b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada new file mode 100644 index 000000000..2f7efaacb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada @@ -0,0 +1,106 @@ +-- C95012A.ADA + +-- 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. +--* +-- CHECK THAT A CALL TO AN ENTRY OF A TASK THAT HAS NOT BEEN ACTIVATED +-- DOES NOT RAISE EXCEPTIONS. + +-- THIS TEST CONTAINS RACE CONDITIONS. + +-- JRK 11/6/81 +-- SPS 11/21/82 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95012A IS + + I : INTEGER := 0; + + +BEGIN + TEST ("C95012A", "CHECK THAT A CALL TO AN ENTRY OF A TASK " & + "THAT HAS NOT BEEN ACTIVATED DOES NOT " & + "RAISE EXCEPTIONS"); + + DECLARE + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2 (I : OUT INTEGER); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER) DO + I := IDENT_INT (1); + END E1; + END T1; + + TASK BODY T2T IS + J : INTEGER := 0; + BEGIN + BEGIN + T1.E1 (J); + EXCEPTION + WHEN OTHERS => + J := -1; + END; + ACCEPT E2 (I : OUT INTEGER) DO + I := J; + END E2; + END T2T; + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + AT2 := NEW T2T; + DELAY 60.0 * Impdef.One_Second; + END PKG; + + BEGIN + + AT2.ALL.E2 (I); + + IF I = -1 THEN + FAILED ("EXCEPTION RAISED"); + T1.E1 (I); + END IF; + + IF I /= 1 THEN + FAILED ("WRONG VALUE PASSED"); + END IF; + + END; + + RESULT; +END C95012A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95021a.ada b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada new file mode 100644 index 000000000..a0c047bad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada @@ -0,0 +1,182 @@ +-- C95021A.ADA + +-- 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. +--* +-- CHECK THAT CALLS TO AN ENTRY ARE PLACED IN A FIFO QUEUE. + +-- JBG 2/22/84 +-- DAS 10/8/90 ADDED PRAGMA PRIORITY TO ENSURE THAT THE FIFO +-- DISCIPLINE MUST BE FOLLOWED (OTHERWISE THE +-- IMPLEMENTATION MIGHT PROHIBIT QUEUES FROM +-- FORMING SO THAT E'COUNT IS ALWAYS ZERO FOR +-- AN ENTRY E). +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +-- THE TASK QUEUE IS THE TASK THAT CHECKS THE QUEUEING DISCIPLINE. +-- +-- THIS TEST PLACES TWO CALLS ON AN ENTRY, WAITS UNTIL ONE OF THE CALLS +-- IS ACCEPTED, AND THEN PLACES A THIRD CALL ON THE ENTRY. THE TEST +-- CHECKS THAT THE SECOND CALL IS HANDLED BEFORE THE THIRD. (IT IS +-- NONDETERMINISTIC WHICH CALL WILL BE THE FIRST ONE ON THE QUEUE, SO +-- THIS MORE COMPLICATED APPROACH IS NECESSARY.) +-- +-- THE TASK DISPATCH FIRES UP THE TWO TASKS THAT MAKE THE FIRST TWO +-- CALLS AND THEN WAITS UNTIL QUEUE SAYS IT IS READY FOR THE THIRD CALL. +-- +-- THE TASK TYPE CALLERS IS USED TO CREATE TASKS THAT WILL CALL THE +-- ENTRY IN THE TASK QUEUE. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE C95021A IS +BEGIN + + TEST ("C95021A", "CHECK THAT ENTRY CALLS ARE PUT IN FIFO QUEUES"); + +-- DO THIS TEST 3 TIMES TO ALLOW FOR RANDOM VARIATIONS IN TIMING. + FOR I IN 1..3 LOOP + COMMENT ("ITERATION" & INTEGER'IMAGE(I)); + + DECLARE + + TASK TYPE CALLERS IS + ENTRY NAME (N : NATURAL); + END CALLERS; + + TASK QUEUE IS + ENTRY GO; + ENTRY E1 (NAME : NATURAL); + END QUEUE; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + TASK BODY CALLERS IS + MY_NAME : NATURAL; + BEGIN + +-- GET NAME OF THIS TASK OBJECT + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + +-- PUT THIS TASK ON QUEUE FOR QUEUE.E1 + QUEUE.E1 (MY_NAME); + END CALLERS; + + TASK BODY DISPATCH IS + TYPE ACC_CALLERS IS ACCESS CALLERS; + OBJ : ACC_CALLERS; + BEGIN + +-- FIRE UP TWO CALLERS FOR QUEUE.E1 + OBJ := NEW CALLERS; + OBJ.NAME(1); + OBJ := NEW CALLERS; + OBJ.NAME(2); + +-- ALLOW THESE CALLS TO BE PROCESSED (ONLY ONE WILL BE ACCEPTED). + QUEUE.GO; + +-- WAIT TILL ONE CALL HAS BEEN PROCESSED. + ACCEPT READY; -- CALLED FROM QUEUE + +-- FIRE UP THIRD CALLER + OBJ := NEW CALLERS; + OBJ.NAME(3); + + END DISPATCH; + + TASK BODY QUEUE IS + NEXT : NATURAL; -- NUMBER OF SECOND CALLER IN QUEUE. + BEGIN + +-- WAIT UNTIL TWO TASKS CALLING E1 HAVE BEEN ACTIVATED. + ACCEPT GO; + +-- WAIT FOR TWO CALLS TO BE AVAILABLE. THIS WAIT ASSUMES THAT THE +-- CALLER TASKS WILL PROCEED IF THIS TASK IS EXECUTING A DELAY +-- STATEMENT, ALTHOUGH THIS IS NOT STRICTLY REQUIRED BY THE STANDARD. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 1"); + END IF; + +-- ASSUMING NO FAILURE, PROCESS ONE OF THE QUEUED CALLS. + ACCEPT E1 (NAME : NATURAL) DO + +-- GET NAME OF NEXT CALLER + CASE NAME IS + WHEN 1 => + NEXT := 2; + WHEN 2 => + NEXT := 1; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR"); + END CASE; + END E1; + +-- TELL DISPATCH TO FIRE UP NEXT CALLER (ONE IS STILL IN QUEUE). + DISPATCH.READY; + +-- WAIT FOR CALL TO ARRIVE. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 2"); + END IF; + +-- ASSUMING NO FAILURE, ACCEPT SECOND CALL AND CHECK THAT IT IS FROM THE +-- CORRECT TASK. + ACCEPT E1 (NAME : NATURAL) DO + IF NAME /= NEXT THEN + FAILED ("FIFO DISCIPLINE NOT OBEYED"); + END IF; + END E1; + +-- ACCEPT THE LAST CALLER + ACCEPT E1 (NAME : NATURAL); + + END QUEUE; + + BEGIN + NULL; + END; -- ALL TASKS NOW TERMINATED. + END LOOP; + + RESULT; + +END C95021A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022a.ada b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada new file mode 100644 index 000000000..c7e4bcbe2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada @@ -0,0 +1,115 @@ +--C95022A.ADA + +-- 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. +--* +--CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE THE +--THE BODY OF AN ACCEPT STATEMENT. + +--CHECK THE CASE OF NORMAL ENTRY TERMINATION. + +-- JEAN-PIERRE ROSEN 25-FEB-1984 +-- JBG 6/1/84 + +-- FOUR CLIENT TASKS CALL ONE SERVER TASK. EACH CLIENT CALLS JUST ONE +-- ENTRY OF THE SERVER TASK. THE TEST CHECKS TO BE SURE THAT CALLS FROM +-- DIFFERENT TASKS ARE NOT MIXED UP. + +WITH REPORT; USE REPORT; +PROCEDURE C95022A IS + +BEGIN + TEST("C95022A", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY"); + DECLARE + + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + ENTRY RESTART; + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK SERVER IS + ENTRY E1 (I : IN OUT INTEGER); + ENTRY E2 (I : IN OUT INTEGER); + ENTRY E3 (I : IN OUT INTEGER); + ENTRY E4 (I : IN OUT INTEGER); + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 (I : IN OUT INTEGER) DO + ACCEPT E2 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + ACCEPT E3 (I : IN OUT INTEGER) DO + ACCEPT E4 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + END E4; + I := IDENT_INT(I); + END E3; + END E2; + I := IDENT_INT(I); + END E1; + + FOR I IN 1 .. 4 LOOP + T_ARR(I).RESTART; + END LOOP; + END SERVER; + + TASK BODY CLIENT IS + ID : INTEGER; + SAVE_ID : INTEGER; + BEGIN + ACCEPT GET_ID (I : INTEGER) DO + ID := I; + END GET_ID; + + SAVE_ID := ID; + + CASE ID IS + WHEN 1 => SERVER.E1(ID); + WHEN 2 => SERVER.E2(ID); + WHEN 3 => SERVER.E3(ID); + WHEN 4 => SERVER.E4(ID); + WHEN OTHERS => FAILED("INCORRECT ID"); + END CASE; + + ACCEPT RESTART; -- WAIT FOR ALL TASKS TO HAVE COMPLETED + -- RENDEZVOUS + IF ID /= SAVE_ID THEN + FAILED("SCRAMBLED EMBEDDED RENDEZVOUS"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED("EXCEPTION IN CLIENT"); + END CLIENT; + + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + +END C95022A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022b.ada b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada new file mode 100644 index 000000000..cd1e3ff5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada @@ -0,0 +1,112 @@ +-- C95022B.ADA + +-- 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. +--* +-- CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE +-- THE BODY OF AN ACCEPT STATEMENT. + +-- CHECK THE CASE OF ABORT DURING THE INNERMOST ACCEPT. + +-- JEAN-PIERRE ROSEN 25-FEB-1984 +-- JBG 6/1/84 + +WITH REPORT; USE REPORT; +PROCEDURE C95022B IS + +BEGIN + + TEST("C95022B", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY (ABORT CASE)"); + DECLARE + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK KILL IS + ENTRY ME; + END KILL; + + TASK SERVER IS + ENTRY E1; + ENTRY E2; + ENTRY E3; + ENTRY E4; + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 DO + ACCEPT E2 DO + ACCEPT E3 DO + ACCEPT E4 DO + KILL.ME; + E1; -- WILL DEADLOCK UNTIL ABORT. + END E4; + END E3; + END E2; + END E1; + + END SERVER; + + TASK BODY KILL IS + BEGIN + ACCEPT ME; + ABORT SERVER; + END; + + TASK BODY CLIENT IS + ID : INTEGER; + BEGIN + ACCEPT GET_ID( I : INTEGER) DO + ID := I; + END GET_ID; + + CASE ID IS + WHEN 1 => SERVER.E1; + WHEN 2 => SERVER.E2; + WHEN 3 => SERVER.E3; + WHEN 4 => SERVER.E4; + WHEN OTHERS => FAILED ("INCORRECT ID"); + END CASE; + + FAILED ("TASKING_ERROR NOT RAISED IN CLIENT" & + INTEGER'IMAGE(ID)); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("EXCEPTION IN CLIENT" & INTEGER'IMAGE(ID)); + END CLIENT; + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + +END C95022B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033a.ada b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada new file mode 100644 index 000000000..53c354856 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada @@ -0,0 +1,74 @@ +-- C95033A.ADA + +-- 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. +--* +-- CHECK THAT - IN THE CASE OF AN ENTRY FAMILY - EXECUTION OF AN +-- ACCEPT STATEMENT STARTS WITH THE EVALUATION OF AN ENTRY INDEX. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BGA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95033A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2); + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (FINIT_POS (1)) DO + PSPY_NUMB (2); + END E1; + ACCEPT BYE; + END T1; + +BEGIN + TEST ("C95033A", "EVALUATION OF ENTRY INDEX"); + + T1.E1 (1); + T1.BYE; + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95033A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033b.ada b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada new file mode 100644 index 000000000..a72f3b6a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada @@ -0,0 +1,67 @@ +-- C95033B.ADA + +-- 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. +--* +-- CHECK THAT EXECUTION OF AN ENTRY CALL STARTS WITH THE EVALUATION OF +-- ANY ENTRY INDEX, FOLLOWED BY THE EVALUATION OF ANY EXPRESSION IN +-- THE PARAMETER LIST. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BHA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95033B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2) (P1 : IN NATURAL); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (1) (P1 : IN NATURAL); + END T1; + +BEGIN + + TEST ("C95033B", "EVALUATION OF ENTRY INDEX AND OF " & + "EXPRESSIONS IN PARAMETER LIST"); + + T1.E1 (FINIT_POS (1)) (FINIT_POS (2)); + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95033B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034a.ada b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada new file mode 100644 index 000000000..c597bf25f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada @@ -0,0 +1,85 @@ +-- C95034A.ADA + +-- 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. +--* +-- CHECK THAT A CALLING TASK IS SUSPENDED IF THE RECEIVING TASK +-- HAS NOT REACHED A CORRESPONDING ACCEPT STATEMENT. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BJA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95034A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY E2; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E2; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + +BEGIN + + TEST ("C95034A", "SUSPENSION OF CALLING TASK"); + + T1.E1; + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95034A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034b.ada b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada new file mode 100644 index 000000000..3c491e70a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada @@ -0,0 +1,83 @@ +-- C95034B.ADA + +-- 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. +--* +-- CHECK THAT A CALLING TASK REMAINS SUSPENDED UNTIL THE ACCEPT +-- STATEMENT RECEIVING THIS ENTRY CALL HAS COMPLETED THE EXECUTION OF +-- ITS SEQUENCE OF STATEMENTS. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CBA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95034B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (2); + END E1; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + +BEGIN + + TEST ("C95034B", "TASK SUSPENSION UNTIL COMPLETION OF ACCEPT " & + "STATEMENT"); + + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95034B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95035a.ada b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada new file mode 100644 index 000000000..ce7816628 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada @@ -0,0 +1,78 @@ +-- C95035A.ADA + +-- 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. +--* +-- CHECK THAT A TASK IS SUSPENDED IF IT REACHES AN ACCEPT STATEMENT +-- PRIOR TO ANY CALL OF THE CORRESPONDING ENTRY. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CAA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95035A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + PSPY_NUMB (2); + ACCEPT BYE; + END T1; + + TASK T2; + + TASK BODY T2 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + T1.E1; + END T2; + +BEGIN + + TEST ("C95035A", "TASK SUSPENSION PRIOR TO ENTRY CALL"); + + T1.BYE; + + IF SPYNUMB /= 12 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95035A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040a.ada b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada new file mode 100644 index 000000000..aa302bd1e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada @@ -0,0 +1,59 @@ +-- C95040A.ADA + +-- 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. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED IF AN ENTRY OF A +-- COMPLETED TASK IS CALLED. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CHA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95040A IS +BEGIN + + TEST ("C95040A", "ENTRY CALL OF COMPLETED TASK"); + +BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + END T1; + BEGIN -- BLOCK1 + T1.E1; + T1.E1; + + FAILED ("DID NOT RAISE TASKING_ERROR"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + END BLOCK1; + + RESULT; + +END C95040A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040b.ada b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada new file mode 100644 index 000000000..aee275f28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada @@ -0,0 +1,63 @@ +-- C95040B.ADA + +-- 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. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED BY A TASK IF THE +-- TASK BECOMES COMPLETED OR ABNORMAL BEFORE ACCEPTING THE CALL. + +-- WEI 3/ 4/82 +-- TLB 10/30/87 RENAMED FROM C950CHC.ADA. + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95040B IS + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + IF EQUAL (1, 1) THEN + ABORT T1; + END IF; + ACCEPT E1; + END T1; + +BEGIN + + TEST ("C95040B", "TASK COMPLETION BEFORE ACCEPTING AN ENTRY CALL"); + + T1.E1; + + FAILED ("NO EXCEPTION TASKING_ERROR RAISED"); + + RESULT; + +EXCEPTION + WHEN TASKING_ERROR => + RESULT; + +END C95040B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040c.ada b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada new file mode 100644 index 000000000..cc7db5804 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada @@ -0,0 +1,86 @@ +-- C95040C.ADA + +-- 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. +--* +-- CHECKS THAT A TASK COMPLETED, BUT NOT TERMINATED (I.E. WAITING +-- FOR TERMINATION OF A DEPENDENT TASK) IS NEITHER 'TERMINATED NOR +-- 'CALLABLE. CALLS TO ENTRIES BELONGING TO SUCH A TASK RAISE +-- TASKING_ERROR. + +-- J.P. ROSEN, ADA PROJECT, NYU +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009A-B.ADA +-- PWN 9/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95040C IS +BEGIN + + TEST ("C95040C", "TASKING_ERROR RAISED WHEN CALLING COMPLETED " & + "BUT UNTERMINATED TASK"); + + DECLARE + + TASK T1 IS + ENTRY E; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + COMMENT ("BEGIN T2"); + T1.E; -- T1 WILL COMPLETE BEFORE THIS CALL + -- OR WHILE WAITING FOR THIS CALL TO + -- BE ACCEPTED. WILL DEADLOCK IF + -- TASKING_ERROR IS NOT RAISED. + FAILED ("NO TASKING_ERROR RAISED"); + EXCEPTION + WHEN TASKING_ERROR => + IF T1'CALLABLE THEN + FAILED ("T1 STILL CALLABLE"); + END IF; + + IF T1'TERMINATED THEN -- T1 CAN'T TERMINATE + -- UNTIL T2 HAS + -- TERMINATED. + FAILED ("T1 TERMINATED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END T2; + BEGIN + NULL; + END; + + BEGIN + NULL; + END; + + RESULT; + +END C95040C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040d.ada b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada new file mode 100644 index 000000000..cfe0a772d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada @@ -0,0 +1,122 @@ +-- C95040D.ADA + +-- 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. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IN A CALLING +-- TASK WHEN THE TASK OWNING THE ENTRY TERMINATES BEFORE RENDEZVOUS +-- CAN OCCUR. + +-- CHECK THAT RE-RAISING TASKING_ERROR, ONCE TRAPPED IN THE CALLER, +-- DOES NOT PROPAGATE OUTSIDE THE TASK BODY. + +-- GOM 11/29/84 +-- JWC 05/14/85 +-- PWB 02/11/86 CORRECTED CALL TO TEST TO SHOW CORRECT TEST NAME. +-- RLB 12/15/99 REMOVED POTENTIALLY ERRONEOUS CALLS TO REPORT.COMMENT. + +WITH REPORT; +USE REPORT; + +PROCEDURE C95040D IS + + PROCEDURE DRIVER IS + + TASK NEST IS + ENTRY OUTER; + ENTRY INNER; + END NEST; + + TASK SLAVE; + + TASK BODY NEST IS + BEGIN + --COMMENT("AT TOP OF 'NEST' TASK WAITING ON 'OUTER' " & + -- "RENDEZVOUS"); + + ACCEPT OUTER DO + --COMMENT("IN 'OUTER' RENDEZVOUS OF 'NEST' TASK " & + -- "ABOUT TO 'RETURN'"); + + RETURN; -- CAUSES 'INNER' RENDEZVOUS TO BE SKIPPED. + + ACCEPT INNER DO + FAILED("'INNER' RENDEZVOUS OF 'NEST' TASK " & + "SHOULD NEVER BE PERFORMED"); + END INNER; + END OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED IN 'NEST' TASK " & + -- "AND NOW TERMINATING"); + END NEST; + + TASK BODY SLAVE IS + BEGIN + --COMMENT("AT TOP OF 'SLAVE' TASK. CALLING 'INNER' " & + -- "RENDEZVOUS"); + + NEST.INNER; + + FAILED("SHOULD HAVE RAISED 'TASKING_ERROR' IN 'SLAVE' " & + "TASK"); + EXCEPTION + WHEN TASKING_ERROR => + --COMMENT("'SLAVE' TASK CORRECTLY TRAPPING " & + -- "'TASKING_ERROR' AND RE-RAISING IT (BUT " & + -- "SHOULD NOT BE PROPAGATED)"); + RAISE; + END SLAVE; + + BEGIN -- START OF DRIVER PROCEDURE. + + --COMMENT("AT TOP OF 'DRIVER'. CALLING 'OUTER' ENTRY OF " & + -- "'NEST' TASK"); + + NEST.OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED. 'DRIVER' AWAITING " & + -- "TERMINATION OF 'NEST' AND 'SLAVE' TASKS"); + + EXCEPTION + WHEN TASKING_ERROR => + FAILED("'TASKING_ERROR' CAUGHT IN 'DRIVER' WHEN IT " & + "SHOULD HAVE BEEN CAUGHT IN 'SLAVE' TASK, OR " & + "'TASKING_ERROR' WAS INCORRECTLY PROPAGATED BY " & + "'SLAVE' TASK"); + END DRIVER; + +BEGIN -- START OF MAIN PROGRAM. + + TEST("C95040D","CHECK THAT 'TASKING_ERROR' IS RAISED IN A " & + "CALLER TASK WHEN TASK OWNING THE ENTRY CANNOT " & + "PERFORM RENDEZVOUS. ALSO CHECK THAT " & + "'TASKING_ERROR', ONCE RAISED, IS NOT PROPAGATED " & + "OUTSIDE THE TASK BODY"); + + --COMMENT("MAIN PROGRAM CALLING 'DRIVER' PROCEDURE"); + + DRIVER; + + --COMMENT("MAIN PROGRAM NOW TERMINATING"); + + RESULT; +END C95040D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95041a.ada b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada new file mode 100644 index 000000000..4f676b3c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada @@ -0,0 +1,97 @@ +-- C95041A.ADA + +-- 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 AN ENTRY FAMILY INDEX CAN BE SPECIFIED WITH THE FORM +-- A'RANGE. + +-- HISTORY: +-- DHH 03/17/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C95041A IS + + GLOBAL_A, GLOBAL_B : INTEGER; + GLOBAL_C, GLOBAL_D : INTEGER; + TYPE COLOR IS (RED, BLUE, YELLOW); + TYPE ARR IS ARRAY(COLOR RANGE RED .. BLUE) OF BOOLEAN; + ARRY : ARR; + + TASK CHECK IS + ENTRY CHECK_LINK(ARR'RANGE)(I : INTEGER); + END CHECK; + + TASK CHECK_OBJ IS + ENTRY CHECK_OBJ_LINK(ARRY'RANGE)(I : INTEGER); + END CHECK_OBJ; + + TASK BODY CHECK IS + BEGIN + ACCEPT CHECK_LINK(RED)(I : INTEGER) DO + GLOBAL_A := IDENT_INT(I); + END; + + ACCEPT CHECK_LINK(BLUE)(I : INTEGER) DO + GLOBAL_B := IDENT_INT(I); + END; + END CHECK; + + TASK BODY CHECK_OBJ IS + BEGIN + ACCEPT CHECK_OBJ_LINK(RED)(I : INTEGER) DO + GLOBAL_C := IDENT_INT(I); + END; + + ACCEPT CHECK_OBJ_LINK(BLUE)(I : INTEGER) DO + GLOBAL_D := IDENT_INT(I); + END; + END CHECK_OBJ; + +BEGIN + TEST("C95041A", "CHECK THAT AN ENTRY FAMILY INDEX CAN BE " & + "SPECIFIED WITH THE FORM A'RANGE"); + CHECK.CHECK_LINK(RED)(10); + CHECK.CHECK_LINK(BLUE)(5); + + CHECK_OBJ.CHECK_OBJ_LINK(RED)(10); + CHECK_OBJ.CHECK_OBJ_LINK(BLUE)(5); + + IF GLOBAL_A /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_B /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_C /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_D /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + RESULT; +END C95041A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065a.ada b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada new file mode 100644 index 000000000..2224dddcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada @@ -0,0 +1,91 @@ +-- C95065A.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND +-- INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065A IS + +BEGIN + + TEST ("C95065A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. IDENT_INT(1), 1 .. IDENT_INT(10)) + OF INTEGER; + + TASK T IS + ENTRY E1 (A : A1 := ((1, 0), (0, 1))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, 0), (0, 1))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065b.ada b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada new file mode 100644 index 000000000..81226af3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada @@ -0,0 +1,91 @@ +-- C95065B.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS +-- INITIALIZED WITH A STATIC VALUE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065B IS + +BEGIN + + TEST ("C95065B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER + RANGE IDENT_INT(0) .. IDENT_INT(63); + + TASK T IS + ENTRY E1 (I : INT := -1); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (I : INT := -1) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065c.ada b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada new file mode 100644 index 000000000..3a7732e87 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada @@ -0,0 +1,97 @@ +-- C95065C.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC +-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065C IS + +BEGIN + + TEST ("C95065C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 3) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(3); + + TYPE REC IS + RECORD + I : INTEGER RANGE IDENT_INT(1)..IDENT_INT(3); + A : A1; + END RECORD; + + TASK T IS + ENTRY E1 (R : REC := (-3,(0,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC := (-3,(0,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065d.ada b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada new file mode 100644 index 000000000..36fc22c27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada @@ -0,0 +1,92 @@ +-- C95065D.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON +-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065D IS + +BEGIN + + TEST ("C95065D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := ((1, -1), (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, -1), (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065e.ada b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada new file mode 100644 index 000000000..95086f073 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada @@ -0,0 +1,92 @@ +-- C95065E.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (E) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON +-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065E IS + +BEGIN + + TEST ("C95065E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := (3 .. 4 => (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := (3 .. 4 => (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065f.ada b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada new file mode 100644 index 000000000..3451707af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada @@ -0,0 +1,97 @@ +-- C95065F.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (F) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT +-- INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065F IS + +BEGIN + + TEST ("C95065F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + TYPE A1 IS ARRAY (1 .. 3) OF INT; + TYPE REC (I : INT) IS + RECORD + A : A1; + END RECORD; + + SUBTYPE REC4 IS REC (IDENT_INT(4)); + + TASK T IS + ENTRY E1 (R : REC4 := (3,(1,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC4 := (3,(1,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95066a.ada b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada new file mode 100644 index 000000000..f9405d99b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada @@ -0,0 +1,214 @@ +-- C95066A.ADA + +-- 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. +--* +-- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME, +-- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER- +-- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION +-- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE +-- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE ENTRY +-- IS CALLED. + +-- GLH 6/19/85 + +WITH REPORT; +PROCEDURE C95066A IS + + USE REPORT; + + TYPE INT IS RANGE 1 .. 10; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + A : ARR (0..CONSTRAINT); + END RECORD; + + C7 : CONSTANT INTEGER := 7; + V7 : INTEGER := 7; + + TYPE A_INT IS ACCESS INTEGER; + C_A : CONSTANT A_INT := NEW INTEGER'(7); + + SUBTYPE RECTYPE1 IS RECTYPE (2 + 5); + SUBTYPE RECTYPE2 IS RECTYPE (C7); + SUBTYPE RECTYPE3 IS RECTYPE (V7); + + FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 10; + END "&"; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END FUNC; + + -- STATIC EXPRESSION. + + TASK T1 IS + ENTRY E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E1 PARAMETER"); + END IF; + END E1; + END T1; + + -- CONSTANT NAME. + + TASK T2 IS + ENTRY E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E2 PARAMETER"); + END IF; + END E2; + END T2; + + -- ATTRIBUTE NAME. + + TASK T3 IS + ENTRY E3 (P1 : INT := INT'LAST); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (P1 : INT := INT'LAST) DO + IF (P1 /= INT (10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E3 PARAMETER"); + END IF; + END E3; + END T3; + + -- VARIABLE. + + TASK T4 IS + ENTRY E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))); + END T4; + + TASK BODY T4 IS + BEGIN + ACCEPT E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) DO + IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E4 PARAMETER"); + END IF; + END E4; + END T4; + + -- DEREFERENCED ACCESS. + + TASK T5 IS + ENTRY E5 (P5 : INTEGER := C_A.ALL); + END T5; + + TASK BODY T5 IS + BEGIN + ACCEPT E5 (P5 : INTEGER := C_A.ALL) DO + IF (P5 /= C_A.ALL) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E5 PARAMETER"); + END IF; + END E5; + END T5; + + -- USER-DEFINED OPERATOR. + + TASK T6 IS + ENTRY E6 (P6 : INTEGER := 6&4); + END T6; + + TASK BODY T6 IS + BEGIN + ACCEPT E6 (P6 : INTEGER := 6&4) DO + IF (P6 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E6 PARAMETER"); + END IF; + END E6; + END T6; + + -- USER-DEFINED FUNCTION. + + TASK T7 IS + ENTRY E7 (P7 : INTEGER := FUNC(10)); + END T7; + + TASK BODY T7 IS + BEGIN + ACCEPT E7 (P7 : INTEGER := FUNC(10)) DO + IF (P7 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E7 PARAMETER"); + END IF; + END E7; + END T7; + + -- ALLOCATOR. + + TASK T8 IS + ENTRY E8 (P8 : A_INT := NEW INTEGER'(7)); + END T8; + + TASK BODY T8 IS + BEGIN + ACCEPT E8 (P8 : A_INT := NEW INTEGER'(7)) DO + IF (P8.ALL /= IDENT_INT(7)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E8 PARAMETER"); + END IF; + END E8; + END T8; + +BEGIN + TEST ("C95066A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " & + "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " & + "DEFINED OPERATORS, USER-DEFINED FUNCTIONS, " & + "DEREFERENCED ACCESSES, AND ALLOCATORS IN " & + "THE FORMAL PART OF A TASK SPECIFICATION"); + + T1.E1; + T2.E2; + T3.E3; + T4.E4; + T5.E5; + T6.E6; + T7.E7; + T8.E8; + + RESULT; + +END C95066A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95067a.ada b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada new file mode 100644 index 000000000..d4393d51d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada @@ -0,0 +1,302 @@ +-- C95067A.ADA + +-- 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. +--* +-- CHECK THAT A FORMAL PARAMETER OF MODE IN OR IN OUT CAN BE OF A +-- LIMITED TYPE, INCLUDING A COMPOSITE LIMITED TYPE. + +-- JWC 6/20/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95067A IS + + PACKAGE PKG IS + + TYPE ITYPE IS LIMITED PRIVATE; + + TASK T1 IS + + ENTRY LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER; + M : STRING); + + ENTRY SET_I (X : IN OUT ITYPE; V : INTEGER); + + END T1; + + SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20; + TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE; + + TASK T2 IS + + ENTRY LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING); + + ENTRY SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING); + + END T2; + + PRIVATE + + TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99; + + TYPE VRTYPE (C : INT_0_20 := 20) IS + RECORD + I : INTEGER; + S : STRING (1 .. C); + END RECORD; + + END PKG; + + USE PKG; + + I1 : ITYPE; + + TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE; + + A1 : ATYPE; + + VR1 : VRTYPE; + + D : CONSTANT INT_0_20 := 10; + + TYPE RTYPE IS + RECORD + J : ITYPE; + R : VRTYPE (D); + END RECORD; + + R1 : RTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_I (X : IN ITYPE; V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_IN_I; + OR + ACCEPT LOOK_INOUT_I (X : IN OUT ITYPE; + V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_INOUT_I; + OR + ACCEPT SET_I (X : IN OUT ITYPE; V : INTEGER) DO + X := ITYPE (IDENT_INT (V)); + END SET_I; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_IN_VR; + OR + ACCEPT LOOK_INOUT_VR (X : IN OUT VRTYPE; + C : INTEGER; I : INTEGER; + S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_INOUT_VR; + OR + ACCEPT SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING) DO + X := (IDENT_INT(C), IDENT_INT(I), + IDENT_STR(S)); + END SET_VR; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + BEGIN + I1 := ITYPE (IDENT_INT(2)); + + FOR I IN A1'RANGE LOOP + A1 (I) := ITYPE (3 + IDENT_INT(I)); + END LOOP; + + VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234")); + + R1.J := ITYPE (IDENT_INT(6)); + R1.R := (IDENT_INT(D), IDENT_INT(19), + IDENT_STR("ABCDEFGHIJ")); + END PKG; + + TASK T3 IS + ENTRY CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING); + + ENTRY CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; OS : STRING; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + + ENTRY CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) DO + T1.LOOK_IN_I (X, V, M); + END CHECK_IN_I; + + ACCEPT CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + T1.LOOK_INOUT_I (X, OV, M & " - A"); + T1.SET_I (X, NV); + T1.LOOK_INOUT_I (X, NV, M & " - B"); + T1.LOOK_IN_I (X, NV, M & " - C"); + END CHECK_INOUT_I; + + ACCEPT CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_IN_I (X(I), V+I, M & " -" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_IN_A; + + ACCEPT CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_INOUT_I (X(I), OV+I, M & " - A" & + INTEGER'IMAGE (I)); + T1.SET_I (X(I), NV+I); + T1.LOOK_INOUT_I (X(I), NV+I, M & " - B" & + INTEGER'IMAGE (I)); + T1.LOOK_IN_I (X(I), NV+I, M & " - C" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_INOUT_A; + + ACCEPT CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING) DO + T2.LOOK_IN_VR (X, C, I, S, M); + END CHECK_IN_VR; + + ACCEPT CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; + OS : STRING; + NC : INTEGER; NI : INTEGER; + NS : STRING; + M : STRING) DO + T2.LOOK_INOUT_VR (X, OC, OI, OS, M & " - A"); + T2.SET_VR (X, NC, NI, NS); + T2.LOOK_INOUT_VR (X, NC, NI, NS, M & " - B"); + T2.LOOK_IN_VR (X, NC, NI, NS, M & " - C"); + END CHECK_INOUT_VR; + + ACCEPT CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING) DO + T1.LOOK_IN_I (X.J, J, M & " - A"); + T2.LOOK_IN_VR (X.R, C, I, S, M & " - B"); + END CHECK_IN_R; + + ACCEPT CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING) DO + T1.LOOK_INOUT_I (X.J, OJ, M & " - A"); + T2.LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B"); + T1.SET_I (X.J, NJ); + T2.SET_VR (X.R, NC, NI, NS); + T1.LOOK_INOUT_I (X.J, NJ, M & " - C"); + T2.LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D"); + T1.LOOK_IN_I (X.J, NJ, M & " - E"); + T2.LOOK_IN_VR (X.R, NC, NI, NS, M & " - F"); + END CHECK_INOUT_R; + END T3; + +BEGIN + TEST ("C95067A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " & + "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS"); + + T3.CHECK_IN_I (I1, 2, "IN I"); + + T3.CHECK_INOUT_I (I1, 2, 5, "INOUT I"); + + T3.CHECK_IN_A (A1, 3, "IN A"); + + T3.CHECK_INOUT_A (A1, 3, 17, "INOUT A"); + + T3.CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR"); + + T3.CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210", + "INOUT VR"); + + T3.CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R"); + + T3.CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, + "ZYXWVUTSRQ", "INOUT R"); + + RESULT; +END C95067A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95071a.ada b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada new file mode 100644 index 000000000..a7153993d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada @@ -0,0 +1,230 @@ +-- C95071A.ADA + +-- 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. +--* +-- CHECK THAT OBJECTS DESIGNATED BY IN PARAMETERS OF ACCESS TYPES CAN +-- BE USED AS THE TARGET OF AN ASSIGNMENT STATEMENT AND AS AN ACTUAL +-- PARAMETER OF ANY MODE. SUBTESTS ARE: +-- (A) INTEGER ACCESS TYPE. +-- (B) ARRAY ACCESS TYPE. +-- (C) RECORD ACCESS TYPE. + +-- JWC 7/11/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95071A IS + +BEGIN + + TEST ("C95071A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS " & + "MAY BE USED IN ASSIGNMENT CONTEXTS"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE PTRINT IS ACCESS INTEGER; + PI : PTRINT; + + TASK TA IS + ENTRY EA (PI : IN PTRINT); + END TA; + + TASK BODY TA IS + BEGIN + ACCEPT EA (PI : IN PTRINT) DO + DECLARE + TASK TA1 IS + ENTRY EA1 (I : OUT INTEGER); + ENTRY EA2 (I : IN OUT INTEGER); + END TA1; + + TASK BODY TA1 IS + BEGIN + ACCEPT EA1 (I : OUT INTEGER) DO + I := 7; + END EA1; + + ACCEPT EA2 (I : IN OUT INTEGER) DO + I := I + 1; + END EA2; + END TA1; + + BEGIN + TA1.EA1 (PI.ALL); + TA1.EA2 (PI.ALL); + PI.ALL := PI.ALL + 1; + IF (PI.ALL /= 9) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "INTEGER ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EA; + END TA; + + BEGIN -- (A) + + PI := NEW INTEGER'(0); + TA.EA (PI); + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + TYPE TBL IS ARRAY (1..3) OF INTEGER; + TYPE PTRTBL IS ACCESS TBL; + PT : PTRTBL; + + TASK TB IS + ENTRY EB (PT : IN PTRTBL); + END TB; + + TASK BODY TB IS + BEGIN + ACCEPT EB (PT : IN PTRTBL) DO + DECLARE + TASK TB1 IS + ENTRY EB1 (T : OUT TBL); + ENTRY EB2 (T : IN OUT TBL); + ENTRY EB3 (I : OUT INTEGER); + ENTRY EB4 (I : IN OUT INTEGER); + END TB1; + + TASK BODY TB1 IS + BEGIN + ACCEPT EB1 (T : OUT TBL) DO + T := (1,2,3); + END EB1; + + ACCEPT EB2 (T : IN OUT TBL) DO + T(3) := T(3) - 1; + END EB2; + + ACCEPT EB3 (I : OUT INTEGER) DO + I := 7; + END EB3; + + ACCEPT EB4 (I : IN OUT INTEGER) DO + I := I + 1; + END EB4; + END TB1; + + BEGIN + TB1.EB1 (PT.ALL); -- (1,2,3) + TB1.EB2 (PT.ALL); -- (1,2,2) + TB1.EB3 (PT(2)); -- (1,7,2) + TB1.EB4 (PT(1)); -- (2,7,2) + PT(3) := PT(3) + 7; -- (2,7,9) + IF (PT.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "ARRAY ACCESS PARAMETER FAILED"); + END IF; + END; + END EB; + END TB; + + BEGIN -- (B) + + PT := NEW TBL'(0,0,0); + TB.EB (PT); + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + TYPE REC IS + RECORD + I1 : INTEGER; + I2 : INTEGER; + I3 : INTEGER; + END RECORD; + + TYPE PTRREC IS ACCESS REC; + PR : PTRREC; + + TASK TC IS + ENTRY EC (PR : IN PTRREC); + END TC; + + TASK BODY TC IS + BEGIN + ACCEPT EC (PR : IN PTRREC) DO + DECLARE + TASK TC1 IS + ENTRY EC1 (R : OUT REC); + ENTRY EC2 (R : IN OUT REC); + ENTRY EC3 (I : OUT INTEGER); + ENTRY EC4 (I : IN OUT INTEGER); + END TC1; + + TASK BODY TC1 IS + BEGIN + ACCEPT EC1 (R : OUT REC) DO + R := (1,2,3); + END EC1; + + ACCEPT EC2 (R : IN OUT REC) DO + R.I3 := R.I3 - 1; + END EC2; + + ACCEPT EC3 (I : OUT INTEGER) DO + I := 7; + END EC3; + + ACCEPT EC4 (I : IN OUT INTEGER) DO + I := I + 1; + END EC4; + END TC1; + + BEGIN + TC1.EC1 (PR.ALL); -- (1,2,3) + TC1.EC2 (PR.ALL); -- (1,2,2) + TC1.EC3 (PR.I2); -- (1,7,2) + TC1.EC4 (PR.I1); -- (2,7,2) + PR.I3 := PR.I3 + 7; -- (2,7,9) + IF (PR.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "RECORD ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EC; + END TC; + + BEGIN -- (C) + + PR := NEW REC'(0,0,0); + TC.EC (PR); + + END; -- (C) + + --------------------------------------------- + + RESULT; + +END C95071A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072a.ada b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada new file mode 100644 index 000000000..261007b27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada @@ -0,0 +1,197 @@ +-- C95072A.ADA + +-- 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. +--* +-- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED FOR ALL THREE +-- PARAMETER MODES. +-- SUBTESTS ARE: +-- (A) SCALAR PARAMETERS TO ENTRIES. +-- (B) ACCESS PARAMETERS TO ENTRIES. + +-- JWC 7/22/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95072A IS + +BEGIN + TEST ("C95072A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " & + "COPIED"); + + -------------------------------------------------- + + DECLARE -- (A) + + I : INTEGER; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER); + END TA; + + TASK BODY TA IS + + TMP : INTEGER; + + BEGIN + + ACCEPT EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := 10; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := EIO + 100; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + I := I + 1; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A) + + I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= 1 THEN + CASE I IS + WHEN 11 => + FAILED ("OUT ACTUAL SCALAR PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL SCALAR " & + "PARAMETERS CHANGED GLOBAL " & + "VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO GLOBAL " & + "VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ACCTYPE IS ACCESS INTEGER; + + I : ACCTYPE; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE); + END TB; + + TASK BODY TB IS + + TMP : ACCTYPE; + + BEGIN + + ACCEPT EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := NEW INTEGER'(101); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EO := NEW INTEGER'(1); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := NEW INTEGER'(10); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B) + + I := NEW INTEGER'(100); + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I.ALL /= 101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B) + + -------------------------------------------------- + + RESULT; +END C95072A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072b.ada b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada new file mode 100644 index 000000000..ba1b91ed1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada @@ -0,0 +1,278 @@ +-- C95072B.ADA + +-- 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. +--* +-- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE +-- PASSED BY COPY FOR ALL MODES. +-- SUBTESTS ARE: +-- (A) PRIVATE SCALAR PARAMETERS TO ENTRIES. +-- (B) PRIVATE ACCESS PARAMETERS TO ENTRIES. + +-- JWC 7/22/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95072B IS + +BEGIN + TEST("C95072B", "CHECK THAT PRIVATE SCALAR AND ACCESS " & + "PARAMETERS ARE COPIED"); + + --------------------------------------------------- + + DECLARE -- (A) + + PACKAGE SCALAR_PKG IS + + TYPE T IS PRIVATE; + C0 : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T; + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER; + + PRIVATE + + TYPE T IS NEW INTEGER; + C0 : CONSTANT T := 0; + C1 : CONSTANT T := 1; + C10 : CONSTANT T := 10; + C100 : CONSTANT T := 100; + + END SCALAR_PKG; + + PACKAGE BODY SCALAR_PKG IS + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS + BEGIN + RETURN T (INTEGER(OLD) + INTEGER(INCREMENT)); + END "+"; + + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS + BEGIN + RETURN INTEGER (OLD_PRIVATE); + END CONVERT; + + END SCALAR_PKG; + + USE SCALAR_PKG; + + BEGIN -- (A) + + DECLARE -- (A1) + + I : T; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TA; + + TASK BODY TA IS + + TEMP : T; + + BEGIN + + ACCEPT EA (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := EIO + C100; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + I := I + C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) ACTUAL PARAMETER " & + "CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A1) + + I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE + -- DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= C1 THEN + CASE CONVERT (I) IS + WHEN 11 => + FAILED ("OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL " & + "PRIVATE (SCALAR) " & + "PARAMETER CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A1) + + END; -- (A) + + --------------------------------------------------- + + DECLARE -- (B) + + PACKAGE ACCESS_PKG IS + + TYPE T IS PRIVATE; + C_NULL : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + C101 : CONSTANT T; + + PRIVATE + + TYPE T IS ACCESS INTEGER; + C_NULL : CONSTANT T := NULL; + C1 : CONSTANT T := NEW INTEGER'(1); + C10 : CONSTANT T := NEW INTEGER'(10); + C100 : CONSTANT T := NEW INTEGER'(100); + C101 : CONSTANT T := NEW INTEGER'(101); + + END ACCESS_PKG; + + USE ACCESS_PKG; + + BEGIN -- (B) + + DECLARE -- (B1) + + I : T; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TB; + + TASK BODY TB IS + + TEMP : T; + + BEGIN + + ACCEPT EB (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := C101; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) ACTUAL VARIABLE " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EO := C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B1) + + I := C100; + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I /= C101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B1) + + END; -- (B) + + --------------------------------------------------- + + RESULT; +END C95072B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95073a.ada b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada new file mode 100644 index 000000000..f8b1e0daf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada @@ -0,0 +1,66 @@ +-- C95073A.ADA + +-- 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. +--* +-- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES, +-- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE +-- IDENTICAL ARGUMENTS. + +-- JWC 7/29/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95073A IS + + TYPE MATRIX IS ARRAY (1..3, 1..3) OF INTEGER; + + A : MATRIX := ((1,2,3), (4,5,6), (7,8,9)); + + TASK T IS + ENTRY MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX); + END T; + + TASK BODY T IS + BEGIN + ACCEPT MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) DO + FOR I IN 1..3 LOOP + FOR J IN 1..3 LOOP + SUM (I,J) := X (I,J) + Y (I,J); + END LOOP; + END LOOP; + END MAT_ADD; + END T; + +BEGIN + + TEST ("C95073A", "CHECK THAT ALIASING IS PERMITTED FOR " & + "PARAMETERS OF COMPOSITE TYPES"); + + T.MAT_ADD (A, A, A); + + IF A /= ((2,4,6), (8,10,12), (14,16,18)) THEN + FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT"); + END IF; + + RESULT; + +END C95073A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95074c.ada b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada new file mode 100644 index 000000000..872a5928d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada @@ -0,0 +1,103 @@ +-- C95074C.ADA + +-- 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. +--* +-- CHECK THAT 'FIRST, 'LAST, 'LENGTH, AND 'RANGE, CAN BE APPLIED TO AN +-- OUT PARAMETER OR OUT PARAMETER SUBCOMPONENT THAT DOES NOT HAVE AN +-- ACCESS TYPE. + +-- JWC 6/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95074C IS + +BEGIN + + TEST ("C95074C", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " & + "NON-ACCESS FORMAL OUT PARAMETERS"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 10) OF NATURAL; + + TYPE REC IS RECORD + A : ARR; + END RECORD; + + A1 : ARR; + R1 : REC; + + TASK T1 IS + ENTRY E (A2 : OUT ARR; R2 : OUT REC); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E (A2 : OUT ARR; R2 : OUT REC) DO + + IF A2'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR A2'FIRST"); + END IF; + + IF A2'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LAST"); + END IF; + + IF A2'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LENGTH"); + END IF; + + IF (1 NOT IN A2'RANGE) OR + (10 NOT IN A2'RANGE) OR + (0 IN A2'RANGE) OR + (11 IN A2'RANGE) THEN + FAILED ("WRONG VALUE FOR A2'RANGE"); + END IF; + + IF R2.A'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR R2.A'FIRST"); + END IF; + + IF R2.A'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LAST"); + END IF; + + IF R2.A'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LENGTH"); + END IF; + + IF (1 NOT IN R2.A'RANGE) OR + (10 NOT IN R2.A'RANGE) OR + (0 IN R2.A'RANGE) OR + (11 IN R2.A'RANGE) THEN + FAILED ("WRONG VALUE FOR R2.A'RANGE"); + END IF; + END E; + END T1; + + BEGIN + T1.E (A1,R1); + END; + + RESULT; +END C95074C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95076a.ada b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada new file mode 100644 index 000000000..ba00cee68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada @@ -0,0 +1,85 @@ +-- C95076A.ADA + +-- 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. +--* +-- CHECK THAT AN ACCEPT STATEMENT WITH AND WITHOUT A RETURN +-- STATEMENT RETURNS CORRECTLY. + +-- GLH 7/11/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95076A IS + + I : INTEGER; + + TASK T1 IS + ENTRY E1 (N : IN OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (N : IN OUT INTEGER) DO + IF (N = 5) THEN + N := N + 5; + ELSE + N := 0; + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (N : IN OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (N : IN OUT INTEGER) DO + IF (N = 10) THEN + N := N + 5; + RETURN; + END IF; + N := 0; + END E2; + END T2; + +BEGIN + + TEST ("C95076A", "CHECK THAT AN ACCEPT STATEMENT WITH AND " & + "WITHOUT A RETURN STATEMENT RETURNS CORRECTLY"); + + I := 5; + T1.E1 (I); + IF (I /= 10) THEN + FAILED ("INCORRECT RENDEVOUS WITHOUT A RETURN"); + END IF; + + I := 10; + T2.E2 (I); + IF (I /= 15) THEN + FAILED ("INCORRECT RENDEVOUS WITH A RETURN"); + END IF; + + RESULT; + +END C95076A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95078a.ada b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada new file mode 100644 index 000000000..399be9602 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada @@ -0,0 +1,195 @@ +-- C95078A.ADA + +-- 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 AN EXCEPTION RAISED DURING THE EXECUTION OF AN ACCEPT +-- STATEMENT CAN BE HANDLED WITHIN THE ACCEPT BODY. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- DHH 03/21/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C95078A IS + +BEGIN + + TEST("C95078A", "CHECK THAT AN EXCEPTION RAISED DURING THE " & + "EXECUTION OF AN ACCEPT STATEMENT CAN BE " & + "HANDLED WITHIN THE ACCEPT BODY"); + + DECLARE + O,PT,QT,R,S,TP,B,C,D :INTEGER := 0; + TASK TYPE PROG_ERR IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END PROG_ERR; + + TASK T IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END T; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + SUBTYPE X IS INTEGER RANGE 1 .. 10; + + PACKAGE P IS + OBJ : REC; + END P; + + TASK BODY PROG_ERR IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END PROG_ERR; + + TASK BODY T IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END T; + + PACKAGE BODY P IS + BEGIN + OBJ.B.START(O,PT,B); + OBJ.B.STOP; + + IF O /= IDENT_INT(1) OR PT /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - TASK TYPE OBJECT"); + END IF; + + IF B /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK TYPE " & + "OBJECT"); + END IF; + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + OBJ.START(QT,R,C); + OBJ.STOP; + + IF QT /= IDENT_INT(1) OR R /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - ACCESS TASK TYPE"); + END IF; + + IF C /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - ACCESS TASK " & + "TYPE"); + END IF; + END; + + BEGIN + T.START(S,TP,D); + T.STOP; + + IF S /= IDENT_INT(1) OR TP /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED PROPERLY " & + "- TASK"); + END IF; + + IF D /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK"); + END IF; + END; -- DECLARE + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION NOT HANDLED INSIDE ACCEPT BODY"); + RESULT; +END C95078A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95080b.ada b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada new file mode 100644 index 000000000..1c3c3b8b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada @@ -0,0 +1,71 @@ +-- C95080B.ADA + +-- 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. +--* +-- CHECK THAT PARAMETERLESS ENTRIES CAN BE CALLED WITH THE APPROPRIATE +-- NOTATION. + +-- JWC 7/15/85 +-- JRK 8/21/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95080B IS + + I : INTEGER := 1; + + TASK T IS + ENTRY E; + ENTRY EF (1..3); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E DO + I := 15; + END E; + ACCEPT EF (2) DO + I := 20; + END EF; + END T; + +BEGIN + + TEST ("C95080B", "CHECK THAT PARAMETERLESS ENTRIES CAN BE " & + "CALLED"); + + T.E; + IF I /= 15 THEN + FAILED ("PARAMETERLESS ENTRY CALL YIELDS INCORRECT " & + "RESULT"); + END IF; + + I := 0; + T.EF (2); + IF I /= 20 THEN + FAILED ("PARAMETERLESS ENTRY FAMILY CALL YIELDS " & + "INCORRECT RESULT"); + END IF; + + RESULT; + +END C95080B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95082g.ada b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada new file mode 100644 index 000000000..f02e35db0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada @@ -0,0 +1,91 @@ +-- C95082G.ADA + +-- 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. +--* +-- CHECK THAT FOR CALLS TO ENTRIES HAVING AT LEAST ONE DEFAULT +-- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND +-- FORMAL PARAMETERS. + +-- JWC 7/17/85 + +WITH REPORT;USE REPORT; +PROCEDURE C95082G IS + + Y1,Y2,Y3 : INTEGER := 0; + + TASK T IS + ENTRY E (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1: INTEGER; I2: INTEGER := 2; + I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER) DO + O1 := I1; + O2 := I2; + O3 := I3; + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + +BEGIN + + TEST ("C95082G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL " & + "PARAMETERS (HAVING DEFAULT VALUES)"); + + T.E (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 1"); + END IF; + + T.E (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 2"); + END IF; + + T.E (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2); + IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 3"); + END IF; + + T.E (41, 42, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 4"); + END IF; + + T.E (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53); + IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 5"); + END IF; + + RESULT; + +END C95082G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085a.ada b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada new file mode 100644 index 000000000..fc7e0dc9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada @@ -0,0 +1,279 @@ +-- C95085A.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR +-- ARGUMENTS. SUBTESTS ARE: +-- (A) STATIC IN ARGUMENT. +-- (B) DYNAMIC IN ARGUMENT. +-- (C) IN OUT, OUT OF RANGE ON CALL. +-- (D) OUT, OUT OF RANGE ON RETURN. +-- (E) IN OUT, OUT OF RANGE ON RETURN. + +-- GLH 7/15/85 +-- JRK 8/23/85 +-- JWC 11/15/85 ADDED VARIABLE "CALLED" TO ENSURE THAT THE ENTRY +-- CALL WAS MADE FOR THOSE CASES THAT ARE APPLICABLE. + +WITH REPORT; USE REPORT; +PROCEDURE C95085A IS + + SUBTYPE DIGIT IS INTEGER RANGE 0..9; + + D : DIGIT; + I : INTEGER; + M1 : CONSTANT INTEGER := IDENT_INT (-1); + COUNT : INTEGER := 0; + CALLED : BOOLEAN; + + SUBTYPE SI IS INTEGER RANGE M1 .. 10; + + TASK T1 IS + ENTRY E1 (PIN : IN DIGIT; WHO : STRING); -- (A), (B). + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (PIN : IN DIGIT; + WHO : STRING) DO -- (A), (B). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E1 " & WHO); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E1"); + END; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (PINOUT : IN OUT DIGIT; WHO : STRING); -- (C). + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E2 (PINOUT : IN OUT DIGIT; + WHO : STRING) DO -- (C). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E2 " & WHO); + END E2; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E2"); + END; + END LOOP; + END T2; + + TASK T3 IS + ENTRY E3 (POUT : OUT SI; WHO : STRING); -- (D). + END T3; + + TASK BODY T3 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E3 (POUT : OUT SI; + WHO : STRING) DO -- (D). + CALLED := TRUE; + IF WHO = "10" THEN + POUT := IDENT_INT (10); -- 10 IS NOT + -- A DIGIT. + ELSE + POUT := -1; + END IF; + END E3; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E3"); + END; + END LOOP; + END T3; + + TASK T4 IS + ENTRY E4 (PINOUT : IN OUT INTEGER; WHO : STRING); -- (E). + END T4; + + TASK BODY T4 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E4 (PINOUT : IN OUT INTEGER; + WHO : STRING) DO -- (E). + CALLED := TRUE; + IF WHO = "10" THEN + PINOUT := 10; -- 10 IS NOT A DIGIT. + ELSE + PINOUT := IDENT_INT (-1); + END IF; + END E4; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E4"); + END; + END LOOP; + END T4; + +BEGIN + + TEST ("C95085A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR OUT OF RANGE SCALAR ARGUMENTS"); + + BEGIN -- (A) + T1.E1 (10, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (10)"); + END; -- (A) + + BEGIN -- (B) + T1.E1 (IDENT_INT (-1), "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (" & + "IDENT_INT (-1))"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (" & + "IDENT_INT (-1))"); + END; -- (B) + + BEGIN -- (C) + I := IDENT_INT (10); + T2.E2 (I, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (10)"); + END; -- (C) + + BEGIN -- (C1) + I := IDENT_INT (-1); + T2.E2 (I, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (-1)"); + END; -- (C1) + + BEGIN -- (D) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (10)"); + END; -- (D) + + BEGIN -- (D1) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (-1)"); + END; -- (D1) + + BEGIN -- (E) + CALLED := FALSE; + D := 9; + T4.E4 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (10)"); + END; -- (E) + + BEGIN -- (E1) + CALLED := FALSE; + D := 0; + T4.E4 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (-1)"); + END; -- (E1) + + IF COUNT /= 8 THEN + FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED"); + END IF; + + RESULT; + +END C95085A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085b.ada b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada new file mode 100644 index 000000000..27ef17052 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada @@ -0,0 +1,183 @@ +-- C95085B.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES +-- WITH RESPECT TO PARAMETERS OF RECORD TYPES IN ENTRY CALLS. SUBTESTS +-- INVOLVE ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT +-- EQUAL TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS: +-- (A) IN PARAMETER, STATIC AGGREGATE. +-- (B) IN PARAMETER, DYNAMIC AGGREGATE. +-- (C) IN PARAMETER, VARIABLE. +-- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL. +-- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL. + +-- JWC 10/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085B IS + + SUBTYPE INT IS INTEGER RANGE 0..10; + + TYPE REC (N : INT := 0) IS + RECORD + A : STRING (1..N); + END RECORD; + + SUBTYPE SREC IS REC(N=>3); + +BEGIN + + TEST ("C95085B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " & + "PARAMETERS OF RECORD TYPES"); + + DECLARE + + TASK TSK1 IS + ENTRY E (R : IN SREC); + END TSK1; + + TASK BODY TSK1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E (R : IN SREC) DO + FAILED ("EXCEPTION NOT RAISED ON " & + "CALL TO TSK1"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK1"); + END; + END LOOP; + END TSK1; + + BEGIN + + BEGIN -- (A) + TSK1.E ((2,"AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)"); + END; -- (A) + + BEGIN -- (B) + TSK1.E ((IDENT_INT(2), "AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)"); + END; -- (B) + + DECLARE -- (C) + R : REC := (IDENT_INT(2), "AA"); + BEGIN -- (C) + TSK1.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)"); + END; -- (C) + + END; + + DECLARE -- (D) + + R : REC := (IDENT_INT(2), "AA"); + + TASK TSK2 IS + ENTRY E (R : IN OUT SREC); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + SELECT + ACCEPT E (R : IN OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK2"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK2"); + END TSK2; + + BEGIN -- (D) + TSK2.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)"); + END; -- (D) + + DECLARE -- (E) + + R : REC; + + TASK TSK3 IS + ENTRY E (R : OUT SREC); + END TSK3; + + TASK BODY TSK3 IS + BEGIN + SELECT + ACCEPT E (R : OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK3"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK3"); + END TSK3; + + BEGIN -- (E) + TSK3.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)"); + END; -- (E) + + RESULT; + +END C95085B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085c.ada b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada new file mode 100644 index 000000000..f2875e340 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada @@ -0,0 +1,245 @@ +-- C95085C.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE +-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS IN ENTRY CALLS, +-- NAMELY WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS +-- (BEFORE THE CALL FOR ALL MODES). +-- SUBTESTS ARE: +-- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE. +-- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE. +-- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE. +-- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE. +-- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE. +-- (F) IN OUT MODE, NULL STRING AGGREGATE. +-- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE). +-- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE. + +-- JWC 10/28/85 +-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE C95085C IS + +BEGIN + TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS"); + + -------------------------------------------------- + + DECLARE -- (A) + SUBTYPE ST IS STRING (1..3); + + TASK TSK IS + ENTRY E (A : ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (A)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END TSK; + + BEGIN -- (A) + + TSK.E ("AB"); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE S IS INTEGER RANGE 1..3; + TYPE T IS ARRAY (S,S) OF INTEGER; + + TASK TSK IS + ENTRY E (A : T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : T) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (B)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END TSK; + + BEGIN -- (B) + + TSK.E ((1..3 => (1..IDENT_INT(2) => 0))); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER; + SUBTYPE ST IS T (1..3,1..3); + V : T (1..IDENT_INT(2), 1..3) := + (1..IDENT_INT(2) => (1..3 => 0)); + + TASK TSK IS + ENTRY E (A :ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A :ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (C)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END TSK; + + BEGIN -- (C) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF + INTEGER; + SUBTYPE ST IS T (1..3, 1..3, 1..3); + V : T (1..3, 1..2, 1..3) := + (1..3 => (1..2 => (1..3 => 0))); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (D)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END TSK; + + BEGIN -- (D) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + + DECLARE -- (G) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER; + SUBTYPE ST IS T (2..1, 2..1); + V : T (2..1, 2..1) := (2..1 => (2..1 => ' ')); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + COMMENT ("OK CASE CALLED CORRECTLY"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (G)"); + END TSK; + + BEGIN -- (G) + + TSK.E (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)"); + END; -- (G) + + -------------------------------------------------- + + + RESULT; +END C95085C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085d.ada b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada new file mode 100644 index 000000000..059298180 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada @@ -0,0 +1,97 @@ +-- C95085D.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085D IS + +BEGIN + TEST ("C95085D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1) IS PRIVATE; + TYPE AR IS ARRAY (E1 .. E3) OF INTEGER; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + A : AR; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (E3); + V : A (E2) := NEW T (E2); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; +END C95085D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085e.ada b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada new file mode 100644 index 000000000..86c446c8b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada @@ -0,0 +1,87 @@ +-- C95085E.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085E IS + +BEGIN + TEST ("C95085E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (BOOLEAN, 'A'..'C'); + V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B')); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085f.ada b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada new file mode 100644 index 000000000..7a716595d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada @@ -0,0 +1,84 @@ +-- C95085F.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY +-- WHEN THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085F IS + +BEGIN + TEST ("C95085F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE A IS ACCESS STRING; + SUBTYPE A1 IS A (1..3); + V : A (2..4) := NEW STRING (2..4); + + TASK TSK IS + ENTRY E (X : IN OUT A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085g.ada b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada new file mode 100644 index 000000000..2004164d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada @@ -0,0 +1,98 @@ +-- C95085G.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085G IS + +BEGIN + TEST ("C95085G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE T (C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INT := 0) IS + RECORD + J : INTEGER; + CASE B IS + WHEN FALSE => + K : INTEGER; + WHEN TRUE => + S : STRING (1 .. I); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('Z', TRUE, 5); + V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5); + + TASK TSK IS + ENTRY E (X : IN OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT SA) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085h.ada b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada new file mode 100644 index 000000000..a46720474 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada @@ -0,0 +1,111 @@ +-- C95085H.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE +-- DISCRIMINANTS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085H IS + +BEGIN + TEST ("C95085H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..10; + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C'; + TYPE T (I : INT := 0; C : CHAR := 'A') IS + LIMITED PRIVATE; + PRIVATE + TYPE T (I : INT := 0; C : CHAR := 'A') IS + RECORD + J : INTEGER; + CASE C IS + WHEN 'A' => + K : INTEGER; + WHEN 'B' => + S : STRING (1..I); + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + + V : A (2,'B') := NEW T (2,'B'); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + X := NEW T (2,'A'); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085i.ada b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada new file mode 100644 index 000000000..b2b08543c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada @@ -0,0 +1,100 @@ +-- C95085I.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL +-- BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085I IS + +BEGIN + TEST ("C95085I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE E IS (E1, E2, E3); + + TYPE T IS ARRAY (CHARACTER RANGE <>, + E RANGE <>, + BOOLEAN RANGE <> + ) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A ('A'..'Z', E1..E2, BOOLEAN) := + NEW T ('A'..'Z', E1..E2, BOOLEAN); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + IF EQUAL (3,3) THEN + X := NEW T ('A'..'Z', E2..E3, BOOLEAN); + END IF; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085I; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085j.ada b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada new file mode 100644 index 000000000..d1ea3ce2e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada @@ -0,0 +1,90 @@ +-- C95085J.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE +-- DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085J IS + +BEGIN + TEST ("C95085J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE A IS ACCESS STRING; + + V : A (1..3) := NEW STRING (1..3); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW STRING (2..3); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085J; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085k.ada b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada new file mode 100644 index 000000000..37952f0ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada @@ -0,0 +1,97 @@ +-- C95085K.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC +-- RECORD DISCRIMINANT. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085K IS + +BEGIN + TEST ("C95085K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + A : ARR (FALSE..B); + END RECORD; + + TYPE A IS ACCESS T; + + V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE)); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW T (TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085K; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085l.ada b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada new file mode 100644 index 000000000..cb62ff249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada @@ -0,0 +1,109 @@ +-- C95085L.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC +-- PRIVATE DISCRIMINANTS. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085L IS + +BEGIN + TEST ("C95085L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER; + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR (E1 .. D); + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2, TRUE); + V : A (E2, FALSE) := NEW T (E2, FALSE); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (E2, TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; +END C95085L; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085m.ada b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada new file mode 100644 index 000000000..45e73fffa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada @@ -0,0 +1,96 @@ +-- C95085M.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN THE +-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO +-- DIMENSIONAL BOUNDS. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085M IS + +BEGIN + TEST ("C95085M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE T IS ARRAY (INTEGER RANGE <>, + CHARACTER RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z'); + + Y : CONSTANT CHARACTER := IDENT_CHAR('Y'); + SUBTYPE SA IS A (1..10, 'A'..Y); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (1..10, 'A'..IDENT_CHAR('Y')); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085M; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085n.ada b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada new file mode 100644 index 000000000..7f7e3a63b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada @@ -0,0 +1,117 @@ +-- C95085N.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE +-- CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE WHERE THE VALUE +-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL +-- PARAMETER. + +-- JWC 10/29/85 +-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE +-- CALL. + +WITH REPORT; USE REPORT; +PROCEDURE C95085N IS + +BEGIN + TEST ("C95085N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS NEW INTEGER; + DC : CONSTANT T := -1; + END P; + + TASK TSK IS + ENTRY E (X : OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T RANGE 0..1 := 0; + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; +END C95085N; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085o.ada b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada new file mode 100644 index 000000000..f5cd288a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada @@ -0,0 +1,118 @@ +-- C95085O.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE +-- CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE THE VALUE +-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL +-- PARAMETER. + +-- JWC 10/30/85 +-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE +-- CALL. + +WITH REPORT; USE REPORT; +PROCEDURE C95085O IS + +BEGIN + + TEST ("C95085O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS ACCESS STRING; + DC : CONSTANT T := NEW STRING'("AAA"); + END P; + + TASK TSK IS + ENTRY E (X : IN OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T (1..5) := NEW STRING'("CCCCC"); + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; +END C95085O; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086a.ada b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada new file mode 100644 index 000000000..e26e8b872 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada @@ -0,0 +1,94 @@ +-- C95086A.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN +-- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE +-- RANGE CONSTRAINTS OF THE FORMAL PARAMETER. + +-- GLH 7/16/85 +-- JRK 8/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95086A IS + + SUBTYPE SUBINT1 IS INTEGER RANGE -10..10; + SUBTYPE SUBINT2 IS INTEGER RANGE -20..20; + + I10 : SUBINT1 := 10; + I20 : SUBINT2 := 20; + + TASK T1 IS + ENTRY E1 (I : OUT SUBINT1); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (I : OUT SUBINT1) DO + I := SUBINT1'FIRST; + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN ACCEPT E1"); + END; + END LOOP; + END T1; + +BEGIN + + TEST ("C95086A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AT THE TIME OF CALL WHEN THE VALUE OF AN " & + "ACTUAL OUT SCALAR PARAMETER DOES NOT " & + "SATISFY THE RANGE CONSTRAINTS OF THE FORMAL " & + "PARAMETER"); + + BEGIN + T1.E1 (SUBINT1(I20)); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 1"); + END; + + BEGIN + I20 := IDENT_INT (20); + T1.E1 (I20); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 2"); + END; + + RESULT; + +END C95086A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086b.ada b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada new file mode 100644 index 000000000..bc222ebc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada @@ -0,0 +1,202 @@ +-- C95086B.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS +-- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT +-- FROM THE FORMAL PARAMETER. +-- +-- SUBTESTS ARE: +-- (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS. +-- (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. +-- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. +-- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + +-- RJW 1/27/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086B IS + +BEGIN + TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " & + "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " & + "DIFFERENT FROM THE FORMAL PARAMETER" ); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (A)" ); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (A)" ); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (B)" ); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (B)" ); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (C)" ); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (C)" ); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (D)" ); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (D)" ); + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C95086B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086c.ada b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada new file mode 100644 index 000000000..9c2050b71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada @@ -0,0 +1,250 @@ +-- C95086C.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL +-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS +-- DIFFERENT CONSTRAINTS. +-- +-- SUBTESTS ARE: +-- (A) IN OUT MODE, STATIC PRIVATE DISCRIMINANT. +-- (B) OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. +-- (C) SAME AS (A), WITH TYPE CONVERSION. +-- (D) SAME AS (B), WITH TYPE CONVERSION. + +-- RJW 1/29/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086C IS + +BEGIN + TEST ("C95086C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL " & + "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " & + "DIFFERENT CONSTRAINTS" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C95086C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086d.ada b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada new file mode 100644 index 000000000..616c025fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada @@ -0,0 +1,142 @@ +-- C95086D.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- BEFORE OR AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED ACTUAL +-- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE +-- ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL +-- PARAMETER. +-- +-- SUBTESTS ARE: +-- (A) STATIC LIMITED PRIVATE DISCRIMINANT. +-- (B) DYNAMIC ONE DIMENSIONAL BOUNDS. + +-- RJW 2/3/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086D IS + +BEGIN + TEST ("C95086D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AND AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED " & + "ACTUAL OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR " & + "TO THE ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE " & + "FORMAL PARAMETER"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..5; + TYPE T (I : INT := 0) IS LIMITED PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE T (I : INT := 0) IS + RECORD + J : INTEGER; + A : ARR (1..I); + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (3); + V : A := NEW T (2); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (3); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE A IS ACCESS STRING; + SUBTYPE SA IS A (1..2); + V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7)); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2)); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + RESULT; +END C95086D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086e.ada b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada new file mode 100644 index 000000000..4e4f42b95 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada @@ -0,0 +1,282 @@ +-- C95086E.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY +-- CALL FOR IN OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE +-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: +-- (A) OK CASE. +-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER +-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER +-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL +-- ARRAYS. +-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + +-- RJW 2/3/86 +-- TMB 11/15/95 ELIMINATED INCOMPATIBILITY WITH ADA95 +-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + +WITH REPORT; USE REPORT; +PROCEDURE C95086E IS + +BEGIN + TEST ("C95086E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR IN OUT ARRAY " & + "PARAMETERS, WITH THE ACTUAL HAVING THE FORM OF A TYPE " & + "CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL := (1..3 => (1..3 => TRUE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL := (3..5 => (3..5 => FALSE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3) := (2..1 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL := (3..5 => (5..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL := (5..2 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; +END C95086E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086f.ada b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada new file mode 100644 index 000000000..00b84441b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada @@ -0,0 +1,282 @@ +-- C95086F.ADA + +-- 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. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY +-- CALL FOR OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE +-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: +-- (A) OK CASE. +-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER +-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER +-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL +-- ARRAYS. +-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + +-- RJW 2/3/86 +-- TMB 11/15/95 FIXED INCOMPATIBILITIES WITH ADA95 +-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + +WITH REPORT; USE REPORT; +PROCEDURE C95086F IS + +BEGIN + TEST ("C95086F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR OUT ARRAY PARAMETERS, " & + "WITH THE ACTUAL HAVING THE FORM OF A TYPE CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X := (1..3 => (1..3 => TRUE)); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ' )); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; +END C95086F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087a.ada b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada new file mode 100644 index 000000000..535cea40d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada @@ -0,0 +1,412 @@ +-- C95087A.ADA + +-- 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. +--* +-- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY +-- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS. +-- SUBTESTS ARE: +-- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS. +-- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS. +-- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS. +-- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS. + +-- GLH 7/19/85 +-- JRK 8/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95087A IS + +BEGIN + TEST ("C95087A", "CHECK USE OF ACTUAL CONSTRAINTS BY " & + "UNCONSTRAINED FORMAL PARAMETERS"); + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + REC1 : RECTYPE := (10,10,"0123456789"); + REC2 : RECTYPE := (17,7,"C95087A.........."); + REC3 : RECTYPE := (1,1,"A"); + REC4 : RECTYPE; -- 80. + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("RECORD TYPE IN PARAMETER " & + "DID NOT USE CONSTRAINT " & + "OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("RECORD TYPE IN OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + REC2 := PKG.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + END PKG; + + BEGIN -- (A) + + PKG.T1.E1 (PKG.REC1, PKG.REC2, PKG.REC3); + PKG.T2.E2 (PKG.REC4); + + END; -- (A) + + --------------------------------------------- + +B : DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE; + + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE (10); + REC2 : PKG.RECTYPE (17); + REC3 : PKG.RECTYPE (1); + REC4 : PKG.RECTYPE (10); + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE IN " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("PRIVATE TYPE IN OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + REC2 := B.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (B) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END B; -- (B) + + --------------------------------------------- + +C : DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + LIMITED PRIVATE; + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE; -- 10. + REC2 : PKG.RECTYPE; -- 17. + REC3 : PKG.RECTYPE; -- 1. + REC4 : PKG.RECTYPE; -- 80. + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "OUT PARAMETER DID NOT " & + "USE CONSTRAINT OF ACTUAL"); + END IF; + REC2 := C.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF UNINITIALIZED " & + "ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (C) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END C; -- (C) + + --------------------------------------------- + +D : DECLARE -- (D) + + TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF + CHARACTER; + + A1, A2, A3 : ATYPE (-1..1, 4..5) := (('A','B'), + ('C','D'), + ('E','F')); + + A4 : ATYPE (-1..1, 4..5); + + CA1 : CONSTANT ATYPE (8..9, -7..INTEGER'FIRST) := + (8..9 => (-7..INTEGER'FIRST => 'A')); + + S1 : STRING (1..INTEGER'FIRST) := ""; + S2 : STRING (-5..-7) := ""; + S3 : STRING (1..0) := ""; + + TASK T1 IS + ENTRY E1 (A1 : IN ATYPE := CA1; + A2 : OUT ATYPE; + A3 : IN OUT ATYPE); + END T1; + + TASK T2 IS + ENTRY E2 (A4 : OUT ATYPE); + END T2; + + TASK T3 IS + ENTRY E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING); + END T3; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE; + A3 : IN OUT ATYPE) DO + IF A1'FIRST(1) /= IDENT_INT (-1) OR + A1'LAST(1) /= IDENT_INT (1) OR + A1'FIRST(2) /= IDENT_INT (4) OR + A1'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A2'FIRST(1) /= IDENT_INT (-1) OR + A2'LAST(1) /= IDENT_INT (1) OR + A2'FIRST(2) /= IDENT_INT (4) OR + A2'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A3'FIRST(1) /= IDENT_INT (-1) OR + A3'LAST(1) /= IDENT_INT (1) OR + A3'FIRST(2) /= IDENT_INT (4) OR + A3'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL"); + END IF; + A2 := D.A2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (A4 : OUT ATYPE) DO + IF A4'FIRST(1) /= IDENT_INT (-1) OR + A4'LAST(1) /= IDENT_INT (1) OR + A4'FIRST(2) /= IDENT_INT (4) OR + A4'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF " & + "UNINITIALIZED ACTUAL"); + END IF; + A4 := A2; + END E2; + END T2; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING) DO + IF S1'FIRST /= IDENT_INT (1) OR + S1'LAST /= IDENT_INT (INTEGER'FIRST) THEN + FAILED ("STRING TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL " & + "NULL STRING"); + END IF; + IF S2'FIRST /= IDENT_INT (-5) OR + S2'LAST /= IDENT_INT (-7) THEN + FAILED ("STRING TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL NULL STRING"); + END IF; + IF S3'FIRST /= IDENT_INT (1) OR + S3'LAST /= IDENT_INT (0) THEN + FAILED ("STRING TYPE OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL " & + "STRING"); + END IF; + S3 := ""; + END E3; + END T3; + + BEGIN -- (D) + + T1.E1 (A1, A2, A3); + T2.E2 (A4); + T3.E3 (S1, S2, S3); + + END D; -- (D) + + RESULT; +END C95087A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087b.ada b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada new file mode 100644 index 000000000..1d6c87826 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada @@ -0,0 +1,267 @@ +-- C95087B.ADA + +-- 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. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT +-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE +-- THE CONSTRAINT OF THE ACTUAL PARAMETER. +-- SUBTESTS ARE: +-- (A) RECORD TYPE. +-- (B) PRIVATE TYPE. +-- (C) LIMITED PRIVATE TYPE. + +-- RJW 1/10/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087B IS + +BEGIN + + TEST ( "C95087B", "CHECK ASSIGNMENT TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPE (WITH NO DEFAULT)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + END PKG; + + REC9 : PKG.RECTYPE(IDENT_INT(9)) := + (IDENT_INT(9), 9, "123456789"); + REC6 : PKG.RECTYPE(IDENT_INT(6)) := + (IDENT_INT(6), 5, "AEIOUY"); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(IDENT_INT(4)) := + (IDENT_INT(4), 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (A.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.1"); + END; -- (A.1) + + BEGIN -- (A.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.2"); + END; -- (A.2) + + REC9 := (IDENT_INT(9), 9, "987654321"); + + END E; + END T; + END PKG; + + BEGIN -- (A) + + PKG.T.E (REC9, REC6); + + IF REC9.STRFIELD /= IDENT_STR("987654321") THEN + FAILED ("ASSIGNMENT TO REC9 FAILED - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC9 : PKG.RECTYPE(9); + REC6 : PKG.RECTYPE(6); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (B.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.1"); + END; -- (B.1) + + BEGIN -- (B.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.2"); + END; -- (B.2) + + END E; + END T; + + BEGIN + REC9 := (9, 9, "123456789"); + REC6 := (6, 5, "AEIOUY"); + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC9, REC6); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC6 : PKG.RECTYPE(IDENT_INT(6)); + REC9 : PKG.RECTYPE(IDENT_INT(9)); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (C.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.1"); + END; -- (C.1) + + BEGIN -- (C.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.2"); + END; -- (C.2) + + END E; + END T; + + BEGIN + REC6 := (6, 5, "AEIOUY"); + REC9 := (9, 9, "123456789"); + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC9, REC6); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087c.ada b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada new file mode 100644 index 000000000..2061af4bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada @@ -0,0 +1,299 @@ +-- C95087C.ADA + +-- 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. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT +-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS +-- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING +-- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER. + +-- SUBTESTS ARE: +-- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. +-- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. +-- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + +-- RJW 1/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087C IS + +BEGIN + + TEST ( "C95087C", "CHECK ASSIGNMENTS TO ENTRY FORMAL " & + "PARAMETERS OF UNCONSTRAINED TYPES " & + "(WITH DEFAULTS)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + REC91,REC92,REC93 : RECTYPE(9); + REC_OOPS : RECTYPE(4); + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON RECORD TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (A) + + PKG.T.E (PKG.REC91, PKG.REC92, PKG.REC93); + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON PRIVATE TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91,REC92,REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= 9) THEN + FAILED ( "CONSTRAINT ON LIMITED " & + "PRIVATE TYPE IN PARAMETER " & + "NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - C.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT RAISED " & + "- C.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087d.ada b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada new file mode 100644 index 000000000..6e44913b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada @@ -0,0 +1,268 @@ +-- C95087D.ADA + +-- 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. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT +-- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER +-- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT +-- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER. + +-- SUBTESTS ARE: +-- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. +-- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. +-- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + +-- RJW 1/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087D IS + +BEGIN + + TEST ( "C95087D", "CHECK ASSIGNMENTS TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPES WITH UNCONSTRAINED " & + "ACTUAL PARAMETERS"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE := + (IDENT_INT(5), 5, IDENT_STR( "12345")); + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF NOT REC1'CONSTRAINED THEN + FAILED ( "REC1 IS NOT CONSTRAINED - A.1"); + END IF; + IF REC1.CONSTRAINT /= IDENT_INT(9) THEN + FAILED ( "REC1 CONSTRAINT IS NOT 9 " & + "- A.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + USE PKG; + + BEGIN -- (A) + + PKG.T.E (REC91, REC92, REC93); + IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN + FAILED ( "RESULTANT VALUE OF REC92 OR REC93 INCORRECT"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF REC3'CONSTRAINED THEN + FAILED ( "REC3 IS CONSTRAINED - B.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95088a.ada b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada new file mode 100644 index 000000000..053abebdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada @@ -0,0 +1,85 @@ +-- C95088A.ADA + +-- 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. +--* +-- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE +-- TIME OF CALL. + +-- GLH 7/10/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95088A IS + + TYPE VECTOR IS ARRAY (1..10) OF INTEGER; + TYPE PTRINT IS ACCESS INTEGER; + + I : INTEGER := 1; + A : VECTOR := (1,2,3,4,5,6,7,8,9,10); + P1 : PTRINT := NEW INTEGER'(2); + P2 : PTRINT := P1; + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER; J : OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER; J : OUT INTEGER) DO + I := 10; + J := -1; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (P : OUT PTRINT; I : OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (P : OUT PTRINT; I : OUT INTEGER) DO + P := NEW INTEGER'(3); + I := 5; + END E2; + END T2; + +BEGIN + + TEST ("C95088A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED " & + "AND IDENTIFIED AT THE TIME OF CALL"); + + COMMENT ("FIRST CALL"); + T1.E1 (I, A(I)); + IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN + FAILED ("A(I) EVALUATED UPON RETURN"); + END IF; + + COMMENT ("SECOND CALL"); + T2.E2 (P1, P1.ALL); + IF (P2.ALL /= 5) THEN + FAILED ("P1.ALL EVALUATED UPON RETURN"); + END IF; + + RESULT; + +END C95088A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95089a.ada b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada new file mode 100644 index 000000000..b66897cc7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada @@ -0,0 +1,175 @@ +-- C95089A.ADA + +-- 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. +--* +-- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED +-- AS ACTUAL PARAMETERS. + +-- GLH 7/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95089A IS + + SUBTYPE INT IS INTEGER RANGE 1..3; + + TYPE REC (N : INT) IS + RECORD + S : STRING (1..N); + END RECORD; + + TYPE PTRSTR IS ACCESS STRING; + + R1, R2, R3 : REC (3); + S1, S2, S3 : STRING (1..3); + PTRTBL : ARRAY (1..3) OF PTRSTR; + + TASK T1 IS + ENTRY E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING) DO + S3 := S2; + S2 := S1; + END E1; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER); + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER) DO + C3 := C2; + C2 := C1; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + FUNCTION F1 (X : INT) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (X); + END F1; + + FUNCTION "+" (S1, S2 : STRING) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1); + END "+"; + +BEGIN + + TEST ("C95089A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE " & + "NAMES ARE PERMITTED AS ACTUAL PARAMETERS"); + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1, S2, S3); + IF S2 /= "AAA" OR S3 /= "BBB" THEN + FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + S3 := IDENT_STR ("CCC"); + T2.E2 (S1(1), S2(IDENT_INT(1)), S3(1)); + IF S2 /= "ABB" OR S3 /= "BCC" THEN + FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " & + "WORKING"); + END IF; + + R1.S := "AAA"; + R2.S := "BBB"; + T1.E1 (R1.S, R2.S, R3.S); + IF R2.S /= "AAA" OR R3.S /= "BBB" THEN + FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1(1..IDENT_INT(2)), S2(1..2), + S3(IDENT_INT(1)..IDENT_INT(2))); + IF S2 /= "AAB" OR S3 /= "BBC" THEN + FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + S1 := IDENT_STR("AAA"); + S2 := IDENT_STR("BBB"); + S3 := IDENT_STR("CCC"); + T1.E1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR " & + "FUNCTION VALUE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T2.E2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1))); + IF PTRTBL(2).ALL /= "ABB" OR PTRTBL(3).ALL /= "BCC" THEN + FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), + F1(3)(2..IDENT_INT(3))); + IF PTRTBL(2).ALL /= "BAA" OR PTRTBL(3).ALL /= "CBB" THEN + FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + RESULT; + +END C95089A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95090a.ada b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada new file mode 100644 index 000000000..24dc17981 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada @@ -0,0 +1,128 @@ +-- C95090A.ADA + +-- 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. +--* +-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY +-- TO ENTRIES. SPECIFICALLY, +-- (A) CHECK ALL PARAMETER MODES. + +-- GLH 7/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95090A IS + +BEGIN + TEST ("C95090A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO ENTRIES"); + + -------------------------------------------- + + DECLARE -- (A) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE (1..IDENT_INT(5)); + + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + + REC : RECORD_TYPE := (I => 23, + A => (1..3 => IDENT_INT(7), 4..5 => 9)); + BOOL : BOOLEAN; + + TASK T1 IS + ENTRY E1 (ARR : ARRAY_TYPE); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (ARR : ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER"); + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (ARR : IN OUT ARRAY_TYPE); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (ARR : IN OUT ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN OUT PARAMETER NOT PASSED " & + "CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 5); + END E2; + END T2; + + TASK T3 IS + ENTRY E3 (ARR : OUT ARRAY_TYPE); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (ARR : OUT ARRAY_TYPE) DO + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 3); + END E3; + END T3; + + BEGIN -- (A) + + T1.E1 (REC.A); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + T2.E2 (REC.A); + IF REC.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + + T3.E3 (REC.A); + IF REC.A /= (3, 3, 3, 3, 3) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + + END; -- (A) + + -------------------------------------------- + + RESULT; +END C95090A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95092a.ada b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada new file mode 100644 index 000000000..47e96b548 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada @@ -0,0 +1,193 @@ +-- C95092A.ADA + +-- 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 FOR ENTRIES OF TASKS, DEFAULT VALUES OF ALL TYPES CAN +-- BE GIVEN FOR A FORMAL PARAMETER. + +-- HISTORY: +-- DHH 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C95092A IS + + SUBTYPE INT IS INTEGER RANGE 1 ..10; + TYPE FLT IS DIGITS 5; + TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 10.0; + TYPE ENUM IS (RED, BLUE, YELLOW); + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'F'; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE REC IS + RECORD + A : INT; + B : ENUM; + C : CHAR; + END RECORD; + + FUNCTION IDENT_FLT(E : FLT) RETURN FLT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION IDENT_FIX(E : FIX) RETURN FIX IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIX; + + FUNCTION IDENT_ENUM(E : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN YELLOW; + END IF; + END IDENT_ENUM; + + FUNCTION IDENT_CHAR(E : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 'F'; + END IF; + END IDENT_CHAR; + + FUNCTION IDENT_ARR(E : ARR) RETURN ARR IS + Z : ARR := (3,2,1); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_ARR; + + FUNCTION IDENT_REC(E : REC) RETURN REC IS + Z : REC := (10, YELLOW, 'F'); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_REC; + + TASK TEST_DEFAULTS IS + ENTRY BOOL(G : BOOLEAN := TRUE); + ENTRY INTEGR(X : IN INT := 5); + ENTRY FLOAT(Y : IN FLT := 1.25); + ENTRY FIXED(Z : IN FIX := 1.0); + ENTRY ENUMERAT(A : IN ENUM := RED); + ENTRY CHARACTR(B : IN CHAR := 'A'); + ENTRY ARRY(C : IN ARR := (1, 2, 3)); + ENTRY RECD(D : IN REC := (5, RED, 'A')); + END TEST_DEFAULTS; + + TASK BODY TEST_DEFAULTS IS + BEGIN + + ACCEPT BOOL(G : BOOLEAN := TRUE) DO + IF G /= IDENT_BOOL(TRUE) THEN + FAILED("BOOLEAN DEFAULT FAILED"); + END IF; + END BOOL; + + ACCEPT INTEGR(X : IN INT := 5) DO + IF X /= IDENT_INT(5) THEN + FAILED("INTEGER DEFAULT FAILED"); + END IF; + END INTEGR; + + ACCEPT FLOAT(Y : IN FLT := 1.25) DO + IF Y /= IDENT_FLT(1.25) THEN + FAILED("FLOAT DEFAULT FAILED"); + END IF; + END FLOAT; + + ACCEPT FIXED(Z : IN FIX := 1.0) DO + IF Z /= IDENT_FIX(1.0) THEN + FAILED("FIXED DEFAULT FAILED"); + END IF; + END FIXED; + + ACCEPT ENUMERAT(A : IN ENUM := RED) DO + IF A /= IDENT_ENUM(RED) THEN + FAILED("ENUMERATION DEFAULT FAILED"); + END IF; + END ENUMERAT; + + ACCEPT CHARACTR(B : IN CHAR := 'A') DO + IF B /= IDENT_CHAR('A') THEN + FAILED("CHARACTER DEFAULT FAILED"); + END IF; + END CHARACTR; + + ACCEPT ARRY(C : IN ARR := (1, 2, 3)) DO + FOR I IN 1 ..3 LOOP + IF C(I) /= IDENT_INT(I) THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "DEFAULT FAILED"); + END IF; + END LOOP; + END ARRY; + + ACCEPT RECD(D : IN REC := (5, RED, 'A')) DO + IF D.A /= IDENT_INT(5) THEN + FAILED("RECORD INTEGER DEFAULT FAILED"); + END IF; + IF D.B /= IDENT_ENUM(RED) THEN + FAILED("RECORD ENUMERATION DEFAULT FAILED"); + END IF; + IF D.C /= IDENT_CHAR('A') THEN + FAILED("RECORD CHARACTER DEFAULT FAILED"); + END IF; + END RECD; + + END TEST_DEFAULTS; + +BEGIN + + TEST("C95092A", "CHECK THAT FOR ENTRIES OF TASKS, DEFAULT " & + "VALUES OF ALL TYPES CAN BE GIVEN FOR A FORMAL " & + "PARAMETER"); + + TEST_DEFAULTS.BOOL; + TEST_DEFAULTS.INTEGR; + TEST_DEFAULTS.FLOAT; + TEST_DEFAULTS.FIXED; + TEST_DEFAULTS.ENUMERAT; + TEST_DEFAULTS.CHARACTR; + TEST_DEFAULTS.ARRY; + TEST_DEFAULTS.RECD; + + RESULT; +END C95092A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95093a.ada b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada new file mode 100644 index 000000000..9c443faae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada @@ -0,0 +1,87 @@ +-- C95093A.ADA + +-- 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. +--* +-- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED +-- EACH TIME THEY ARE NEEDED. + +-- GLH 7/2/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95093A IS +BEGIN + + TEST ("C95093A", "CHECK THAT THE DEFAULT EXPRESSION IS " & + "EVALUATED EACH TIME IT IS NEEDED"); + + DECLARE + + X : INTEGER := 1; + + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + TASK T1 IS + ENTRY E1 (X, Y : INTEGER := F); + END T1; + + TASK BODY T1 IS + BEGIN + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR Y /= 2 THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "1, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR + NOT ((X = 3 AND Y = 4) OR + (X = 4 AND Y = 3)) THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "2, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + END T1; + + BEGIN + + COMMENT ("FIRST CALL"); + T1.E1 (3); + + COMMENT ("SECOND CALL"); + T1.E1; + + END; + + RESULT; + +END C95093A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095a.ada b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada new file mode 100644 index 000000000..0cd02958d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada @@ -0,0 +1,108 @@ +-- C95095A.ADA + +-- 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. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (A) A FUNCTION AND AN ENTRY. + +-- JWC 7/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095A IS + +BEGIN + TEST ("C95095A", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- BOTH PARAMETERIZED AND PARAMETERLESS SUBPROGRAMS AND ENTRIES + -- ARE TESTED. + + DECLARE + I, J, K : INTEGER := 0; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2; + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E2 DO + S (1) := 'C'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + FUNCTION E1 (I1, I2 : INTEGER) RETURN INTEGER IS + BEGIN + S (2) := 'B'; + RETURN I1; -- RETURNED VALUE IS IRRELEVENT. + END E1; + + + FUNCTION E2 RETURN INTEGER IS + BEGIN + S (2) := 'D'; + RETURN I; -- RETURNED VALUE IS IRRELEVENT. + END E2; + + BEGIN + T.E1 (I, J); + K := E1 (I, J); + + IF S /= "AB" THEN + FAILED ("PARAMETERIZED OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2; + K := E2; + + IF S /= "CD" THEN + FAILED ("PARAMETERLESS OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095b.ada b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada new file mode 100644 index 000000000..f3c9c0df5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada @@ -0,0 +1,112 @@ +-- C95095B.ADA + +-- 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. +--* +-- CHECK THAT OVERLOADED ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (B) ONE ENTRY HAS ONE LESS PARAMETER THAN THE OTHER. + +-- JWC 7/24/85 +-- JRK 10/2/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095B IS + +BEGIN + TEST ("C95095B", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- ONE ENTRY HAS ONE MORE PARAMETER + -- THAN THE OTHER. THIS IS TESTED IN THE + -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT + -- VALUE, AND THE CASE IN WHICH IT DOES NOT. + + DECLARE + I, J : INTEGER := 0; + B : BOOLEAN := TRUE; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN); + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0); + ENTRY E2 (B1 : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER; + B1 : IN OUT BOOLEAN) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E1 (I1, I2 : INTEGER) DO + S (2) := 'B'; + END E1; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN; + I1 : INTEGER := 0) DO + S (1) := 'C'; + END E2; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN) DO + S (2) := 'D'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E1 (I, J, B); + T.E1 (I, J); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "NUMBER OF PARAMETERS (NO DEFAULTS) " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2 (B, I); + -- NOTE THAT A CALL TO T.E2 WITH ONLY + -- ONE PARAMETER IS AMBIGUOUS. + + IF S /= "C2" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "EXISTENCE OF ONE PARAMETER (WITH " & + "DEFAULT) CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095c.ada b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada new file mode 100644 index 000000000..694c7d31e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada @@ -0,0 +1,97 @@ +-- C95095C.ADA + +-- 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. +--* +-- CHECK THAT OVERLOADED ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (C) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT +-- OF THE CORRESPONDING ONE. + +-- JWC 7/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095C IS + +BEGIN + TEST ("C95095C", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- THE BASE TYPE OF ONE PARAMETER IS + -- DIFFERENT FROM THAT OF THE CORRESPONDING + -- ONE. + + DECLARE + + TYPE NEWINT IS NEW INTEGER; + + I, J, K : INTEGER := 0; + N : NEWINT; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER); + ENTRY E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER) DO + S (1) := 'A'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + ACCEPT E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E (I, N, K); + T.E (I, J, K); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY BY " & + "THE BASE TYPE OF A PARAMETER " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095d.ada b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada new file mode 100644 index 000000000..f2ad7d95a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada @@ -0,0 +1,99 @@ +-- C95095D.ADA + +-- 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. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (D) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE +-- PART, AN ENTRY IS DECLARED IN A TASK, AND THE +-- PARAMETERS ARE ORDERED DIFFERENTLY. + +-- JWC 7/24/85 +-- JRK 10/2/85 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95095D IS + + +BEGIN + TEST ("C95095D", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IS DECLARED IN A TASK, AND THE + -- PARAMETERS ARE ORDERED DIFFERENTLY. + + DECLARE + S : STRING (1..2) := "12"; + + I : INTEGER := 0; + + PROCEDURE E (I1 : INTEGER; I2 : IN OUT INTEGER; + B1 : BOOLEAN) IS + BEGIN + S (1) := 'A'; + END E; + + TASK T IS + ENTRY E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + E (5, I, TRUE); -- PROCEDURE CALL. + ACCEPT E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + END E; + E (TRUE, 5, I); -- ENTRY CALL; SELF-BLOCKING. + -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS + -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS. + FAILED ("TASK DID NOT BLOCK ITSELF"); + END T; + + BEGIN + + T.E (TRUE, 5, I); + + DELAY 10.0 * Impdef.One_Second; + ABORT T; + + IF S /= "AB" THEN + FAILED ("PROCEDURES/ENTRIES " & + "DIFFERING ONLY IN PARAMETER " & + "TYPE ORDER CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095e.ada b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada new file mode 100644 index 000000000..01951691f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada @@ -0,0 +1,88 @@ +-- C95095E.ADA + +-- 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. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (E) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART, +-- AN ENTRY IN A TASK, AND ONE HAS ONE MORE PARAMETER +-- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE. + +-- JWC 7/30/85 +-- JRK 10/2/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095E IS + +BEGIN + TEST ("C95095E", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IN A TASK, AND ONE + -- HAS ONE MORE PARAMETER (WITH A DEFAULT + -- VALUE) THAN THE OTHER. + + DECLARE + S : STRING (1..3) := "123"; + + PROCEDURE E (I1, I2, I3 : INTEGER := 1) IS + C : CONSTANT STRING := "CXA"; + BEGIN + S (I3) := C (I3); + END E; + + TASK T IS + ENTRY E (I1, I2 : INTEGER := 1); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I1, I2 : INTEGER := 1) DO + S (2) := 'B'; + END E; + END T; + + BEGIN + + E (1, 2, 3); + T.E (1, 2); + E (1, 2); + + IF S /= "CBA" THEN + FAILED ("PROCEDURES/ENTRIES DIFFERING " & + "ONLY IN EXISTENCE OF ONE " & + "DEFAULT-VALUED PARAMETER CAUSED " & + "CONFUSION"); + END IF; + + END; + + -------------------------------------------------- + + RESULT; +END C95095E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c951001.a b/gcc/testsuite/ada/acats/tests/c9/c951001.a new file mode 100644 index 000000000..c1cf96593 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c951001.a @@ -0,0 +1,192 @@ +-- C951001.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 two procedures in a protected object will not be +-- executed concurrently. +-- +-- TEST DESCRIPTION: +-- A very simple example of two tasks calling two procedures in the same +-- protected object is used. Test control code has been added to the +-- procedures such that, whichever gets called first executes a lengthy +-- calculation giving sufficient time (on a multiprocessor or a +-- time-slicing machine) for the other task to get control and call the +-- other procedure. The control code verifies that entry to the second +-- routine is postponed until the first is complete. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C951001 is + + protected Ramp_31 is + + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + function TC_Failed return Boolean; + + private + + Ramp_Count : integer range 0..20 := 4; -- Start test with some + -- vehicles on the ramp + + TC_Add_Started : Boolean := false; + TC_Subtract_Started : Boolean := false; + TC_Add_Finished : Boolean := false; + TC_Subtract_Finished : Boolean := false; + TC_Concurrent_Running: Boolean := false; + + end Ramp_31; + + + protected body Ramp_31 is + + function TC_Failed return Boolean is + begin + -- this indicator will have been set true if any instance + -- of concurrent running has been proved + return TC_Concurrent_Running; + end TC_Failed; + + + procedure Add_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Add_Started := true; + if TC_Subtract_Started then + if not TC_Subtract_Finished then + TC_Concurrent_Running := true; + end if; + else + -- Subtract has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Subtract_Started then + -- Subtract was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Add_Finished := true; + --================================================== + Ramp_Count := Ramp_Count + 1; + end Add_Meter_Queue; + + procedure Subtract_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Subtract_Started := true; + if TC_Add_Started then + if not TC_Add_Finished then + -- We already have concurrent running + TC_Concurrent_Running := true; + end if; + else + -- Add has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Add_Started then + -- Add was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Subtract_Finished := true; + --================================================== + Ramp_Count := Ramp_Count - 1; + end Subtract_Meter_Queue; + + end Ramp_31; + +begin + + Report.Test ("C951001", "Check that two procedures in a protected" & + " object will not be executed concurrently"); + + declare -- encapsulate the test + + task Vehicle_1; + task Vehicle_2; + + + -- Vehicle_1 and Vehicle_2 are simulations of Instances of the task + -- of type Vehicle in different stages of execution + + task body Vehicle_1 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + null; -- ::::: stub: Ramp_31.Subtract_Meter_Queue + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_1 task"); + end Vehicle_1; + + + task body Vehicle_2 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + null; -- ::::: stub Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + Ramp_31.Subtract_Meter_Queue; + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_2 task"); + end Vehicle_2; + + + + begin + null; + end; -- encapsulation + + if Ramp_31.TC_Failed then + Report.Failed ("Concurrent Running detected"); + end if; + + Report.Result; + +end C951001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c951002.a b/gcc/testsuite/ada/acats/tests/c9/c951002.a new file mode 100644 index 000000000..65b696c4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c951002.a @@ -0,0 +1,334 @@ +-- C951002.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 an entry and a procedure within the same protected object +-- will not be executed simultaneously. +-- +-- TEST DESCRIPTION: +-- Two tasks are used. The first calls an entry who's barrier is set +-- and is thus queued. The second calls a procedure in the same +-- protected object. This procedure clears the entry barrier of the +-- first then executes a lengthy compute bound procedure. This is +-- intended to allow a multiprocessor, or a time-slicing implementation +-- of a uniprocessor, to (erroneously) permit the first task to continue +-- while the second is still computing. Flags in each process in the +-- PO are checked to ensure that they do not run out of sequence or in +-- parallel. +-- In the second part of the test another entry and procedure are used +-- but in this case the procedure is started first. A different task +-- calls the entry AFTER the procedure has started. If the entry +-- completes before the procedure the test fails. +-- +-- This test will not be effective on a uniprocessor without time-slicing +-- It is designed to increase the chances of failure on a multiprocessor, +-- or a uniprocessor with time-slicing, if the entry and procedure in a +-- Protected Object are not forced to acquire a single execution +-- resource. It is not guaranteed to fail. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C951002 is + + -- These global error flags are used for failure conditions within + -- the protected object. We cannot call Report.Failed (thus Text_io) + -- which would result in a bounded error. + -- + TC_Error_01 : Boolean := false; + TC_Error_02 : Boolean := false; + TC_Error_03 : Boolean := false; + TC_Error_04 : Boolean := false; + TC_Error_05 : Boolean := false; + TC_Error_06 : Boolean := false; + +begin + + Report.Test ("C951002", "Check that a procedure and an entry body " & + "in a protected object will not run concurrently"); + + declare -- encapsulate the test + + task Credit_Message is + entry TC_Start; + end Credit_Message; + + task Credit_Task is + entry TC_Start; + end Credit_Task; + + task Debit_Message is + entry TC_Start; + end Debit_Message; + + task Debit_Task is + entry TC_Start; + end Debit_Task; + + --==================================== + + protected Hold is + + entry Wait_for_CR_Underload; + procedure Clear_CR_Overload; + entry Wait_for_DB_Underload; + procedure Set_DB_Overload; + procedure Clear_DB_Overload; + -- + function TC_Message_is_Queued return Boolean; + + private + Credit_Overloaded : Boolean := true; -- Test starts in overload + Debit_Overloaded : Boolean := false; + -- + TC_CR_Proc_Finished : Boolean := false; + TC_CR_Entry_Finished : Boolean := false; + TC_DB_Proc_Finished : Boolean := false; + TC_DB_Entry_Finished : Boolean := false; + end Hold; + --==================== + protected body Hold is + + entry Wait_for_CR_Underload when not Credit_Overloaded is + begin + -- The barrier must only be re-evaluated at the end of the + -- of the execution of the procedure, also while the procedure + -- is executing this entry body must not be executed + if not TC_CR_Proc_Finished then + TC_Error_01 := true; -- Set error indicator + end if; + TC_CR_Entry_Finished := true; + end Wait_for_CR_Underload ; + + -- This is the procedure which should NOT be able to run in + -- parallel with the entry body + -- + procedure Clear_CR_Overload is + begin + + -- The entry body must not be executed until this procedure + -- is completed. + if TC_CR_Entry_Finished then + TC_Error_02 := true; -- Set error indicator + end if; + Credit_Overloaded := false; -- clear the entry barrier + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task. + -- + ImpDef.Exceed_Time_Slice; + + -- Again, the entry body must not be executed until the current + -- procedure is completed. + -- + if TC_CR_Entry_Finished then + TC_Error_03 := true; -- Set error indicator + end if; + TC_CR_Proc_Finished := true; + + end Clear_CR_Overload; + + --============ + -- The following subprogram and entry body are used in the second + -- part of the test + + entry Wait_for_DB_Underload when not Debit_Overloaded is + begin + -- By the time the task that calls this entry is allowed access to + -- the queue the barrier, which starts off as open, will be closed + -- by the Set_DB_Overload procedure. It is only reopened + -- at the end of the test + if not TC_DB_Proc_Finished then + TC_Error_04 := true; -- Set error indicator + end if; + TC_DB_Entry_Finished := true; + end Wait_for_DB_Underload ; + + + procedure Set_DB_Overload is + begin + -- The task timing is such that this procedure should be started + -- before the entry is called. Thus the entry should be blocked + -- until the end of this procedure which then sets the barrier + -- + if TC_DB_Entry_Finished then + TC_Error_05 := true; -- Set error indicator + end if; + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task + -- + ImpDef.Exceed_Time_Slice; + + Debit_Overloaded := true; -- set the entry barrier + + if TC_DB_Entry_Finished then + TC_Error_06 := true; -- Set error indicator + end if; + TC_DB_Proc_Finished := true; + + end Set_DB_Overload; + + procedure Clear_DB_Overload is + begin + Debit_Overloaded := false; -- open the entry barrier + end Clear_DB_Overload; + + function TC_Message_is_Queued return Boolean is + begin + + -- returns true when one message arrives on the queue + return (Wait_for_CR_Underload'Count = 1); + + end TC_Message_is_Queued ; + + end Hold; + + --==================================== + + task body Credit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Credit + -- application. This message task queues itself on a queue + -- waiting till the overload in no longer in effect + Hold.Wait_for_CR_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Message Task"); + end Credit_Message; + + task body Credit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Clear_CR_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Task"); + end Credit_Task; + + --============== + + -- The following two tasks are used in the second part of the test + + task body Debit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Debit + -- application. This message task queues itself on a queue + -- waiting till the overload is no longer in effect + -- + Hold.Wait_for_DB_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Message Task"); + end Debit_Message; + + task body Debit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Set_DB_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Task"); + end Debit_Task; + + begin -- declare + + Credit_Message.TC_Start; + + -- Wait until the message is queued on the entry before starting + -- the Credit_Task + while not Hold.TC_Message_is_Queued loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + -- + Credit_Task.TC_Start; + + -- Ensure the first part of the test is complete before continuing + while not (Credit_Message'terminated and Credit_Task'terminated) loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + + --====================================================== + -- Second part of the test + + + Debit_Task.TC_Start; + + -- Delay long enough to allow a task switch to the Debit_Task and + -- for it to reach the accept statement and call Hold.Set_DB_Overload + -- before starting Debit_Message + -- + delay ImpDef.Long_Switch_To_New_Task; + + Debit_Message.TC_Start; + + while not Debit_Task'terminated loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + + Hold.Clear_DB_Overload; -- Allow completion + + end; -- declare (encapsulation) + + if TC_Error_01 then + Report.Failed ("Wait_for_CR_Underload executed out of sequence"); + end if; + if TC_Error_02 then + Report.Failed ("Credit: Entry executed before procedure"); + end if; + if TC_Error_03 then + Report.Failed ("Credit: Entry executed in parallel"); + end if; + if TC_Error_04 then + Report.Failed ("Wait_for_DB_Underload executed out of sequence"); + end if; + if TC_Error_05 then + Report.Failed ("Debit: Entry executed before procedure"); + end if; + if TC_Error_06 then + Report.Failed ("Debit: Entry executed in parallel"); + end if; + + Report.Result; + +end C951002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a new file mode 100644 index 000000000..bc9c85f30 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953001.a @@ -0,0 +1,188 @@ +-- C953001.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 if the evaluation of an entry_barrier condition +-- propagates an exception, the exception Program_Error +-- is propagated to all current callers of all entries of the +-- protected object. +-- +-- TEST DESCRIPTION: +-- This test declares a protected object (PO) with two entries and +-- a 5 element entry family. +-- All the entries are always closed. However, one of the entries +-- (Oh_No) will get a constraint_error in its barrier_evaluation +-- whenever the global variable Blow_Up is true. +-- An array of tasks is created where the tasks wait on the various +-- entries of the protected object. Once all the tasks are waiting +-- the main procedure calls the entry Oh_No and causes an exception +-- to be propagated to all the tasks. The tasks record the fact +-- that they got the correct exception in global variables that +-- can be checked after the tasks complete. +-- +-- +-- CHANGE HISTORY: +-- 19 OCT 95 SAIC ACVC 2.1 +-- +--! + + +with Report; +with ImpDef; +procedure C953001 is + Verbose : constant Boolean := False; + Max_Tasks : constant := 12; + + -- note status and error conditions + Blocked_Entry_Taken : Boolean := False; + In_Oh_No : Boolean := False; + Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False); + +begin + Report.Test ("C953001", + "Check that an exception in an entry_barrier condition" & + " causes Program_Error to be propagated to all current" & + " callers of all entries of the protected object"); + + declare -- test encapsulation + -- miscellaneous values + Cows : Integer := Report.Ident_Int (1); + Came_Home : Integer := Report.Ident_Int (2); + + -- make the Barrier_Condition fail only when we want it to + Blow_Up : Boolean := False; + + function Barrier_Condition return Boolean is + begin + if Blow_Up then + return 5 mod Report.Ident_Int(0) = 1; + else + return False; + end if; + end Barrier_Condition; + + subtype Family_Index is Integer range 1..5; + + protected PO is + entry Block1; + entry Oh_No; + entry Family (Family_Index); + end PO; + + protected body PO is + entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is + begin + Blocked_Entry_Taken := True; + end Block1; + + -- barrier will get a Constraint_Error (divide by 0) + entry Oh_No when Barrier_Condition is + begin + In_Oh_No := True; + end Oh_No; + + entry Family (for Member in Family_Index) when Cows = Came_Home is + begin + Blocked_Entry_Taken := True; + end Family; + end PO; + + + task type Waiter is + entry Take_Id (Id : Integer); + end Waiter; + + Bunch_of_Waiters : array (1..Max_Tasks) of Waiter; + + task body Waiter is + Me : Integer; + Action : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + + Action := Me mod (Family_Index'Last + 1); + begin + if Action = 0 then + PO.Block1; + else + PO.Family (Action); + end if; + Report.Failed ("no exception for task" & Integer'Image (Me)); + exception + when Program_Error => + Task_Passed (Me) := True; + if Verbose then + Report.Comment ("pass for task" & Integer'Image (Me)); + end if; + when others => + Report.Failed ("wrong exception raised in task" & + Integer'Image (Me)); + end; + end Waiter; + + + begin -- test encapsulation + for I in 1..Max_Tasks loop + Bunch_Of_Waiters(I).Take_Id (I); + end loop; + + -- give all the Waiters time to get queued + delay 2*ImpDef.Clear_Ready_Queue; + + -- cause the protected object to fail + begin + Blow_Up := True; + PO.Oh_No; + Report.Failed ("no exception in call to PO.Oh_No"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error instead of Program_Error"); + when Program_Error => + if Verbose then + Report.Comment ("main exception passed"); + end if; + when others => + Report.Failed ("wrong exception in main"); + end; + end; -- test encapsulation + + -- all the tasks have now completed. + -- check the flags for pass/fail info + if Blocked_Entry_Taken then + Report.Failed ("blocked entry taken"); + end if; + if In_Oh_No then + Report.Failed ("entry taken with exception in barrier"); + end if; + for I in 1..Max_Tasks loop + if not Task_Passed (I) then + Report.Failed ("task" & Integer'Image (I) & " did not pass"); + end if; + end loop; + + Report.Result; +end C953001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953002.a b/gcc/testsuite/ada/acats/tests/c9/c953002.a new file mode 100644 index 000000000..d821bb24e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953002.a @@ -0,0 +1,242 @@ +-- C953002.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 the servicing of entry queues of a protected object +-- continues until there are no open entries with queued calls +-- and that this takes place as part of a single protected +-- operation. +-- +-- TEST DESCRIPTION: +-- This test enqueues a bunch of tasks on the entries of the +-- protected object Main_PO. At the same time another bunch of +-- of tasks are queued on the single entry of protected object +-- Holding_Pen. +-- Once all the tasks have had time to block, the main procedure +-- opens all the entries for Main_PO by calling the +-- Start_Protected_Operation protected procedure. This should +-- process all the pending callers as part of a single protected +-- operation. +-- During this protected operation, the entries of Main_PO release +-- the tasks blocked on Holding_Pen by calling the protected +-- procedure Release. +-- Once released from Holding_Pen, the task immediately calls +-- an entry in Main_PO. +-- These new calls should not gain access to Main_PO until +-- the initial protected operation on that object completes. +-- The order in which the entry calls on Main_PO are taken is +-- recorded in a global array and checked after all the tasks +-- have terminated. +-- +-- +-- CHANGE HISTORY: +-- 25 OCT 95 SAIC ACVC 2.1 +-- 15 JAN 95 SAIC Fixed deadlock problem. +-- +--! + +with Report; +procedure C953002 is + Verbose : constant Boolean := False; + + Half_Tasks : constant := 15; -- how many tasks of each group + Max_Tasks : constant := Half_Tasks * 2; -- total number of tasks + + Note_Order : array (1..Max_Tasks) of Integer := (1..Max_Tasks => 0); + Note_Cnt : Integer := 0; +begin + Report.Test ("C953002", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + First_Wave : array (1 .. Half_Tasks) of Assault_PO; + Second_Wave : array (1 .. Half_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + entry E1 (Who : Integer); + entry E2 (Who : Integer); + entry E3 (Who : Integer); + entry All_Present; + procedure Start_Protected_Operation; + private + Open : Boolean := False; + end Main_PO; + + protected Holding_Pen is + -- Note that Release is called by tasks executing in + -- the protected object Main_PO. + entry Wait (Who : Integer); + entry All_Present; + procedure Release; + private + Open : Boolean := False; + end Holding_Pen; + + + protected body Main_PO is + procedure Start_Protected_Operation is + begin + Open := True; + -- at this point all the First_Wave tasks are + -- waiting at the entries and all of them should + -- be processed as part of the protected operation. + end Start_Protected_Operation; + + entry All_Present when E0'Count + E1'Count + E2'Count + E3'Count = + Max_Tasks / 2 is + begin + null; -- all tasks are waiting + end All_Present; + + entry E0 (Who : Integer) when Open is + begin + Holding_Pen.Release; + -- note the order in which entry calls are handled. + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E0; + + entry E1 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E1; + + entry E2 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E2; + + entry E3 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E3; + end Main_PO; + + + protected body Holding_Pen is + procedure Release is + begin + Open := True; + end Release; + + entry All_Present when Wait'Count = Max_Tasks / 2 is + begin + null; -- all tasks waiting + end All_Present; + + entry Wait (Who : Integer) when Open is + begin + null; -- unblock the task + end Wait; + end Holding_Pen; + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + if Me >= 200 then + Holding_Pen.Wait (Me); + end if; + case Me mod 4 is + when 0 => Main_PO.E0 (Me); + when 1 => Main_PO.E1 (Me); + when 2 => Main_PO.E2 (Me); + when 3 => Main_PO.E3 (Me); + when others => null; -- cant happen + end case; + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in First_Wave'Range loop + First_Wave (I).Take_ID (100 + I); + end loop; + for I in Second_Wave'Range loop + Second_Wave (I).Take_ID (200 + I); + end loop; + + -- let all the tasks get blocked + Main_PO.All_Present; + Holding_Pen.All_Present; + + -- let the games begin + if Verbose then + Report.Comment ("starting protected operation"); + end if; + Main_PO.Start_Protected_Operation; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + -- check the order in which entries were handled. + -- all the 100 level items should be handled as part of the + -- first protected operation and thus should be completed + -- before any 200 level item. + + if Verbose then + for I in 1..Max_Tasks loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + for I in 2 .. Max_Tasks loop + if Note_Order (I) < 200 and + Note_Order (I-1) >= 200 then + Report.Failed ("protected operation failure" & + Integer'Image (Note_Order (I-1)) & + Integer'Image (Note_Order (I))); + end if; + end loop; + + Report.Result; +end C953002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953003.a b/gcc/testsuite/ada/acats/tests/c9/c953003.a new file mode 100644 index 000000000..4ac91169e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953003.a @@ -0,0 +1,189 @@ +-- C953003.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 the servicing of entry queues of a protected object +-- continues until there are no open entries with queued (or +-- requeued) calls and that internal requeues are handled +-- as part of a single protected operation. +-- +-- TEST DESCRIPTION: +-- A number of tasks are created and blocked on a protected object +-- so that they can all be released at one time. When released, +-- these tasks make an entry call to an entry in the Main_PO +-- protected object. As part of the servicing of this entry +-- call the call is passed through the remaining entries of the +-- protected object by using internal requeues. The protected +-- object checks that no other entry call is accepted until +-- after all the internal requeuing has completed. +-- +-- +-- CHANGE HISTORY: +-- 12 JAN 96 SAIC Initial version for 2.1 +-- +--! + +with Report; +procedure C953003 is + Verbose : constant Boolean := False; + + Order_Error : Boolean := False; + + Max_Tasks : constant := 10; -- total number of tasks + Max_Entries : constant := 4; -- number of entries in Main_PO + Note_Cnt : Integer := 0; + Note_Order : array (1..Max_Tasks*Max_Entries) of Integer; +begin + Report.Test ("C953003", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation," & + " including those resulting from an internal requeue"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + Marines : array (1 .. Max_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + private + entry E3 (Who : Integer); + entry E2 (Who : Integer); + entry E1 (Who : Integer); + Expected_Next : Integer := 0; + end Main_PO; + + + protected body Main_PO is + + entry E0 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 0; + Expected_Next := 1; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E1; + end E0; + + entry E1 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 1; + Expected_Next := 2; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E2; + end E1; + + entry E3 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 3; + Expected_Next := 0; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + -- all done - return now + end E3; + + entry E2 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 2; + Expected_Next := 3; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E3; + end E2; + end Main_PO; + + protected Holding_Pen is + entry Wait_For_All_Present; + entry Wait; + private + Open : Boolean := False; + end Holding_Pen; + + protected body Holding_Pen is + entry Wait_For_All_Present when Wait'Count = Max_Tasks is + begin + Open := True; + end Wait_For_All_Present; + + entry Wait when Open is + begin + null; -- just go + end Wait; + end Holding_Pen; + + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + Holding_Pen.Wait; + Main_PO.E0 (Me); + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in Marines'Range loop + Marines (I).Take_ID (100 + I); + end loop; + + -- let all the tasks get blocked so we can release them all + -- at one time + Holding_Pen.Wait_For_All_Present; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks * Max_Entries then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + if Order_Error then + Report.Failed ("internal requeue not handled as part of operation"); + end if; + + if Verbose or Order_Error then + for I in 1..Max_Tasks * Max_Entries loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + + Report.Result; +end C953003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954001.a b/gcc/testsuite/ada/acats/tests/c9/c954001.a new file mode 100644 index 000000000..3112cce2b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954001.a @@ -0,0 +1,273 @@ +-- C954001.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 requeue statement within an entry_body with parameters +-- may requeue the entry call to a protected entry with a subtype- +-- conformant parameter profile. Check that, if the call is queued on the +-- new entry's queue, the original caller remains blocked after the +-- requeue, but the entry_body containing the requeue is completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected object which simulates a disk device. Declare an +-- entry that requeues the caller to a second entry if the disk head is +-- not in the proper location, but first sets the second entry's barrier +-- to false. Declare a procedure which sets the second entry's barrier +-- to true. +-- +-- Declare a task which calls the first entry such that the requeue is +-- called. This task should be queued on the second entry and remain +-- blocked, and the first entry should be complete. Call the procedure +-- which releases the second entry's queue. The second entry should +-- complete, after which the task should complete. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C954001_0 is -- Disk management abstraction. + + + -- Simulate a read-only disk device with a head that may be moved to + -- different tracks. If a read request is issued for the current + -- track, the request can be satisfied immediately. Otherwise, the head + -- must be moved to the correct track, during which time the calling task + -- is blocked. When the head reaches the correct track, the disk generates + -- an interrupt, after which the request can be satisfied, and the + -- calling task can proceed. + + Buffer_Size : constant := 100; + + type Disk_Buffer is new String (1 .. Buffer_Size); + type Disk_Track is new Natural; + + type Disk_Address is record + Track : Disk_Track; + -- Additional components. + end record; + + Initial_Track : constant Disk_Track := 0; + New_Track : constant Disk_Track := 5; + + --==============================================-- + + protected Disk_Device is + + entry Read (Where : Disk_Address; -- Read data from disk + Data : out Disk_Buffer); -- track. + + procedure Disk_Interrupt; -- Handle interrupt + -- from disk. + + function TC_Track return Disk_Track; -- Return current track. + + function TC_Pending_Queued return Boolean; -- True when there is + -- an entry in queue + + private + + entry Pending_Read (Where : Disk_Address; -- Wait for head to + Data : out Disk_Buffer); -- move then read data. + + Current_Track : Disk_Track := Initial_Track; -- Current disk track. + Operation_Pending : Boolean := False; -- Vis. entry barrier. + Disk_Interrupted : Boolean := False; -- Priv. entry barrier. + + end Disk_Device; + + +end C954001_0; + + + --==================================================================-- + + +package body C954001_0 is -- Disk management abstraction. + + + protected body Disk_Device is + + entry Read (Where : Disk_Address; Data : out Disk_Buffer) + when not Operation_Pending is + begin + if (Where.Track = Current_Track) then -- If the head is over the + -- Read data from disk... -- requested track, read + null; -- the data. + + else -- Otherwise, defer read + Operation_Pending := True; -- while head is moved to + -- correct track (signaled + -- -- -- by a disk interrupt). + -- Requeue is tested here -- + -- -- + + requeue Pending_Read; + + end if; + end Read; + + + procedure Disk_Interrupt is -- Called when the disk + begin -- interrupts, indicating + Disk_Interrupted := True; -- that the head is over + end Disk_Interrupt; -- the correct track. + + + function TC_Track return Disk_Track is -- Artifice required for + begin -- testing purposes. + return (Current_Track); + end TC_Track; + + + entry Pending_Read (Where : Disk_Address; Data : out Disk_Buffer) + when Disk_Interrupted is + begin + Current_Track := Where.Track; -- Head is now over the + -- Read data from disk... -- correct track; read + Operation_Pending := False; -- the data. + Disk_Interrupted := False; + end Pending_Read; + + function TC_Pending_Queued return Boolean is + begin + -- Return true when there is something on the Pending_Read queue + return (Pending_Read'Count /=0); + end TC_Pending_Queued; + + end Disk_Device; + + +end C954001_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C954001_0; -- Disk management abstraction. +use C954001_0; + +procedure C954001 is + + + task type Read_Task is -- an unusual (but legal) declaration + end Read_Task; + -- + -- + task body Read_Task is + Location : constant Disk_Address := (Track => New_Track); + Data : Disk_Buffer := (others => ' '); + begin + Disk_Device.Read (Location, Data); -- Invoke requeue statement. + exception + when others => + Report.Failed ("Exception raised in task"); + end Read_Task; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954001", "Requeue from an entry within a P.O. " & + "to a private entry within the same P.O."); + + + declare + + IO_Request : Read_Task; -- Request a read from other + -- than the current track. + -- IO_Request will be requeued + -- from Read to Pending_Read. + begin + + -- To pass this test, the following must be true: + -- + -- (A) The Read entry call made by the task IO_Request must be + -- completed by the requeue. + -- (B) IO_Request must remain blocked following the requeue. + -- (C) IO_Request must be queued on the Pending_Read entry queue. + -- (D) IO_Request must continue execution after the Pending_Read + -- entry completes. + -- + -- First, verify (A): that the Read entry call is complete. + -- + -- Call a protected operation (Disk_Device.TC_Track). Since no two + -- protected actions may proceed concurrently unless both are protected + -- function calls, a call to a protected operation at this point can + -- proceed only if the Read entry call is already complete. + -- + -- Note that if Read is NOT complete, the test will likely hang here. + -- + -- Next, verify (B): that IO_Request remains blocked following the + -- requeue. Also verify that Pending_Read (the entry to which + -- IO_Request should have been queued) has not yet executed. + + -- Wait until the task had made the call and the requeue has been + -- effected. + while not Disk_Device.TC_Pending_Queued loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Disk_Device.TC_Track /= Initial_Track then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif IO_Request'Terminated then + Report.Failed ("Caller did not remain blocked after " & + "the requeue or was never requeued"); + else + + -- Verify (C): that IO_Request is queued on the + -- Pending_Read entry queue. + -- + -- Set the barrier for Pending_Read to true. Check that the + -- current track is updated and that IO_Request terminates. + + Disk_Device.Disk_Interrupt; -- Simulate a disk interrupt, + -- signaling that the head is + -- over the correct track. + + -- The Pending_Read entry body will complete before the next + -- protected action is called (Disk_Device.TC_Track). + + if Disk_Device.TC_Track /= New_Track then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Read_Task continues after Pending_Read + -- completes. + -- + -- Note that the test will hang here if Read_Task does not continue + -- executing following the completion of the requeued entry call. + + end if; + + end; -- We will not exit the declare block until the task completes + + Report.Result; + +end C954001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954010.a b/gcc/testsuite/ada/acats/tests/c9/c954010.a new file mode 100644 index 000000000..ac39c89a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954010.a @@ -0,0 +1,286 @@ +-- C954010.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 requeue within an accept statement does not block. +-- This test uses: Requeue to an entry in a different task +-- Parameterless call +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- In the Distributor task, requeue two successive calls on the entries +-- of two separate target tasks. Verify that the target tasks are +-- run in parallel proving that the first requeue does not block +-- while the first target rendezvous takes place. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- This test is directed towards the BLOCKING of the REQUEUE only +-- If the original caller does not block, the outcome of the test will +-- not be affected. If the original caller does not continue after +-- the return, the test will not pass. +-- If the requeue gets placed on the wrong entry a failing test could +-- pass (eg. if the first message is delivered to the second +-- computation task and the second message to the first) - a check for +-- this condition is made in other tests +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C954010 is + + -- Mechanism to count the number of Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + -- + TC_Expected_To_Complete : constant integer := 2; + + + task type Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input; + end Distributor; + + task Credit_Computation is + entry Input; + end Credit_Computation; + + task Debit_Computation is + entry Input; + entry TC_Artificial_Rendezvous_1; -- test purposes only + entry TC_Artificial_Rendezvous_2; -- test purposes only + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each and sends this to a Distributor + -- for appropriate disposal around the network of tasks + -- Such a task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop + declare + -- create a new message task + N : acc_Message_Task := new Message_Task; + begin + -- preparation code + null; -- stub + + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + task body Message_Task is + begin + -- Queue up on Distributor's Input queue + Distributor.Input; + + -- After the required computations have been performed + -- return the message appropriately (probably to an output + -- line driver + null; -- stub + + -- Increment to show completion of this task + TC_Tasks_Completed.Increment; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + -- Dispose each input message to the appropriate computation tasks + -- Normally this would be according to some parameters in the entry + -- but this simple test is using parameterless entries. + -- + task body Distributor is + Last_was_for_Credit_Computation : Boolean := false; -- switch + begin + loop + select + accept Input do + -- Determine to which task the message should be + -- distributed + -- For this test arbitrarily send the first to + -- Credit_Computation and the second to Debit_Computation + if Last_was_for_Credit_Computation then + requeue Debit_Computation.Input with abort; + else + Last_was_for_Credit_Computation := true; + requeue Credit_Computation.Input with abort; + end if; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + begin + loop + select + accept Input do + -- Perform the computations required for this message + -- + null; -- stub + + -- For the test: + -- Artificially rendezvous with Debit_Computation. + -- If the first requeue in Distributor has blocked + -- waiting for the current rendezvous to complete then the + -- second message will not be sent to Debit_Computation + -- which will still be waiting on its Input accept. + -- This task will HANG + -- + Debit_Computation.TC_Artificial_Rendezvous_1; + -- + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + TC_AR1_is_complete : Boolean := false; + begin + loop + select + accept Input do + -- Perform the computations required for this message + null; -- stub + end Input; + Message_Count := Message_Count + 1; + or + -- Guard until the rendezvous with the message for this task + -- has completed + when Message_Count > 0 => + accept TC_Artificial_Rendezvous_1; -- see comments in + -- Credit_Computation above + TC_AR1_is_complete := true; + or + -- Completion rendezvous with the main procedure + when TC_AR1_is_complete => + accept TC_Artificial_Rendezvous_2; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954010 + Report.Test ("C954010", "Requeue in an accept body does not block"); + + Line_Driver.Start; + + -- Ensure that both messages were delivered to the computation tasks + -- This shows that both requeues were effective. + -- + Debit_Computation.TC_Artificial_Rendezvous_2; + + -- Ensure that the message tasks completed + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954011.a b/gcc/testsuite/ada/acats/tests/c9/c954011.a new file mode 100644 index 000000000..159b32dba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954011.a @@ -0,0 +1,384 @@ +-- C954011.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 requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeued rendezvous; +-- that the original caller continues after the rendezvous. +-- Specifically, this test checks requeue to an entry in a different +-- task, requeue where the entry has parameters, and requeue with +-- abort. +-- +-- TEST DESCRIPTION: +-- In the Distributor task, requeue two successive calls on the entries +-- of two separate target tasks. Each task in each of the paths adds +-- identifying information in the transaction being passed. This +-- information is checked by the Message tasks on completion ensuring that +-- the requeues have been placed on the correct queues. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Fixed problems with shared global variables +-- for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954011 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + protected type Message_Mgr is + procedure Mark_Complete; + function Is_Complete return Boolean; + private + Complete : Boolean := False; + end Message_Mgr; + + protected body Message_Mgr is + procedure Mark_Complete is + begin + Complete := True; + end Mark_Complete; + + Function Is_Complete return Boolean is + begin + return Complete; + end Is_Complete; + end Message_Mgr; + + TC_Debit_Message : Message_Mgr; + TC_Credit_Message : Message_Mgr; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Mark_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Mark_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Mark the message as having passed through the distributor + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954011 + + Report.Test ("C954011", "Requeue from task body to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Is_Complete and + TC_Debit_Message.Is_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954012.a b/gcc/testsuite/ada/acats/tests/c9/c954012.a new file mode 100644 index 000000000..44575b1b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954012.a @@ -0,0 +1,496 @@ +-- C954012.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 a requeue within an accept body to another entry in the same task +-- Specifically, check a call with parameters and a requeue with abort. +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After +-- processing this the Credit task sets the "overloaded" indicator. Once +-- this indicator is set the Distributor queues low priority transactions +-- on a Wait_for_Underload queue in the same task using a requeue. The +-- Distributor still delivers high priority transactions. After two high +-- priority transactions have been processed by the Credit task it clears +-- the overload condition. The low priority transactions should now be +-- delivered. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problem for +-- ACVC 2.0.1 +-- 14 Mar 03 RLB Fixed a race condition and an incorrect termination +-- condition in the test. +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C954012 is + + function "=" (X,Y: Ada.Calendar.Time) return Boolean + renames Ada.Calendar."="; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- This is used as an "initializing" time for the messages as they are + -- created. As they pass through the Distributor they get a time_stamp + -- of the current time. An arbitrary base time is chosen. + -- TC: this fact is used, incidentally, to check that the messages have, + -- indeed, passed through the Distributor as expected. + -- + Base_Time : Ada.Calendar.Time := Ada.Calendar.Time_of(1959,3,9); + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + -- Handshaking mechanism between the Line Driver and the Credit task + TC_First_Message_Has_Arrived : Shared_Boolean (False); + Credit_Overloaded : Shared_Boolean (False); + + TC_Credit_Messages_Expected : constant integer := 5; + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + Message_Count : integer := 0; -- for test + Time_Stamp : Ada.Calendar.Time := Base_Time; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input (Transaction : acc_Transaction_Record); + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + entry TC_Credit_OK; + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_First_Message_Has_Arrived.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + -- TC: Wait for Credit_Overloaded to be cleared, then insure that the + -- Distributor has evalated all tasks. Otherwise, some tasks may never + -- be evaluated. + while Credit_Overloaded.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Distributor.TC_Credit_OK; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.Message_Count /= 1 or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Time_Stamp the messages with the current time + -- TC: Used, incidentally, by the test to check that the + -- message did pass through the Distributor Task + Transaction.Time_Stamp := Ada.Calendar.Clock; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded.Value and + Transaction.Priority = Low then + requeue Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + when not Credit_Overloaded.Value => + accept Wait_for_Underload (Transaction : acc_Transaction_Record) do + requeue Credit_Computation.Input with abort; + end Wait_for_Underload; + or + accept TC_Credit_OK; + -- We need this to insure that we evaluate the guards at least + -- once when Credit_Overloaded is False. Otherwise, tasks + -- could stay queued on Wait_for_Underload forever (starvation). + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Credit_Overloaded.Value and + Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Distributor's Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Credit_Overloaded.Set_True; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_First_Message_Has_Arrived.Set_True; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Credit_Overloaded.Set_False; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954012 + Report.Test ("C954012", "Requeue within an accept body" & + " to another entry in the same task"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + or (not TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954013.a b/gcc/testsuite/ada/acats/tests/c9/c954013.a new file mode 100644 index 000000000..a9de8c56b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954013.a @@ -0,0 +1,521 @@ +-- C954013.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 requeue is cancelled and that the requeuing task is +-- unaffected when the calling task is aborted. +-- Specifically, check requeue to an entry in a different task, +-- requeue where the entry has parameters, and requeue with abort. +-- +-- TEST DESCRIPTION: +-- Abort a task that has a call requeued to the entry queue of another +-- task. We do this by sending two messages to the Distributor which +-- requeues them to the Credit task. In the accept body of the Credit +-- task we wait for the second message to arrive then check that an +-- abort of the second message task does result in the requeue being +-- removed. The Line Driver task which generates the messages and the +-- Credit task communicate artificially in this test to arrange for the +-- proper timing of the messages and the abort. One extra message is +-- sent to the Debit task to ensure that the Distributor is still viable +-- and has been unaffected by the abort. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problems for +-- ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954013 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + TC_Credit_Message_Complete : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- This protected object is here for Test Control purposes only + protected TC_Prt is + procedure Set_First_Has_Arrived; + procedure Set_Second_Has_Arrived; + procedure Set_Abort_Has_Completed; + function First_Has_Arrived return Boolean; + function Second_Has_Arrived return Boolean; + function Abort_Has_Completed return Boolean; + private + First_Flag, Second_Flag, Abort_Flag : Boolean := false; + end TC_Prt; + + protected body TC_Prt is + + Procedure Set_First_Has_Arrived is + begin + First_Flag := true; + end Set_First_Has_Arrived; + + Procedure Set_Second_Has_Arrived is + begin + Second_Flag := true; + end Set_Second_Has_Arrived; + + Procedure Set_Abort_Has_Completed is + begin + Abort_Flag := true; + end Set_Abort_Has_Completed; + + Function First_Has_Arrived return boolean is + begin + return First_Flag; + end First_Has_Arrived; + + Function Second_Has_Arrived return boolean is + begin + return Second_Flag; + end Second_has_Arrived; + + Function Abort_Has_Completed return boolean is + begin + return Abort_Flag; + end Abort_Has_Completed; + + end TC_PRT; + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to three dummy messages for this test and use + -- special artificial checks to pace the messages out under controlled + -- conditions for the test; allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..3 loop -- TC: arbitrarily limit to two credit messages + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message to start up the Credit task + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + elsif not TC_Prt.Abort_Has_Completed then + -- We have not yet processed the second message + -- Wait to send the second message until we know the first + -- has arrived at the Credit task and that task is in the + -- accept body + while not TC_Prt.First_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- We can now send the second message + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + + -- Now wait for the second to arrive on the Credit input queue + while not TC_Prt.Second_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point: The Credit task is in the accept block + -- dealing with the first message and the second message is + -- is on the input queue + abort Next_Message_Task.all; -- Note: we are still in the + -- declare block for the + -- second message task + + -- Make absolutely certain that all the actions + -- associated with the abort have been completed, that the + -- task has gone from Abnormal right through to + -- Termination. All requeues that are to going to be + -- cancelled will have been by the point of Termination. + while not Next_Message_Task.all'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- We now signal the Credit task that the abort has taken place + -- so that it can check that the entry queue is empty as the + -- requeue should have been cancelled + TC_Prt.Set_Abort_Has_Completed; + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the cancellation of the requeue. + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message_Complete.Set_True; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that this message did pass through the Distributor Task + Transaction.TC_Thru_Dist := true; + + -- Pass this transaction on the the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not cancelled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- first message has arrived and the Line Driver may now send + -- the second one + TC_Prt.Set_First_Has_Arrived; + + -- Now wait for the second to arrive + + while Input'Count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Second message has been requeued - the Line driver may + -- now abort the calling task + TC_Prt.Set_Second_Has_Arrived; + + -- Now wait for the Line Driver to signal that the abort of + -- the first task is complete - the requeue should be cancelled + -- at this time + while not TC_Prt.Abort_Has_Completed loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Input'Count /=0 then + Report.Failed ("Aborted Requeue was not cancelled -2"); + end if; + -- We can now complete the rendezvous with the first caller + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954013 + + Report.Test ("C954013", "Abort a task that has a call requeued"); + + Line_Driver.Start; -- start the test + + -- Wait for the message tasks to complete before calling Report.Result. + -- Although two Credit tasks are generated one is aborted so only + -- one completes, thus a single flag is sufficient + -- Note: the test will hang here if there is a problem with the + -- completion of the tasks + while not (TC_Credit_Message_Complete.Value and + TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954014.a b/gcc/testsuite/ada/acats/tests/c9/c954014.a new file mode 100644 index 000000000..53e45a090 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954014.a @@ -0,0 +1,485 @@ +-- C954014.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 requeue is not canceled and that the requeueing +-- task is unaffected when a calling task is aborted. Check that the +-- abort is deferred until the entry call is complete. +-- Specifically, check requeue to an entry in a different task, +-- requeue where the entry call has parameters, and requeue +-- without the abort option. +-- +-- TEST DESCRIPTION +-- In the Driver create a task that places a call on the +-- Distributor. In the Distributor requeue this call on the Credit task. +-- Abort the calling task when it is known to be in rendezvous with the +-- Credit task. (We arrange this by using artificial synchronization +-- points in the Driver and the accept body of the Credit task) Ensure +-- that the abort is deferred (the task is not terminated) until the +-- accept body completes. Afterwards, send one extra message through +-- the Distributor to check that the requeueing task has not been +-- disrupted. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Replaced global variables with protected objects +-- for ACVC 2.0.1. +-- +--! + +with Report; +with ImpDef; + +procedure C954014 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + + -- Synchronization flags for handshaking between the Line_Driver + -- and the Accept body in the Credit Task + TC_Handshake_A : Shared_Boolean (False); + TC_Handshake_B : Shared_Boolean (False); + TC_Handshake_C : Shared_Boolean (False); + TC_Handshake_D : Shared_Boolean (False); + TC_Handshake_E : Shared_Boolean (False); + TC_Handshake_F : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to two dummy messages for this test and use + -- special artificial handshaking checks with the Credit accept body + -- to control the test. Allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop -- TC: arbitrarily limit to one credit message + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message which will be aborted + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + + -- Wait for Credit task to get into the accept body + -- The call from the Message Task has been requeued by + -- the distributor + while not TC_Handshake_A.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Abort the calling task; the Credit task is guaranteed to + -- be in the accept body + abort Next_Message_Task.all; -- We are still in this declare + -- block + + -- Inform the Credit task that the abort has been initiated + TC_Handshake_B.Set_True; + + -- Now wait for the "acknowledgment" from the Credit task + -- this ensures a complete task switch (at least) + while not TC_Handshake_C.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The aborted task must not terminate till the accept body + -- has completed + if Next_Message_Task'terminated then + Report.Failed ("The abort was not deferred"); + end if; + + -- Inform the Credit task that the termination has been checked + TC_Handshake_D.Set_True; + + -- Now wait for the completion of the accept body in the + -- Credit task + while not TC_Handshake_E.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + while not ( Next_Message_Task'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Indicate to the Main program that this section is complete + TC_Handshake_F.Set_True; + + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the abort of the requeue; + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + -- The only Credit message was the one that should have been aborted + Report.Failed ("Abort was not effective"); + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + + -- Indicate that the message did pass through the + -- Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; -- without abort + when Debit => + requeue Debit_Computation.Input; -- without abort + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not canceled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- message has arrived and the Line Driver may now abort the + -- calling task + TC_Handshake_A.Set_True; + + -- Now wait for the Line Driver to inform us the calling + -- task has been aborted + while not TC_Handshake_B.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The abort has taken place + -- Inform the Line Driver that we are still running in the + -- accept body + TC_Handshake_C.Set_True; + + -- Now wait for the Line Driver to digest this information + while not TC_Handshake_D.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The Line driver has checked that the caller is not terminated + -- We can now complete the accept + + end Input; + -- We are out of the accept + TC_Handshake_E.Set_True; + + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954014 + Report.Test ("C954014", "Abort a task that has a call" & + " requeued_without_abort"); + + Line_Driver.Start; -- Start the test + + -- Wait for the message tasks to complete before reporting the result + -- + while not (TC_Handshake_F.Value -- abort not effective? + and TC_Debit_Message_Complete.Value -- Distributor affected? + and TC_Handshake_E.Value ) loop -- accept not completed? + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954015.a b/gcc/testsuite/ada/acats/tests/c9/c954015.a new file mode 100644 index 000000000..c86e1078e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954015.a @@ -0,0 +1,549 @@ +-- C954015.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 requeued calls to task entries may, in turn, be requeued. +-- Check that the intermediate requeues are not blocked and that the +-- original caller remains blocked until the last requeue is complete. +-- This test uses: +-- Call with parameters +-- Requeue with abort +-- +-- TEST DESCRIPTION +-- A call is placed on the input queue of the Distributor. The +-- Distributor requeues to the Credit task; the Credit task requeues to a +-- secondary task which, in turn requeues to yet another task. This +-- continues down the chain. At the furthest point of the chain the +-- rendezvous is completed. To verify the action, the furthest task +-- waits in the accept statement for a second message to arrive before +-- completing. This second message can only arrive if none of the earlier +-- tasks in the chain are blocked waiting for completion. Apart from +-- the two Credit messages which are used to check the requeue chain one +-- Debit message is sent to validate the mix. +-- +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C954015 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + TC_Expected_To_Complete : constant integer := 3; + + + -- Values added to the Return_Value indicating passage through the + -- particular task + TC_Credit_Value : constant integer := 1; + TC_Sub_1_Value : constant integer := 2; + TC_Sub_2_Value : constant integer := 3; + TC_Sub_3_Value : constant integer := 4; + TC_Sub_4_Value : constant integer := 5; + -- + TC_Full_Value : integer := TC_Credit_Value + TC_Sub_1_Value + + TC_Sub_2_Value + TC_Sub_3_Value + + TC_Sub_4_Value; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- The following are almost identical for the purpose of the test + task Credit_Sub_1 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_1; + -- + task Credit_Sub_2 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_2; + -- + task Credit_Sub_3 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_3; + + -- This is the last in the chain + task Credit_Sub_4 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_4; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the number of dummy messages needed for this + -- test and allow it to terminate at that point. + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + -- Arbitrary limit for the number of messages sent for this test + type TC_Trans_Range is range 1..3; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + + begin + + accept Start; -- wait for trigger from Main + + -- Arbitrarily limit the loop to the number needed for this test only + for Transaction_Numb in TC_Trans_Range loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + -- Artificially send out in the order required + case Transaction_Numb is + when 1 => + Build_Credit_Record( Next_Transaction ); + when 2 => + Build_Credit_Record( Next_Transaction ); + when 3 => + Build_Debit_Record ( Next_Transaction ); + end case; + + -- Present the record to the message task + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= TC_Full_Value or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - CR"); + end if; + if + This_Transaction.TC_Message_Count not in 1..2 then + Report.Failed ("Incorrect Message Count"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - DB"); + end if; + end if; + TC_Tasks_Completed.Increment; + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that the message did pass through the Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + + -- Computation task. + -- Note: After the computation is performed in this task the message is + -- passed on for further processing to some subsidiary task. The choice + -- of subsidiary task is made according to criteria not specified in + -- this test. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test, plug a known value and count + Transaction.Return_Value := TC_Credit_Value; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Depending on transaction content send it on to the + -- some other task for further processing + -- TC: Arbitrarily send the message on to Credit_Sub_1 + requeue Credit_Sub_1.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + task body Credit_Sub_1 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_1_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_2 + requeue Credit_Sub_2.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_1"); + + end Credit_Sub_1; + + task body Credit_Sub_2 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_2_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_3 + requeue Credit_Sub_3.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_2"); + end Credit_Sub_2; + + task body Credit_Sub_3 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_3_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_4 + requeue Credit_Sub_4.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_3"); + end Credit_Sub_3; + + -- This is the last in the chain of tasks to which transactions will + -- be requeued + -- + task body Credit_Sub_4 is + + TC_First_Message : Boolean := true; + + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_4_Value; + -- TC: stay in the accept body dealing with the first message + -- until the second arrives. If any of the requeues are + -- blocked the test will hang here indicating failure + if TC_First_Message then + while Input'count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + TC_First_Message := false; + end if; + -- for the second message, just complete the rendezvous + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_4"); + end Credit_Sub_4; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin + + Report.Test ("C954015", "Test multiple levels of requeue to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks completed before calling Result + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954015; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954016.a b/gcc/testsuite/ada/acats/tests/c9/c954016.a new file mode 100644 index 000000000..1390801ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954016.a @@ -0,0 +1,182 @@ +-- C954016.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 when a task that is called by a requeue is aborted, the +-- original caller receives Tasking_Error and the requeuing task is +-- unaffected. +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver. While the Receiver is in the accept body for this +-- rendezvous the Main aborts it. Check that Tasking_Error is raised in +-- the Original_Caller, that the Receiver does, indeed, get aborted and +-- the Intermediate task is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang which would constitute failure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Replaced shared global variable with protected +-- object for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954016 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Receiver_in_Accept : Shared_Boolean (False); + + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + entry TC_Never_Called; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_Original_Caller_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + accept Input do + TC_Receiver_in_Accept.Set_True; + -- Hang within the accept body to allow Main to abort this task + accept TC_Never_Called; + end Input; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + +begin + Report.Test ("C954016", "Requeue: abort the called task"); + + Original_Caller.Start; + + -- Wait till the rendezvous with Receiver is started + while not TC_Receiver_in_Accept.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point the Receiver is guaranteed to be in its accept + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and TC_Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954016; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954017.a b/gcc/testsuite/ada/acats/tests/c9/c954017.a new file mode 100644 index 000000000..a5447a756 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954017.a @@ -0,0 +1,184 @@ +-- C954017.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 when an exception is raised in the rendezvous of a task +-- that was called by a requeue the exception is propagated to the +-- original caller and that the requeuing task is unaffected. +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver. While the Receiver is in the accept body for this +-- rendezvous a Constraint_Error exception is raised. Check that the +-- exception is propagated to the Original_Caller, that the Receiver's +-- normal exception logic is employed and that the Intermediate task +-- is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang (and thus fail). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problem for +-- ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + + +procedure C954017 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + TC_Receiver_Complete : Boolean := false; + TC_Exception : Exception; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Exception_Process_Complete : Shared_Boolean (False); + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Exception not propagated to Original_Caller"); + + exception + when TC_Exception => + TC_Original_Caller_Complete := true; -- Expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the exception housekeeping is finished + while not TC_Exception_Process_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + -- + begin + accept Input do + null; -- the user code for the rendezvous is stubbed out + + -- Test Control: Raise an exception in the destination task which + -- should then be propagated + raise TC_Exception; + + end Input; + exception + when TC_Exception => + TC_Receiver_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + end Receiver; + + +begin + + Report.Test ("C954017", "Requeue: exception processing"); + + Original_Caller.Start; -- Start the test after the Report.Test + + -- Wait for the whole of the exception process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + TC_Exception_Process_Complete.Set_True; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and + TC_Intermediate_Complete and + TC_Receiver_Complete) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954017; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954018.a b/gcc/testsuite/ada/acats/tests/c9/c954018.a new file mode 100644 index 000000000..a9da1e06b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954018.a @@ -0,0 +1,227 @@ +-- C954018.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 if a task is aborted while a requeued call is queued +-- on one of its entries the original caller receives Tasking_Error +-- and the requeuing task is unaffected. +-- This test uses: Requeue to an entry in a different task +-- Parameterless call +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver on an entry with a guard that is always false. While the +-- Original_Caller is still queued the Receiver is aborted. +-- Check that Tasking_Error is raised in the Original_Caller, that the +-- Receiver does, indeed, get aborted and the Intermediate task +-- is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang and thus indicate failure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + + +procedure C954018 is + + + -- Protected object to control the shared test variables + -- + protected TC_State is + function On_Entry_Queue return Boolean; + procedure Set_On_Entry_Queue; + function Original_Caller_Complete return Boolean; + procedure Set_Original_Caller_Complete; + function Intermediate_Complete return Boolean; + procedure Set_Intermediate_Complete; + private + On_Entry_Queue_Flag : Boolean := false; + Original_Caller_Complete_Flag : Boolean := false; + Intermediate_Complete_Flag : Boolean := false; + end TC_State; + -- + -- + protected body TC_State is + function On_Entry_Queue return Boolean is + begin + return On_Entry_Queue_Flag; + end On_Entry_Queue; + + procedure Set_On_Entry_Queue is + begin + On_Entry_Queue_Flag := true; + end Set_On_Entry_Queue; + + function Original_Caller_Complete return Boolean is + begin + return Original_Caller_Complete_Flag; + end Original_Caller_Complete; + + procedure Set_Original_Caller_Complete is + begin + Original_Caller_Complete_Flag := true; + end Set_Original_Caller_Complete; + + function Intermediate_Complete return Boolean is + begin + return Intermediate_Complete_Flag; + end Intermediate_Complete; + + procedure Set_Intermediate_Complete is + begin + Intermediate_Complete_Flag := true; + end Set_Intermediate_Complete; + + end TC_State; + + --================================ + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_State.Set_Original_Caller_Complete; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + TC_State.Set_On_Entry_Queue; + requeue Receiver.Input with abort; + Report.Failed ("Requeue did not complete the Accept"); + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_State.Set_Intermediate_Complete; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + loop + select + -- A call to Input will be placed on the queue and never serviced + when Report.Equal (1,2) => -- Always false + accept Input do + Report.Failed ("Receiver in Accept"); + end Input; + or + delay ImpDef.Minimum_Task_Switch; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + +begin + + Report.Test ("C954018", "Requeue: abort the called task" & + " while Caller is still queued"); + + Original_Caller.Start; + + + -- This is the main part of the test + + -- Wait for the requeue + while not TC_State.On_Entry_Queue loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Delay long enough to ensure that the requeue has "arrived" on + -- the entry queue. Note: TC_State.Set_On_Entry_Queue is called the + -- statement before the requeue + -- + delay ImpDef.Switch_To_New_Task; + + -- At this point the Receiver is guaranteed to have the requeue on + -- the entry queue + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_State.Original_Caller_Complete and + TC_State.Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954018; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954019.a b/gcc/testsuite/ada/acats/tests/c9/c954019.a new file mode 100644 index 000000000..fafc6aa59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954019.a @@ -0,0 +1,314 @@ +-- C954019.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 when a requeue is to the same entry the items go to the +-- right queue and that they are placed back on the end of the queue. +-- +-- TEST DESCRIPTION: +-- Simulate part of a message handling application where the messages are +-- composed of several segments. The sequence of the segments within the +-- message is specified by Seg_Sequence_No. The segments are handled by +-- different tasks and finally forwarded to an output driver. The +-- segments can arrive in any order but must be assembled into the proper +-- sequence for final output. There is a Sequencer task interposed +-- before the Driver. This takes the segments of the message off the +-- Ordering_Queue and those that are in the right order it sends on to +-- the driver; those that are out of order it places back on the end of +-- the queue. +-- +-- The test just simulates the arrival of the segments at the Sequencer. +-- The task generating the segments handshakes with the Sequencer during +-- the "Await Arrival" phase ensuring that the three segments of a +-- message arrive in REVERSE order (the End-of-Message segment arrives +-- first and the Header last). In the first cycle the sequencer pulls +-- segments off the queue and puts them back on the end till it +-- encounters the header. It checks the sequence of the ones it pulls +-- off in case the segments are being put back on in the wrong part of +-- the queue. Having cycled once through it no longer verifies the +-- sequence - it just executes the "application" code for the correct +-- order for dispatch to the driver. +-- +-- In this simple example no attempt is made to address segments of +-- another message arriving or any other error conditions (such as +-- missing segments, timing etc.) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Remove parameter from requeue statement +-- +--! + +with Report; +with ImpDef; + +procedure C954019 is +begin + + + Report.Test ("C954019", "Check Requeue to the same Accept"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Alpha : string (1..128); + EOM : Boolean := false; -- true for final msg segment + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + task Sequencer is + entry Ordering_Queue ( Segment : acc_Message_Segment ); + entry TC_Handshake_1; + entry TC_Handshake_2; + end Sequencer; + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + Sequencer.TC_Handshake_1; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header + 1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + Sequencer.TC_Handshake_2; + -- Build the segment. The last segment in order to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Ordering_Queue ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + + -- Pull segments off the Ordering_Queue and deliver them in the correct + -- sequence to the Output_Driver. + -- + task body Sequencer is + Next_Needed : Segment_Sequence := Header; + + TC_Await_Arrival : Boolean := true; + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + begin + loop + select + accept Ordering_Queue ( Segment : acc_Message_Segment ) do + + --===================================================== + -- This part is all Test_Control code + + if TC_Await_Arrival then + -- We have to arrange that the segments arrive on the + -- queue in the right order, so we handshake with the + -- TC_Simulate_Arrival task to "send" only one at + -- a time + accept TC_Handshake_1; -- the first has arrived + -- and has been pulled off the + -- queue + + -- Wait for the second to arrive (the first has already + -- been pulled off the queue + while Ordering_Queue'count < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + accept TC_Handshake_2; -- the second has arrived + + -- Wait for the third to arrive + while Ordering_Queue'count < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Subsequent passes through the loop, bypass this code + TC_Await_Arrival := false; + + + end if; -- await arrival + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + Report.Failed ("Sequencer: Segment out of sequence"); + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + + end if; -- decrementing + end if; -- first pass + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + Report.Failed ("Requeue did not complete accept body"); + else + -- Not the next needed - put it back on the queue + requeue Sequencer.Ordering_Queue; + Report.Failed ("Requeue did not complete accept body"); + end if; + end Ordering_Queue; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Sequencer"); + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + + begin + + null; + + end; -- encapsulation + + Report.Result; + +end C954019; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954020.a b/gcc/testsuite/ada/acats/tests/c9/c954020.a new file mode 100644 index 000000000..bc08a6bd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954020.a @@ -0,0 +1,422 @@ +-- C954020.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 call to a protected entry can be requeued to a task +-- entry. Check that the requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeue and continues +-- after the requeued rendezvous. Check that the requeue does not block. +-- Specifically, check a requeue with abort from a protected entry to +-- an entry in a task. +-- +-- TEST DESCRIPTION: +-- +-- In the Distributor protected object, requeue two successive calls on +-- the entries of two separate target tasks. Each task in each of the +-- paths adds identifying information in the transaction being passed. +-- This information is checked by the Message tasks on completion +-- ensuring that the requeues have been placed on the correct queues. +-- There is an artificial guard on the Credit Task to ensure that the +-- input is queued; this guard is released by the Debit task which +-- handles its input immediately. This ensures that we have one of the +-- requeued items actually queued for later handling and also verifies +-- that the requeuing process (in the protected object) is not blocked. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor object which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 06 Nov 95 SAIC Fixed problems for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954020 is + Verbose : constant Boolean := False; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + protected type Message_Status is + procedure Set_Complete; + function Complete return Boolean; + private + Is_Complete : Boolean := False; + end Message_Status; + + protected body Message_Status is + procedure Set_Complete is + begin + Is_Complete := True; + end Set_Complete; + + function Complete return Boolean is + begin + return Is_Complete; + end Complete; + end Message_Status; + + TC_Debit_Message : Message_Status; + TC_Credit_Message : Message_Status; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + if Verbose then + Report.Comment ("message task got " & + Transaction_Code'Image (This_Transaction.Code)); + end if; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Set_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Set_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + if Verbose then + Report.Comment ("Credit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + end Input; + exit; -- only handle 1 transaction + else + -- poll until we can accept credit transaction + delay ImpDef.Clear_Ready_Queue; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + if Verbose then + Report.Comment ("Debit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- C954020 + + Report.Test ("C954020", "Requeue, with abort, from protected entry " & + "to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Complete and TC_Debit_Message.Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954020; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954021.a b/gcc/testsuite/ada/acats/tests/c9/c954021.a new file mode 100644 index 000000000..626f2f970 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954021.a @@ -0,0 +1,524 @@ +-- C954021.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 requeue within a protected entry to an entry in a +-- different protected object is queued correctly. +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After processing +-- this the Credit task sets the "overloaded" indicator. Once this +-- indicator is set the Distributor (a protected object) queues low +-- priority transactions on a Wait_for_Underload queue in another +-- protected object using a requeue. The Distributor still delivers high +-- priority transactions. After two high priority transactions have been +-- processed by the Credit task it clears the overload condition. The +-- low priority transactions should now be delivered. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Fixed shared global variable for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954021 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + + TC_Credit_Messages_Expected : constant integer := 5; + + protected TC_Handshake is + procedure Set; + function First_Message_Arrived return Boolean; + private + Arrived_Flag : Boolean := false; + end TC_Handshake; + + -- Handshaking mechanism between the Line Driver and the Credit task + -- + protected body TC_Handshake is + -- + procedure Set is + begin + Arrived_Flag := true; + end Set; + -- + function First_Message_Arrived return Boolean is + begin + return Arrived_Flag; + end First_Message_Arrived; + -- + end TC_Handshake; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Credit_Overloaded; + function Credit_is_Overloaded return Boolean; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Underloaded; + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + private + Release_All : Boolean := false; + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Credit_Overloaded is + begin + Credit_Overloaded := false; + Hold.Underloaded; -- Release all held messages + end Clear_Credit_Overloaded; + + function Credit_is_Overloaded return Boolean is + begin + return Credit_Overloaded; + end Credit_is_Overloaded; + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority = Low then + requeue Hold.Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once this is executed the barrier condition for the entry is + -- evaluated + procedure Underloaded is + begin + Release_All := true; + end Underloaded; + + entry Wait_for_Underload (Transaction : acc_Transaction_Record) + when Release_All is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload'count = 0 then + -- Queue is purged. Set up to hold next batch + Release_All := false; + end if; + end Wait_for_Underload; + + end Hold; + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_Handshake.First_Message_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Distributor.Credit_is_Overloaded + and Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Hold.Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_Handshake.Set; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Distributor.Clear_Credit_Overloaded; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + +begin + Report.Test ("C954021", "Requeue from one entry body to an entry in" & + " another protected object"); + + Line_Driver.Start; -- Start the test + + + -- Ensure that the message tasks have completed before reporting result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954021; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954022.a b/gcc/testsuite/ada/acats/tests/c9/c954022.a new file mode 100644 index 000000000..5ebff8dcb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954022.a @@ -0,0 +1,351 @@ +-- C954022.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: +-- In an entry body requeue the call to the same entry. Check that the +-- items go to the right queue and that they are placed back on the end +-- of the queue +-- +-- TEST DESCRIPTION: +-- Simulate part of a message handling application where the messages are +-- composed of several segments. The sequence of the segments within the +-- message is specified by Seg_Sequence_No. The segments are handled by +-- different tasks and finally forwarded to an output driver. The +-- segments can arrive in any order but must be assembled into the proper +-- sequence for final output. There is a Sequencer task interposed +-- before the Driver. This takes the segments of the message off the +-- Ordering_Queue and those that are in the right order it sends on to +-- the driver; those that are out of order it places back on the end of +-- the queue. +-- +-- The test just simulates the arrival of the segments at the Sequencer. +-- The task generating the segments handshakes with the Sequencer during +-- the "Await Arrival" phase ensuring that the three segments of a +-- message arrive in REVERSE order (the End-of-Message segment arrives +-- first and the Header last). In the first cycle the sequencer pulls +-- segments off the queue and puts them back on the end till it +-- encounters the header. It checks the sequence of the ones it pulls +-- off in case the segments are being put back on in the wrong part of +-- the queue. Having cycled once through it no longer verifies the +-- sequence - it just executes the "application" code for the correct +-- order for dispatch to the driver. +-- +-- In this simple example no attempt is made to address segments of +-- another message arriving or any other error conditions (such as +-- missing segments, timing etc.) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Nov 95 SAIC ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954022 is + + -- These global Booleans are set when failure conditions inside Protected + -- objects are encountered. Report.Failed cannot be called within + -- the object or a Bounded Error would occur + -- + TC_Failed_1 : Boolean := false; + TC_Failed_2 : Boolean := false; + TC_Failed_3 : Boolean := false; + +begin + + + Report.Test ("C954022", "Check Requeue to the same Protected Entry"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Segs_In_Message : integer; -- Total segs this message + EOM : Boolean := false; -- true for final msg segment + Alpha : string (1..128); + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + protected Sequencer is + function TC_Arrivals return integer; + entry Input ( Segment : acc_Message_Segment ); + entry Ordering_Queue ( Segment : acc_Message_Segment ); + private + Number_of_Segments_Arrived : integer := 0; + Number_of_Segments_Expected : integer := 0; + Next_Needed : Segment_Sequence := Header; + All_Segments_Arrived : Boolean := false; + Seen_EOM : Boolean := false; + + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + + end Sequencer; + + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.Segs_In_Message := 3; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + while Sequencer.TC_Arrivals < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header +1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + while Sequencer.TC_Arrivals < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment. The last segment (in order) to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + + + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Input ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + -- Store segments on the Ordering_Queue then deliver them in the correct + -- sequence to the Output_Driver. + -- + protected body Sequencer is + + function TC_Arrivals return integer is + begin + return Number_of_Segments_Arrived; + end TC_Arrivals; + + + -- Segments arriving at the Input queue are counted and checked + -- against the total number of segments for the message. They + -- are requeued onto the ordering queue where they are held until + -- all the segments have arrived. + entry Input ( Segment : acc_Message_Segment ) when true is + begin + -- check for EOM, if so get the number of segments in the message + -- Note: in this portion of code no attempt is made to address + -- reset for new message , end conditions, missing segments, + -- segments of a different message etc. + Number_of_Segments_Arrived := Number_of_Segments_Arrived + 1; + if Segment.EOM then + Number_of_Segments_Expected := Segment.Segs_In_Message; + Seen_EOM := true; + end if; + + if Seen_EOM then + if Number_of_Segments_Arrived = Number_of_Segments_Expected then + -- This is the last segment for this message + All_Segments_Arrived := true; -- clear the barrier + end if; + end if; + + requeue Ordering_Queue; + + -- At this exit point the entry queue barriers are evaluated + + end Input; + + + entry Ordering_Queue ( Segment : acc_Message_Segment ) + when All_Segments_Arrived is + begin + + --===================================================== + -- This part is all Test_Control code + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + TC_Failed_3 := true; + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + end if; -- decrementing + end if; -- first cycle + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + -- :: other resets not shown + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_1 := true; + else + -- Not the next needed - put it back on the queue + -- NOTE: here we are requeueing to the same entry + requeue Sequencer.Ordering_Queue; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_2 := true; + end if; + end Ordering_Queue; + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + begin + + null; + + end; -- encapsulation + + if TC_Failed_1 then + Report.Failed ("Requeue did not complete entry body - 1"); + end if; + + if TC_Failed_2 then + Report.Failed ("Requeue did not complete entry body - 2"); + end if; + + if TC_Failed_3 then + Report.Failed ("Sequencer: Segment out of sequence"); + end if; + + Report.Result; + +end C954022; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954023.a b/gcc/testsuite/ada/acats/tests/c9/c954023.a new file mode 100644 index 000000000..bfa69dc60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954023.a @@ -0,0 +1,558 @@ +-- C954023.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 requeue within a protected entry to a family of entries +-- in a different protected object is queued correctly +-- Call with parameters +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After processing +-- this, the Credit task sets the "overloaded" indicator. Once this +-- indicator is set the Distributor (a protected object) queues lower +-- priority transactions on a family of queues (Wait_for_Underload) in +-- another protected object using a requeue. The Distributor still +-- delivers high priority transactions. After two more high priority +-- transactions have been processed by the Credit task the artificial +-- test code clears the overload condition to the threshold level that +-- allows only the items on the Medium priority queue of the family to be +-- released. When these have been processed and checked the test code +-- then lowers the priority threshold once again, allowing the Low +-- priority items from the last queue in the family to be released, +-- processed and checked. Note: the High priority queue in the family is +-- not used. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C954023 is + + -- Artificial: number of messages required for this test + subtype TC_Trans_Range is integer range 1..8; + + TC_Credit_Messages_Expected : constant integer + := TC_Trans_Range'Last - 1; + + TC_Debit_Message_Complete : Boolean := false; + + + -- Mechanism for handshaking between tasks + protected TC_PO is + procedure Increment_Tasks_Completed_Count; + function Tasks_Completed_Count return integer; + function First_Message_Has_Arrived return Boolean; + procedure Set_First_Message_Has_Arrived; + private + Number_Complete : integer := 0; + Message_Arrived_Flag : Boolean := false; + end TC_PO; + -- + protected body TC_PO is + procedure Increment_Tasks_Completed_Count is + begin + Number_Complete := Number_Complete + 1; + end Increment_Tasks_Completed_Count; + + function Tasks_Completed_Count return integer is + begin + return Number_Complete; + end Tasks_Completed_Count; + + function First_Message_Has_Arrived return Boolean is + begin + return Message_Arrived_Flag; + end First_Message_Has_Arrived; + + procedure Set_First_Message_Has_Arrived is + begin + Message_Arrived_Flag := true; + end Set_First_Message_Has_Arrived; + + end TC_PO; + +begin + + Report.Test ("C954023", "Requeue from within a protected object" & + " to a family of entries in another protected object"); + + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + type App_Priority is (Low, Medium, High); + type Priority_Block is array (App_Priority) of Boolean; + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : App_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Overload_to_Medium; + procedure Clear_Overload_to_Low; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Release_Medium; + procedure Release_Low; + -- Family of entry queues indexed by App_Priority + entry Wait_for_Underload (App_Priority) + (Transaction : acc_Transaction_Record); + private + Release : Priority_Block := (others => false); + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Overload_to_Medium is + begin + Credit_Overloaded := false; + Hold.Release_Medium; -- Release all held messages on Medium + -- priority queue + end Clear_Overload_to_Medium; + + procedure Clear_Overload_to_Low is + begin + Credit_Overloaded := false; + Hold.Release_Low; -- Release all held messages on Low + -- priority queue + end Clear_Overload_to_Low; + + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority /= High then + -- use the appropriate queue in the family + requeue Hold.Wait_for_Underload(Transaction.Priority) + with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once these are executed the barrier conditions for the entries + -- are evaluated + procedure Release_Medium is + begin + Release(Medium) := true; + end Release_Medium; + -- + procedure Release_Low is + begin + Release(Low) := true; + end Release_Low; + + -- This is a family of entry queues indexed by App_Priority + entry Wait_for_Underload (for AP in App_Priority) + (Transaction : acc_Transaction_Record) + when Release(AP) is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload(AP)'count = 0 then + -- Queue is purged. Set up to hold next batch + Release(AP) := false; + end if; + end Wait_for_Underload; + + end Hold; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- cycle the generation of High medium and Low priority Credit + -- transactions for this test. Send out one final Debit message + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : App_Priority := High; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_PO.First_Message_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Cycle generation of high medium and low priority + -- transactions + if Current_Priority = High then + Current_Priority := Medium; + elsif + Current_Priority = Medium then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction(In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_PO.Increment_Tasks_Completed_Count; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete := true; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + + -- Perform the computations required for this transaction + null; -- stub + + + -- The following is all Test Control code: + + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- This is checked by the Message_Task: + Transaction.Return_Value := Credit_Return; + + -- Now take special action depending on which Message. + -- Note: The count gives the order in which the messages are + -- arriving at this task NOT the order in which they + -- were originally generated and sent out. + + Message_Count := Message_Count + 1; + + if Message_Count < 4 then + -- This is one of the first three messages which must + -- be High priority because we will set "Overload" after + -- the first, which is known to be High. The lower + -- priority should be waiting on the queues + if Transaction.Priority /= High then + Report.Failed + ("Credit Task: Lower priority trans. during overload"); + end if; + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and + -- subsequent messages may now be sent + TC_PO.Set_First_Message_Has_Arrived; + elsif + Message_Count = 3 then + -- The two high priority transactions created + -- subsequent to the overload have now been processed, + -- release the Medium priority items + Distributor.Clear_Overload_to_Medium; + end if; + elsif Message_Count < 6 then + -- This must be one of the Medium priority messages + if Transaction.Priority /= Medium then + Report.Failed + ("Credit Task: Second group not Medium Priority"); + end if; + if Message_Count = 5 then + -- The two medium priority transactions + -- have now been processed - release the + -- Low priority items + Distributor.Clear_Overload_to_Low; + end if; + elsif Message_Count < TC_Trans_Range'Last then + -- This must be one of the Low priority messages + if Transaction.Priority /= Low then + Report.Failed + ("Credit Task: Third group not Low Priority"); + end if; + else + -- Too many transactions have arrived. Duplicates? + -- the Debit transaction? + Report.Failed + ("Credit Task: Too many transactions"); + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + + begin -- declare + + null; + + end; -- declare (test encapsulation) + + if (TC_PO.Tasks_Completed_Count /= TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete then + Report.Failed ("Incorrect number of Message Tasks completed"); + end if; + + Report.Result; + +end C954023; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954024.a b/gcc/testsuite/ada/acats/tests/c9/c954024.a new file mode 100644 index 000000000..7f19a8183 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954024.a @@ -0,0 +1,380 @@ +-- C954024.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 call to a protected entry can be requeued to a task +-- entry. Check that the requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeue and continues +-- after the requeued rendezvous. Check that the requeue does not block. +-- Specifically, check a requeue without abort from a protected entry to +-- an entry in a task. +-- +-- TEST DESCRIPTION: +-- In the Distributor protected object, requeue two successive calls on +-- the entries of two separate target tasks. Each task in each of the +-- paths adds identifying information in the transaction being passed. +-- This information is checked by the Message tasks on completion +-- ensuring that the requeues have been placed on the correct queues. +-- There is an artificial guard on the Credit Task to ensure that the +-- input is queued; this guard is released by the Debit task which +-- handles its input immediately. This ensures that we have one of the +-- requeued items actually queued for later handling and also verifies +-- that the requeuing process (in the protected object) is not blocked. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor object which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Fixed reported problems for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; +procedure C954024 is + + +begin -- C954024 + + Report.Test ("C954024", "Requeue from protected entry to task entry"); + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; + when Debit => + requeue Debit_Computation.Input; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- NOTE: + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction + (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + exit; -- one message is enough + else + delay ImpDef.Clear_Ready_Queue; -- poll + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + end Debit_Computation; + + begin -- declare block + Line_Driver.Start; + end; -- test encapsulation + + Report.Result; + +end C954024; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954025.a b/gcc/testsuite/ada/acats/tests/c9/c954025.a new file mode 100644 index 000000000..c4993f7ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954025.a @@ -0,0 +1,237 @@ +-- C954025.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 if the original entry call was a conditional entry call, +-- the call is cancelled if a requeue-with-abort of the call is not +-- selected immediately. +-- Check that if the original entry call was a timed entry call, the +-- expiration time for a requeue-with-abort is the original expiration +-- time. +-- +-- TEST DESCRIPTION: +-- This test declares two tasks: Launch_Control and Mission_Control. +-- Mission_Control instructs Launch_Control to start its countdown +-- and then requeues (with abort) to the Launch_Control.Launch +-- entry. This call to Launch will be accepted at the end of the +-- countdown (if the task is still waiting). +-- The main task does an unconditional, conditional, and timed +-- entry call to Mission_Control and checks to see if the launch +-- was accepted. +-- +-- +-- CHANGE HISTORY: +-- 18 OCT 95 SAIC ACVC 2.1 +-- 10 JUL 96 SAIC Incorporated reviewer's comments. +-- +--! + +with Calendar; use type Calendar.Time; +with Report; +with ImpDef; +procedure C954025 is + Verbose : constant Boolean := False; + Countdown_Amount : constant Duration := 2.0 * Impdef.One_Long_Second; + Plenty_Of_Time : constant Duration := + Countdown_Amount + ImpDef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second; + Not_Enough_Time : constant Duration := + Countdown_Amount - 0.5 * Impdef.One_Long_Second; +begin + Report.Test ("C954025", + "Check that if the original entry" & + " call was a conditional or timed entry call, the" & + " expiration time for a requeue with abort is the" & + " original expiration time"); + declare + -- note that the following object is a shared object and its use + -- governed by the rules of 9.10(3,4,8);6.0 + Launch_Accepted : Boolean := False; + + task Launch_Control is + entry Enable_Launch_Control; + entry Start_Countdown (How_Long : Duration); + -- Launch will be accepted if a call is waiting when the countdown + -- reaches 0 + entry Launch; + end Launch_Control; + + task body Launch_Control is + Wait_Amount : Duration := 0.0; + begin + loop + select + accept Enable_Launch_Control do + Launch_Accepted := False; + end Enable_Launch_Control; + or + terminate; + end select; + + accept Start_Countdown (How_Long : Duration) do + Wait_Amount := How_Long; + end Start_Countdown; + + delay Wait_Amount; + + select + accept Launch do + Launch_Accepted := True; + end Launch; + else + null; + -- note that Launch_Accepted is False here + end select; + end loop; + end Launch_Control; + + task Mission_Control is + -- launch will occur if we are given enough time to complete + -- a standard countdown. We will not be rushed! + entry Do_Launch; + end Mission_Control; + + task body Mission_Control is + begin + loop + select + accept Do_Launch do + Launch_Control.Start_Countdown (Countdown_Amount); + requeue Launch_Control.Launch with abort; + end Do_Launch; + or + terminate; + end select; + end loop; + end Mission_Control; + + begin -- test encapsulation + -- unconditional entry call to check the simple case + Launch_Control.Enable_Launch_Control; + Mission_Control.Do_Launch; + if Launch_Accepted then + if Verbose then + Report.Comment ("simple case passed"); + end if; + else + Report.Failed ("simple case"); + end if; + + + -- timed but with plenty of time - delay relative + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + or + delay Plenty_Of_Time; + if Launch_Accepted then + Report.Failed ("plenty of time timed out after accept (1)"); + end if; + end select; + if Launch_Accepted then + if Verbose then + Report.Comment ("plenty of time case passed (1)"); + end if; + else + Report.Failed ("plenty of time (1)"); + end if; + + + -- timed but with plenty of time -- delay until + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + or + delay until Calendar.Clock + Plenty_Of_Time; + if Launch_Accepted then + Report.Failed ("plenty of time timed out after accept(2)"); + end if; + end select; + if Launch_Accepted then + if Verbose then + Report.Comment ("plenty of time case passed (2)"); + end if; + else + Report.Failed ("plenty of time (2)"); + end if; + + + -- timed without enough time - delay relative + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + Report.Failed ("not enough time completed accept (1)"); + or + delay Not_Enough_Time; + end select; + if Launch_Accepted then + Report.Failed ("not enough time (1)"); + else + if Verbose then + Report.Comment ("not enough time case passed (1)"); + end if; + end if; + + + -- timed without enough time - delay until + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + Report.Failed ("not enough time completed accept (2)"); + or + delay until Calendar.Clock + Not_Enough_Time; + end select; + if Launch_Accepted then + Report.Failed ("not enough time (2)"); + else + if Verbose then + Report.Comment ("not enough time case passed (2)"); + end if; + end if; + + + -- conditional case + Launch_Control.Enable_Launch_Control; + -- make sure Mission_Control is ready to accept immediately + delay ImpDef.Clear_Ready_Queue; + select + Mission_Control.Do_Launch; + Report.Failed ("no time completed accept"); + else + if Verbose then + Report.Comment ("conditional case - else taken"); + end if; + end select; + if Launch_Accepted then + Report.Failed ("no time"); + else + if Verbose then + Report.Comment ("no time case passed"); + end if; + end if; + + end; + + Report.Result; +end C954025; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954026.a b/gcc/testsuite/ada/acats/tests/c9/c954026.a new file mode 100644 index 000000000..9e261247b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954026.a @@ -0,0 +1,269 @@ +-- C954026.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 if the original protected entry call was a conditional +-- entry call, the call is cancelled if a requeue-with-abort of the +-- call is not selected immediately. +-- Check that if the original protected entry call was a timed entry +-- call, the expiration time for a requeue-with-abort is the original +-- expiration time. +-- +-- TEST DESCRIPTION: +-- In this test the main task makes a variety of calls to the protected +-- object Initial_PO. These calls include a simple call, a conditional +-- call, and a timed call. The timed calls include calls with enough +-- time and those with less than the needed amount of time to get through +-- the requeue performed by Initial_PO. +-- Initial_PO requeues its entry call to Final_PO. +-- Final_PO does not accept the requeued call until the protected +-- procedure Ok_To_Take_Requeue is called. +-- A separate task, Delayed_Opener, is used to call Ok_To_Take_Requeue +-- after a delay amount specified by the main task has expired. +-- +-- +-- CHANGE HISTORY: +-- 15 DEC 95 SAIC ACVC 2.1 +-- 10 JUL 96 SAIC Incorporated reviewer comments. +-- 10 OCT 96 SAIC Incorporated fix provided by vendor. +-- +--! + +with Calendar; +use type Calendar.Time; +with Report; +with Impdef; +procedure C954026 is + Verbose : constant Boolean := False; + Final_Po_Reached : Boolean := False; + Allowed_Time : constant Duration := 2.0 * Impdef.One_Long_Second; + Plenty_Of_Time : constant Duration := + Allowed_Time + Impdef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second; + Not_Enough_Time : constant Duration := Allowed_Time - 0.5 * Impdef.One_Long_Second; +begin + Report.Test ("C954026", + "Check that if the original entry" & + " call was a conditional or timed entry call," & + " the expiration time for a requeue with" & + " abort to a protected" & + " entry is the original expiration time"); + declare + + protected Initial_Po is + entry Start_Here; + end Initial_Po; + + protected Final_Po is + entry Requeue_Target; + procedure Ok_To_Take_Requeue; + procedure Close_Requeue; + private + Open : Boolean := False; + end Final_Po; + + -- the Delayed_Opener task is used to notify Final_PO that it can + -- accept the Requeue_Target entry. + task Delayed_Opener is + entry Start_Timer (Amt : Duration); + entry Cancel_Timer; + end Delayed_Opener; + + task body Delayed_Opener is + Wait_Amt : Duration; + begin + loop + accept Start_Timer (Amt : Duration) do + Wait_Amt := Amt; + end Start_Timer; + exit when Wait_Amt < 0.0; + if Verbose then + Report.Comment ("Timer started"); + end if; + select + accept Cancel_Timer do + Final_Po.Close_Requeue; + end Cancel_Timer; + or + delay Wait_Amt; + Final_Po.Ok_To_Take_Requeue; + accept Cancel_Timer do + Final_Po.Close_Requeue; + end Cancel_Timer; + end select; + end loop; + exception + when others => + Report.Failed ("exception in Delayed_Opener"); + end Delayed_Opener; + + protected body Initial_Po is + entry Start_Here when True is + begin + Final_Po_Reached := False; + requeue Final_Po.Requeue_Target with abort; + end Start_Here; + end Initial_Po; + + protected body Final_Po is + entry Requeue_Target when Open is + begin + Open := False; + Final_Po_Reached := True; + end Requeue_Target; + + procedure Ok_To_Take_Requeue is + begin + Open := True; + end Ok_To_Take_Requeue; + + procedure Close_Requeue is + begin + Open := False; + end Close_Requeue; + end Final_Po; + + begin -- test encapsulation + -- unconditional entry call to check the simple case + Delayed_Opener.Start_Timer (0.0); + Initial_Po.Start_Here; + if Final_Po_Reached then + if Verbose then + Report.Comment ("simple case passed"); + end if; + else + Report.Failed ("simple case"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed but with plenty of time - delay relative + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + or + delay Plenty_Of_Time; + Report.Failed ("plenty of time timed out (1)"); + if Final_Po_Reached then + Report.Failed ( + "plenty of time timed out after accept (1)"); + end if; + end select; + if Final_Po_Reached then + if Verbose then + Report.Comment ("plenty of time case passed (1)"); + end if; + else + Report.Failed ("plenty of time (1)"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed but with plenty of time -- delay until + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + or + delay until Calendar.Clock + Plenty_Of_Time; + Report.Failed ("plenty of time timed out (2)"); + if Final_Po_Reached then + Report.Failed ( + "plenty of time timed out after accept(2)"); + end if; + end select; + if Final_Po_Reached then + if Verbose then + Report.Comment ("plenty of time case passed (2)"); + end if; + else + Report.Failed ("plenty of time (2)"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed without enough time - delay relative + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("not enough time completed accept (1)"); + or + delay Not_Enough_Time; + end select; + if Final_Po_Reached then + Report.Failed ("not enough time (1)"); + else + if Verbose then + Report.Comment ("not enough time case passed (1)"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed without enough time - delay until + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("not enough time completed accept (2)"); + or + delay until Calendar.Clock + Not_Enough_Time; + end select; + if Final_Po_Reached then + Report.Failed ("not enough time (2)"); + else + if Verbose then + Report.Comment ("not enough time case passed (2)"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + + -- conditional case + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("no time completed accept"); + else + if Verbose then + Report.Comment ("conditional case - else taken"); + end if; + end select; + if Final_Po_Reached then + Report.Failed ("no time"); + else + if Verbose then + Report.Comment ("no time case passed"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + -- kill off the Delayed_Opener task + Delayed_Opener.Start_Timer (-10.0); + + exception + when others => + Report.Failed ("exception in main"); + end; + + Report.Result; +end C954026; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a01.a b/gcc/testsuite/ada/acats/tests/c9/c954a01.a new file mode 100644 index 000000000..3ea545a8f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a01.a @@ -0,0 +1,262 @@ +-- C954A01.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 if a task requeued without abort on a protected entry queue +-- is aborted, the abort is deferred until the entry call completes, +-- after which the task becomes completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Attempt to abort the requesting +-- task. Verify that it is not aborted. Call the second protected +-- procedure of the protected type (the interrupt handler) and verify that +-- the protected entry completes for the requesting task. Verify that +-- the requesting task is then aborted. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate. +-- +--! + +package C954A01_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A01_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954A00); + +package body C954A01_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing; -- server task free + -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + -- Allow other tasks to get control + delay ImpDef.Long_Minimum_Task_Switch; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A01_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A01_0; -- Printer server abstraction. + +use C954A01_0; +use F954A00; + +procedure C954A01 is + + Long_Enough : constant Duration := ImpDef.Long_Switch_To_New_Task; + + --==============================================-- + + task Print_Request; -- Send a print request. + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Report.Failed ("Task continued execution following entry call"); + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A01", "Requeue without abort - check that the abort " & + "is deferred until after the rendezvous completes. (Task to PO)"); + + -- To pass this test, the following must be true: + -- + -- (A) The abort of Print_Request is deferred until after the + -- Done_Printing entry body completes. + -- (B) Print_Request aborts after the Done_Printing entry call + -- completes. + -- + -- Call the entry Verify_Results. The entry call will not be accepted + -- until after Print_Request has been requeued to Done_Printing. + + Printer_Server.Verify_Results; -- Accepted after Print_Request is + -- requeued to Done_Printing. + + -- Simulate an application which needs access to the printer within + -- a specified time, and which aborts the current printer job if time + -- runs out. + + select + Printer(1).Done_Printing; -- Wait for printer to come free. + or + delay Long_Enough; -- Print job took too long. + abort Print_Request; -- Abort print job. + end select; + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- abort to complete (if it's going + -- to). + + -- Verify that the Done_Printing entry body has not yet completed, + -- and thus that Print_Request has not been aborted. + + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif Print_Request'Terminated then + Report.Failed ("Caller was aborted before entry was complete"); + else + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + + -- The Done_Printing entry body will complete before the next protected + -- action is called (Printer(1).Is_Done). Verify (A) and (B): that the + -- Print_Request is aborted. + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- Print_Request abort to complete. + + if not Printer(1).Is_Done then + Report.Failed ("Target entry of requeue did not complete"); + end if; + + if not Print_Request'Terminated then + Report.Failed ("Task not aborted following completion of entry call"); + abort Print_Request; -- Try to kill hung task. + end if; + + end if; + + Report.Result; + +end C954A01; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a02.a b/gcc/testsuite/ada/acats/tests/c9/c954a02.a new file mode 100644 index 000000000..7d61aea8c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a02.a @@ -0,0 +1,259 @@ +-- C954A02.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 if a task requeued with abort on a protected entry queue +-- is aborted, the protected entry call is canceled and the aborted +-- task becomes completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Attempt to abort the requesting +-- task. Verify that it is aborted, that the requeued entry call is +-- canceled, and that the corresponding entry body is not executed. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate +-- +--! + +package C954A02_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A02_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954a00); + +package body C954A02_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other task to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A02_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A02_0; -- Printer server abstraction. + +use C954A02_0; +use F954A00; + +procedure C954A02 is + + -- Length of time which simulates a very long process + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + --==============================================-- + + task Print_Request; -- Send a print request. + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Report.Failed ("Task continued execution following entry call"); + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A02", "Abort a requeue on a Protected entry"); + + -- To pass this test, the following must be true: + -- + -- (A) The abort of Print_Request takes place immediately. + -- (B) The Done_Printing entry call is canceled, and the corresponding + -- entry body is not executed. + -- + -- Call the entry Verify_Results. The entry call will not be accepted + -- until after Print_Request has been requeued to Done_Printing. + + Printer_Server.Verify_Results; -- Accepted after Print_Request is + -- requeued to Done_Printing. + + -- Verify that the Done_Printing entry call has not been completed. + -- + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + else + + -- Simulate an application which needs access to the printer within + -- a specified time, and which aborts the current printer job if time + -- runs out. + + select + Printer(1).Done_Printing; -- Wait for printer to come free. + or + delay Long_Enough; -- Print job took too long. + abort Print_Request; -- Abort print job. + end select; + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- Print_Request abort to complete. + + -- Verify (A): that Print_Request has been aborted. + -- Note: the test will hang if the task as not been aborted + -- + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Verify (B): that the Done_Printing entry call was canceled, and + -- the corresponding entry body was not executed. + -- + -- Set the barrier of the entry to true, then check that the entry + -- body is not executed. If the entry call is NOT canceled, the + -- entry body will execute when the barrier is set true. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + if Printer(1).Is_Done then + Report.Failed ("Entry call was not canceled"); + end if; + + + end if; + + + Report.Result; + +end C954A02; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a03.a b/gcc/testsuite/ada/acats/tests/c9/c954a03.a new file mode 100644 index 000000000..13d21311c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a03.a @@ -0,0 +1,322 @@ +-- C954A03.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 requeue statement in an accept_statement with +-- parameters may requeue the entry call to a protected entry with no +-- parameters. Check that, if the call is queued on the new entry's +-- queue, the original caller remains blocked after the requeue, but +-- the accept_statement containing the requeue is completed. +-- +-- Note that this test uses a requeue "with abort," although it does not +-- check that such a requeued caller can be aborted; that feature is +-- tested elsewhere. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Verify that, following the requeue, +-- the requesting task remains blocked. Call the second entry of the +-- printer server task (the acceptance of this entry call verifies that +-- the requeue statement completed the entry call by the requesting task. +-- Call the second protected procedure of the protected type (the +-- interrupt handler) and verify that the protected entry completes for +-- the requesting task (which verifies that the requeue statement queued +-- the first task object to the protected entry). +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate. +-- +--! + +package C954A03_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A03_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954a00); + +package body C954A03_0 is -- Printer server abstraction. + + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other tasks to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A03_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A03_0; -- Printer server abstraction. + +use C954A03_0; +use F954A00; + +procedure C954A03 is + + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + + --==============================================-- + + Task_Completed : Boolean := False; -- Testing flag. + + protected Interlock is -- Artifice for test purposes. + entry Wait; -- Wait for lock to be released. + procedure Release; -- Release the lock. + private + Locked : Boolean := True; + end Interlock; + + + protected body Interlock is + + entry Wait when not Locked is -- Calls are queued until after + -- -- Release is called. + begin + Task_Completed := True; + end Wait; + + procedure Release is -- Called by Print_Request. + begin + Locked := False; + end Release; + + end Interlock; + + --==============================================-- + + task Print_Request is -- Send a print request. + end Print_Request; + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Interlock.Release; -- Allow main to continue. + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A03", "Requeue from an Accept with parameters" & + " to a Protected Entry without parameters"); + + -- To pass this test, the following must be true: + -- + -- (A) The Print entry call made by the task Print_Request must be + -- completed by the requeue statement. + -- (B) Print_Request must remain blocked following the requeue. + -- (C) Print_Request must be queued on the Done_Printing queue of + -- Printer(1). + -- (D) Print_Request must continue execution after Done_Printing is + -- complete. + -- + -- First, verify (A): that the Print entry call is complete. + -- + -- Call the entry Verify_Results. If the requeue statement completed the + -- entry call to Print, the entry call to Verify_Results should be + -- accepted. Since the main will hang if this is NOT the case, make this + -- a timed entry call. + + select + Printer_Server.Verify_Results; -- Accepted if requeue completed + -- entry call to Print. + or + delay Long_Enough; -- Time out otherwise. + Report.Failed ("Requeue did not complete entry call"); + end select; + + -- Now verify (B): that Print_Request remains blocked following the + -- requeue. Also verify that Done_Printing (the entry to which + -- Print_Request should have been queued) has not yet executed. + + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif Print_Request'Terminated then + Report.Failed ("Caller did not remain blocked after the requeue"); + else + + -- Verify (C): that Print_Request is queued on the + -- Done_Printing queue of Printer(1). + -- + -- Set the barrier for Printer(1).Done_Printing to true. Check + -- that the Done flag is updated and that Print_Request terminates. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + + -- The Done_Printing entry body will complete before the next + -- protected action is called (Printer(1).Is_Done). + + if not Printer(1).Is_Done then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Print_Request continues after Done_Printing + -- completes. + -- + -- After Done_Printing completes, there is a potential race condition + -- between the main program and Print_Request. The protected object + -- Interlock is provided to ensure that the check of whether + -- Print_Request continued is made *after* it has had a chance to do so. + -- The main program waits until the statement in Print_Request following + -- the requeue-causing statement has executed, then checks to see + -- whether Print_Request did in fact continue executing. + -- + -- Note that the test will hang here if Print_Request does not continue + -- executing following the completion of the requeued entry call. + + Interlock.Wait; -- Wait until Print_Request is + -- done. + if not Task_Completed then + Report.Failed ("Caller remained blocked after target " & + "entry released"); + end if; + + -- Wait for Print_Request to finish before calling Report.Result. + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + end if; + + Report.Result; + +end C954A03; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960001.a b/gcc/testsuite/ada/acats/tests/c9/c960001.a new file mode 100644 index 000000000..4eaa1f49f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960001.a @@ -0,0 +1,164 @@ +-- C960001.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: +-- Confirm that a simple Delay Until statement is performed. Check +-- that the delay does not complete before the requested time and that it +-- does complete thereafter +-- +-- TEST DESCRIPTION: +-- Simulate a task that sends a "pulse" at regular intervals. The Delay +-- Until statement is used to avoid accumulated drift. For the +-- test, we expect the delay to return very close to the requested time; +-- we use an additional Pulse_Time_Delta for the limit. The test +-- driver (main) artificially limits the number of iterations by setting +-- the Stop_Pulse Boolean after a small number. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Fixed global variable problem for ACVC 2.0.1 +-- +--! + +with Report; +with Ada.Calendar; +with ImpDef; + +procedure C960001 is + +begin + + Report.Test ("C960001", "Simple Delay Until"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "<" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar."<"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + TC_Loop_Count : integer range 0..4 := 0; + + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization; Control.Stop + -- becoming true terminates the task. + -- + task body Pulse_Task is + + Pulse_Time : Ada.Calendar.Time; + + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + TC_Last_Time : Ada.Calendar.Time; + TC_Current : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + TC_Last_Time := Pulse_Time; + + while not Control.Stop loop + delay until Pulse_Time; + Pulse; + + -- Calculate time for next pulse. Note: this is based on the + -- last pulse time, not the time we returned from the delay + -- + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- Test Control: + TC_Current := Ada.Calendar.Clock; + if TC_Current < TC_Last_Time then + Report.Failed ("Delay expired before requested time"); + end if; + if TC_Current > Pulse_Time then + Report.Failed ("Delay too long"); + end if; + TC_Last_Time := Pulse_Time; + TC_Loop_Count := TC_Loop_Count +1; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + -- Artificially limit the number of iterations + while TC_Loop_Count < 3 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + Control.Stop_Now; -- End test + + end; -- declare + + Report.Result; + +end C960001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960002.a b/gcc/testsuite/ada/acats/tests/c9/c960002.a new file mode 100644 index 000000000..06edaf0c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960002.a @@ -0,0 +1,171 @@ +-- C960002.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 the simple "delay until" when the request time is "now" and +-- also some time already in the past is obeyed and returns immediately +-- +-- TEST DESCRIPTION: +-- Simulate a task that sends a "pulse" at regular intervals. The Delay +-- Until statement is used to avoid accumulated drift. In this test +-- three simple situations simulating the start of drift are used: the +-- next pulse being called for at the normal time, the next pulse being +-- called for at exactly the current time and then at some time which has +-- already past. We assume the delay is within a While Loop and, to +-- simplify the test, we "unfold" the While Loop and execute the Delays +-- in a serial fashion. This loop is shown in test C960001. +-- It is not possible to test the actual immediacy of the expiration. We +-- can only check that it returns in a "reasonable" time. In this case +-- we check that it expires before the next "pulse" should have been +-- issued. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +with Ada.Calendar; +with System; + +procedure C960002 is + +begin + + Report.Test ("C960002", "Simple Delay Until with requested time being" & + " ""now"" and time already in the past"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "-" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "-" (Left, Right : Ada.Calendar.Time) + return duration renames Ada.Calendar."-"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization. + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + Pulse_Time_Delta : constant duration := ImpDef.Clear_Ready_Queue; + + + + TC_Time_Back : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + + -- TC: unfold the "while" loop in C960001. Four passes through + -- the loop are shown + + delay until Pulse_Time; + + Pulse; + --------------- + -- TC: the normal calculation for "next" would be + -- Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Instead of this normal pulse time calculation simulate + -- the new pulse time to be exactly "now" (or, as exactly as + -- we can) + Pulse_Time := Ada.Calendar.Clock; + delay until Ada.Calendar.Clock; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - A"); + end if; + Pulse; + --------------- + -- normal calculation for "next" would be + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- TC: Instead of this, simulate the new calculated pulse time + -- being already past + Pulse_Time := Ada.Calendar.Clock - System.Tick; + delay until Pulse_Time; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - B"); + end if; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Now simulate getting back into synch + delay until Pulse_Time; + Pulse; + --------------- + -- This would be the end of the "while" loop + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + end; -- declare + + Report.Result; + +end C960002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960004.a b/gcc/testsuite/ada/acats/tests/c9/c960004.a new file mode 100644 index 000000000..f394aab66 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960004.a @@ -0,0 +1,206 @@ +-- C960004.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: +-- With the triggering statement being a delay and with the Asynchronous +-- Select statement being in a tasking situation complete the abortable +-- part before the delay expires. Check that the delay is cancelled +-- and that the optional statements in the triggering part are not +-- executed. +-- +-- TEST DESCRIPTION: +-- Simulate the creation of a carrier task to control the output of +-- a message via a line driver. If the message sending process is +-- not complete (the completion of the rendezvous) within a +-- specified time the carrier task is designed to take corrective action. +-- Use an asynchronous select to control the timing; arrange that +-- the abortable part (the rendezvous) completes almost immediately. +-- Check that the optional statements are not executed and that the +-- test completes well before the time of the trigger delay request thus +-- showing that it has been cancelled. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with Ada.Calendar; + +procedure C960004 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + -- Note: a properly executing test will complete immediately. + Allowable_ACK_Time : duration := 600.0; + +begin + + Report.Test ("C960004", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed. Tasking situation"); + + declare -- To get the Report.Result after all has completed + + type Sequence_Number is range 1..1_999_999; -- Message Number + subtype S_length_subtype is integer range 1..80; + + type Message_Type (Max_String : S_length_subtype := 1) is + record + Message_Number : Sequence_Number; + Alpha : string(1..Max_String); + end record; + + -- TC: Dummy message for the test + Dummy_Alpha : constant string := "This could be printed"; + Message_to_Send : Message_Type (Max_string => Dummy_Alpha'length); + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task type Require_ACK_task is + entry Message_In (Message_to_Send: Message_Type); + end Require_ACK_task; + type acc_Require_ACK_task is access Require_ACK_task; + + + --::::::::::::::::::::::::::::::::: + -- There would also be another task type "No_ACK_Task" which would + -- be the carrier task for those messages not requiring an ACK. + -- This task would call Send_Message.ACK_Not_Required. It is not + -- shown in this test as it is not used. + --::::::::::::::::::::::::::::::::: + + + + task Send_Message is + entry ACK_Required (Message_to_Send: Message_Type); + entry ACK_Not_Required (Message_to_Send: Message_Type); + end Send_Message; + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task body Require_ACK_task is + Hold_Message : Message_Type; + + procedure Time_Out (Failed_Message_Number : Sequence_Number) is + begin + -- Take remedial action on the timed-out message + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Time_out; + + begin + accept Message_In (Message_to_Send: Message_Type) do + Hold_Message := Message_to_Send; -- to release caller + end Message_In; + + -- Now put the message out to the Send_Message task and + -- wait (no more than Allowable_Ack_Time) for its completion + -- + select + delay Allowable_ACK_Time; + -- ACK not received in specified time + Time_out (Hold_Message.Message_Number); + then abort + -- If the rendezvous is not completed in the above time, this + -- call is cancelled + -- Note: for this test this call will complete immediately + -- and thus the trigger should be cancelled + Send_Message.ACK_Required (Hold_Message); + end select; + + exception + when others => + Report.Failed ("Unexpected exception in Require_ACK_task"); + end Require_ACK_task; + + + -- This is the Line Driver task + -- + task body Send_Message is + Hold_Non_ACK_Message : Message_Type; + begin + loop + select + accept ACK_Required (Message_to_Send: Message_Type) do + -- Here send the message from within the rendezvous + -- waiting for full transmission to complete + null; -- stub + -- Note: In this test this accept will complete immediately + end ACK_Required; + or + accept ACK_Not_Required (Message_to_Send: Message_Type) do + Hold_Non_ACK_Message := Message_to_Send; + end ACK_Not_Required; + -- Here send the message from outside the rendezvous + null; -- stub + or + terminate; + end select; + end loop; + exception + when others => Report.Failed ("Unexpected exception in Send_Message"); + end Send_Message; + + begin -- declare + -- Build a dummy message + Message_to_Send.Alpha := Dummy_Alpha; + Message_to_Send.Message_Number := 110_693; + + declare + New_Require_ACK_task : acc_Require_ACK_task := + new Require_ACK_task; + begin + -- Create a carrier task for this message and pass the latter in + New_Require_ACK_task.Message_In (Message_to_Send); + end; -- declare + + end; -- declare + + --Once we are out of the above declarative region, all tasks have completed + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Check that the test has completed well before the time of the requested + -- delay to ensure the delay was cancelled + -- + if (TC_Elapsed_Time > Allowable_ACK_Time/2) then + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + Report.Result; +end C960004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96001a.ada b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada new file mode 100644 index 000000000..f958ea107 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada @@ -0,0 +1,163 @@ +-- C96001A.ADA + +-- 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 DELAY STATEMENT DELAYS EXECUTION FOR AT LEAST THE +-- SPECIFIED TIME. SPECIFICALLY, +-- (A) POSITIVE DELAY ARGUMENT. +-- (B) NEGATIVE DELAY ARGUMENT. +-- (C) ZERO DELAY ARGUMENT. +-- (D) DURATION'SMALL DELAY ARGUMENT. +-- (E) EXPRESSION OF TYPE DURATION AS DELAY ARGUMENT. + +-- HISTORY: +-- CPP 8/14/84 CREATED ORIGINAL TEST. +-- RJW 11/13/87 ADDED CODE WHICH ALLOWS TEST TO REPORT "PASSED" +-- IF TICK > DURATION'SMALL. + +with Impdef; +WITH CALENDAR; USE CALENDAR; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C96001A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 20_000; + +BEGIN + TEST ("C96001A", "CHECK THAT DELAY STATEMENT DELAYS " & + "EXECUTION FOR AT LEAST THE SPECIFIED TIME"); + + --------------------------------------------- + + DECLARE -- (A) + X : DURATION := 5.0 * Impdef.One_Second; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (A) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST 5.0 " & + "SECONDS - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; + + --------------------------------------------- + + DECLARE -- (B) + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (B) + LOOP + OLD_TIME := CLOCK; + DELAY -5.0; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(B) - NEGATIVE DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; + + --------------------------------------------- + + DECLARE -- (C) + X : DURATION := 0.0; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (C) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(C) - ZERO DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; + + --------------------------------------------- + + DECLARE -- (D) + X : DURATION := DURATION'SMALL; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (D) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + IF TICK < DURATION'SMALL THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "DURATION'SMALL SECONDS - (D)"); + ELSE + COMMENT ("TICK > DURATION'SMALL SO DELAY IN " & + "'(D)' IS NOT MEASURABLE"); + END IF; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; + + --------------------------------------------- + + DECLARE -- (E) + INC1 : DURATION := 2.0 * Impdef.One_Second; + INC2 : DURATION := 3.0 * Impdef.One_Second; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (E) + LOOP + OLD_TIME := CLOCK; + DELAY INC1 + INC2; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < (INC1 + INC2) THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "INC1 + INC2 SECONDS - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; + + RESULT; +END C96001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada new file mode 100644 index 000000000..f5357fc51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada @@ -0,0 +1,258 @@ +-- C96004A.ADA + +-- 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 THE PRE-DEFINED SUBTYPES FROM THE PACKAGE CALENDAR, +-- NAMELY YEAR_NUMBER, MONTH_NUMBER, DAY_NUMBER, AND DAY_DURATION, +-- HAVE THE CORRECT RANGE CONSTRAINTS. SUBTESTS ARE: +-- (A) YEAR_NUMBER. +-- (B) MONTH_NUMBER. +-- (C) DAY_NUMBER. +-- (D) DAY_DURATION. + +-- HISTORY: +-- CPP 08/15/84 CREATED ORIGINAL TEST. +-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT +-- OPTIMIZATION. + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96004A IS + +BEGIN + TEST("C96004A", "CHECK THAT PRE-DEFINED SUBTYPES FROM THE " & + "CALENDAR PACKAGE HAVE CORRECT RANGE CONSTRAINTS"); + + --------------------------------------------- + + DECLARE -- (A) + + YR : YEAR_NUMBER; + + BEGIN -- (A) + + BEGIN + YR := 1900; + FAILED ("EXCEPTION NOT RAISED - (A)1"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)1"); + END; + + BEGIN + YR := 84; + FAILED ("EXCEPTION NOT RAISED - (A)2"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)2"); + END; + + BEGIN + YR := 2099; + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 2099 - (A)"); + END; + + BEGIN + YR := IDENT_INT(YEAR_NUMBER'LAST + 1); + FAILED ("EXCEPTION NOT RAISED - (A)3"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)3"); + END; + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + MO : MONTH_NUMBER; + + BEGIN -- (B) + + BEGIN + MO := IDENT_INT(0); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + BEGIN + MO := 12; + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 12 - (B)"); + END; + + BEGIN + MO := 13; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + DY : DAY_NUMBER; + + BEGIN -- (C) + + BEGIN + DY := 0; + FAILED ("EXCEPTION NOT RAISED - (C)1"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)1"); + END; + + BEGIN + DY := IDENT_INT(32); + FAILED ("EXCEPTION NOT RAISED - (C)2"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)2"); + END; + + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SEGMENT : DAY_DURATION; + + FUNCTION CHECK_OK (X : DAY_DURATION) RETURN BOOLEAN IS + I : INTEGER := INTEGER (X); + BEGIN + RETURN EQUAL (I,I); + END CHECK_OK; + + BEGIN -- (D) + + BEGIN + SEGMENT := 86_400.0; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + COMMENT ("NO EXCEPTION RAISED (D1)"); + ELSE + COMMENT ("NO EXCEPTION RAISED (D2)"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 86_400 - (D)"); + END; + + BEGIN + SEGMENT := -4.0; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + IF NOT EQUAL (INTEGER(SEGMENT), INTEGER(SEGMENT)) THEN + COMMENT ("NO EXCEPTION RAISED (D3)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + BEGIN + SEGMENT := 86_401.00; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + FAILED ("NO EXCEPTION RAISED (D4)"); + ELSE + FAILED ("NO EXCEPTION RAISED (D5)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; +END C96004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005a.ada b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada new file mode 100644 index 000000000..ca6fc5b83 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada @@ -0,0 +1,239 @@ +-- C96005A.ADA + +-- 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. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (A) CHECK THAT ADDITION AND SUBTRACTION OPERATORS WORK CORRECTLY ON +-- VALUES OF TYPE TIME. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +-- WITH TEXT_IO; USE TEXT_IO; +PROCEDURE C96005A IS + + -- PACKAGE DURATION_IO IS NEW FIXED_IO (DURATION); + -- USE DURATION_IO; + +BEGIN + TEST ("C96005A", "CHECK THAT THE ADDITION AND SUBTRACTION " & + "FUNCTIONS FOR VALUES OF TYPE TIME WORK CORRECTLY"); + + ----------------------------------------------- + + BEGIN -- (A) + + -- ADDITION TESTS FOLLOW. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW + INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)1"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := INCREMENT + NOW; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)2"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(INCREMENT, NOW); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)3"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)4"); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 45_000.0); + ONCE := TIME_OF (1984, 8, 12, 45_000.0); + DIFFERENCE := NOW - ONCE; + IF DIFFERENCE /= 86_400.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)1"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT MONTHS. + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, IDENT_INT(1), 60.0); + ONCE := TIME_OF (1984, 7, 31, 86_399.0); + DIFFERENCE := "-"(NOW, ONCE); + IF DIFFERENCE /= 61.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)2"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT YEARS. + NOW, AFTER : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (IDENT_INT(1999), 12, 31, 86_399.0); + AFTER := TIME_OF (2000, 1, 1, 1.0); + DIFFERENCE := "-"(LEFT => AFTER, + RIGHT => NOW); + IF DIFFERENCE /= 2.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)3"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A LEAP YEAR. + NOW, LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 3, 1); + LEAP := TIME_OF (1984, 2, 29, 86_399.0); + DIFFERENCE := NOW - LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)4"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A NON-LEAP YEAR. + NOW, NON_LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1983, 3, 1); + NON_LEAP := TIME_OF (1983, 2, 28, 86_399.0); + DIFFERENCE := NOW - NON_LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)5"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW: TIME - DURATION. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 12, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)6"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)8"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(NOW, INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + END; -- (A) + + ----------------------------------------------- + + RESULT; +END C96005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005b.tst b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst new file mode 100644 index 000000000..f4665b136 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst @@ -0,0 +1,135 @@ +-- C96005B.TST + +-- 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. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (B) ADDITION AND SUBTRACTION OPERATORS RAISE CONSTRAINT_ERROR WHEN +-- CALLED WITH AN OUT OF RANGE DURATION PARAMETER. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96005B IS + +BEGIN + TEST ("C96005B", "CHECK THAT ADDITION AND SUBTRACTION " & + "OPERATORS RAISE CONSTRAINT_ERROR WHEN CALLED WITH " & + "OUT OF RANGE DURATION PARAMETER"); + + ----------------------------------------------- + + BEGIN -- (B) + + -- ADDITION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)1"); + BEFORE := BEFORE + ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)1"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)2"); + BEFORE := $GREATER_THAN_DURATION + BEFORE; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)3"); + BEFORE := BEFORE - ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)3"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)3"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)4"); + BEFORE := BEFORE - $GREATER_THAN_DURATION; + FAILED ("EXCEPTION NOT RAISED - (B)4"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)4"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)4"); + END; + + + END; -- (B) + + ----------------------------------------------- + + RESULT; +END C96005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005d.ada b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada new file mode 100644 index 000000000..8caba3e36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada @@ -0,0 +1,81 @@ +-- C96005D.ADA + +-- 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. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (D) THE EXCEPTION TIME_ERROR IS RAISED WHEN THE FUNCTION "-" +-- RETURNS A VALUE NOT IN THE SUBTYPE RANGE DURATION. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96005D IS + +BEGIN + TEST ("C96005D", "CHECK THAT THE SUBTRACTION OPERATOR RAISES " & + "TIME_ERROR APPROPRIATELY"); + + --------------------------------------------- + + BEGIN -- (D) + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'LAST) + 1.0; + WAIT := LATER - NOW; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'FIRST) - 1.0; + WAIT := NOW - LATER; + FAILED ("EXCEPTION NOT RAISED - (D)2"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; +END C96005D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005f.ada b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada new file mode 100644 index 000000000..89e3d574b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada @@ -0,0 +1,93 @@ +-- C96005F.ADA + +-- 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. +--* +-- CHECK THAT PACKAGE CALENDAR + AND - FUNCTIONS WORK PROPERLY, +-- ESPECIALLY WITH VALUES AT MIDNIGHT. + +-- GOM 02/18/85 +-- JWC 05/14/85 + +WITH REPORT; +USE REPORT; +WITH CALENDAR; +USE CALENDAR; + +PROCEDURE C96005F IS + + CURR_DAY1 : CONSTANT TIME := TIME_OF(1984,1,1,0.0); + CURR_DAY2 : CONSTANT TIME := TIME_OF(1984,1,1,DAY_DURATION'LAST); + CURR_DAY3 : CONSTANT TIME := TIME_OF(1984,1,1,10000.0); + + TOMORROW1 : CONSTANT TIME := TIME_OF(1984,1,2,0.0); + TOMORROW2 : CONSTANT TIME := TIME_OF(1984,1,2,DAY_DURATION'LAST); + TOMORROW3 : CONSTANT TIME := TIME_OF(1984,1,2,10000.0); + + YESTERDAY1 : CONSTANT TIME := TIME_OF(1983,12,31,0.0); + YESTERDAY2 : CONSTANT TIME := TIME_OF(1983,12,31, + DAY_DURATION'LAST); + YESTERDAY3 : CONSTANT TIME := TIME_OF(1983,12,31,10000.0); + +BEGIN + TEST("C96005F","CHECKING PACKAGE CALENDAR + AND - FUNCTIONS"); + + -- CHECK IF ADDING ONE DAY TO 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'TOMORROW'. + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= TOMORROW1 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 + DAY_DURATION'LAST) /= TOMORROW2 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 + DAY_DURATION'LAST) /= TOMORROW3 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= CURR_DAY2 THEN + FAILED("'CURR_DAY1' + 1 /= 'CURR_DAY2'"); + END IF; + + -- CHECK IF SUBTRACTING ONE DAY FROM 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'YESTERDAY'. + + IF (CURR_DAY1 - DAY_DURATION'LAST) /= YESTERDAY1 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= YESTERDAY2 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 - DAY_DURATION'LAST) /= YESTERDAY3 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= CURR_DAY1 THEN + FAILED("'CURR_DAY2' - 1 /= 'CURR_DAY1'"); + END IF; + + RESULT; +END C96005F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96006a.ada b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada new file mode 100644 index 000000000..0f6448bd2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada @@ -0,0 +1,298 @@ +-- C96006A.ADA + +-- 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. +--* +-- CHECK THAT FOR THE PACKAGE CALENDAR, THE RELATIONAL OPERATORS WORK +-- CORRECTLY FOR OPERANDS OF TYPE TIME AND TYPE DURATION. PARTICULARLY, +-- (A) RELATIONS BASED ON YEARS. +-- (B) RELATIONS BASED ON MONTH. +-- (C) RELATIONS BASED ON SECONDS. +-- (D) RELATIONS AT EXTREMES OF THE PERMITTED RANGE OF TIME. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96006A IS + +BEGIN + TEST ("C96006A", "CHECK THAT RELATIONAL OPERATORS WORK " & + "CORRECTLY IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + -- RELATIONS BASED ON YEARS. + NOW, LATER : TIME; + BEGIN -- (A) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1985, 8, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (A)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (A)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (A)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (A)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (A)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (A)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)2"); + END IF; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + -- RELATIONS BASED ON MONTH. + NOW, LATER : TIME; + BEGIN -- (B) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1984, 9, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (B)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (B)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (B)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (B)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (B)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (B)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)2"); + END IF; + + IF NOW = NOW THEN + COMMENT ("= OPERATOR OK - (B)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER /= NOW THEN + COMMENT ("/= OPERATOR OK - (B)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------- + + DECLARE -- (C) + -- RELATIONS BASED ON SECONDS. + NOW, LATER : TIME; + INCREMENT : DURATION := 99.9; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := NOW + INCREMENT; + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (C)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (C)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (C)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (C)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (C)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (C)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER = LATER THEN + COMMENT ("= OPERATOR OK - (C)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW /= LATER THEN + COMMENT ("/= OPERATOR OK - (C)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW < NOW THEN + FAILED ("NOW < NOW INCORRECT - (C)"); + ELSIF NOW /= NOW THEN + FAILED ("NOW = NOW INCORRECT - (C)"); + ELSIF LATER < NOW THEN + FAILED ("LATER < NOW INCORRECT - (C)"); + ELSIF LATER <= NOW THEN + FAILED ("LATER <= NOW INCORRECT - (C)"); + ELSIF LATER = NOW THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + ELSIF NOW > LATER THEN + FAILED ("NOW > LATER INCORRECT - (C)"); + ELSIF NOW > NOW THEN + FAILED ("NOW > NOW INCORRECT - (C)"); + ELSIF NOW >= LATER THEN + FAILED ("NOW >= LATER INCORRECT - (C)"); + ELSIF NOW = LATER THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------- + + DECLARE -- (D) + + NOW, WAY_BACK_THEN : TIME; + + BEGIN -- (D) + + NOW := TIME_OF (2099, 12, 31); + WAY_BACK_THEN := TIME_OF (1901, 1, 1); + + BEGIN + IF NOW < WAY_BACK_THEN THEN + FAILED ("TEST < AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("< AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW <= WAY_BACK_THEN THEN + FAILED ("TEST <= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("<= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN > NOW THEN + FAILED ("TEST > AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("> AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN >= NOW THEN + FAILED ("TEST >= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED (">= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN /= WAY_BACK_THEN THEN + FAILED ("TEST /= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("/= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW = WAY_BACK_THEN THEN + FAILED ("TEST = AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + END; -- (D) + + -------------------------------------------- + + RESULT; +END C96006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada new file mode 100644 index 000000000..beda25fd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada @@ -0,0 +1,203 @@ +-- C96007A.ADA + +-- 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. +--* +-- CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED FOR THE TIME_OF() +-- FUNCTION IN THE PACKAGE CALENDAR. PARTICULARLY, +-- (A) TIME_ERROR IS RAISED ON INVALID DATES. +-- (B) CONSTRAINT_ERROR IS RAISED FOR OUT-OF-RANGE PARAMETERS. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96007A IS + +BEGIN + TEST ("C96007A", "CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED " & + "FOR THE TIME_OF FUNCTION IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + + BAD_TIME : TIME; + + BEGIN -- (A) + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 30); + FAILED ("EXCEPTION NOT RAISED - 2/30 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/30 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 31); + FAILED ("EXCEPTION NOT RAISED - 2/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 4, 31); + FAILED ("EXCEPTION NOT RAISED - 4/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 6, 31); + FAILED ("EXCEPTION NOT RAISED - 6/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 9, 31); + FAILED ("EXCEPTION NOT RAISED - 9/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 9/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 11, 31); + FAILED ("EXCEPTION NOT RAISED - 11/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 11/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1983, 2, 29); + FAILED ("EXCEPTION NOT RAISED - 2/29 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/29 (A)"); + END; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + + BAD_TIME : TIME; + + BEGIN -- (B) + + BEGIN + BAD_TIME := TIME_OF (1900, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 1900 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1900 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (YEAR_NUMBER'LAST + 1, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 2100 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2100 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 0, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 13, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 0); + FAILED ("EXCEPTION NOT RAISED - DAY (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (19784, 8, 32); + FAILED ("EXCEPTION NOT RAISED - DAY (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 13, -0.5); + FAILED ("EXCEPTION NOT RAISED - SECONDS (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - SECONDS (B)1"); + END; + + END; -- (B) + + -------------------------------------------- + + RESULT; +END C96007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008a.ada b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada new file mode 100644 index 000000000..33b59d8c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada @@ -0,0 +1,203 @@ +-- C96008A.ADA + +-- 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. +--* +-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE +-- CALENDAR. SUBTESTS ARE: +-- (A) TIME_OF() AND SPLIT() ARE INVERSE FUNCTIONS. +-- (B) FORMAL PARAMETERS OF TIME_OF() AND SPLIT() ARE NAMED CORRECTLY. +-- (C) TIME_OF() GIVES THE PARAMETER SECONDS A DEFAULT VALUE OF 0.0. +-- (D) THE FUNCTIONS YEAR(), MONTH(), DAY(), AND SECONDS() RETURN +-- CORRECT VALUES USING NAMED NOTATION. +-- (E) A VALUE RETURNED FROM CLOCK() CAN BE PROCESSED BY SPLIT(). +-- (F) DURATION'SMALL MEETS REQUIRED LIMIT. + +-- CPP 8/16/84 + +WITH SYSTEM; +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96008A IS + +BEGIN + TEST ("C96008A", "CHECK MISCELLANEOUS FUNCTIONS IN THE " & + "PACKAGE CALENDAR"); + + --------------------------------------------- + + DECLARE -- (A) + NOW : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (A) + BEGIN + NOW := TIME_OF (1984, 8, 13, DURATION(1.0/3.0)); + SPLIT (NOW, YR, MO, DY, SEC); + IF NOW /= TIME_OF (YR, MO, DY, SEC) THEN + COMMENT ("TIME_OF AND SPLIT ARE NOT INVERSES " & + "WHEN SECONDS IS A NON-MODEL NUMBER " & + "- (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("TIME_OF(SPLIT) RAISED EXCEPTION - (A)"); + END; + + + BEGIN + -- RESET VALUES. + YR := 1984; + MO := 8; + DY := 13; + SEC := 1.0; + + SPLIT (TIME_OF (YR, MO, DY, SEC), YR, MO, DY, SEC); + + IF YR /= 1984 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF YR - (A)"); + END IF; + + IF MO /= 8 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF MO - (A)"); + END IF; + + IF DY /= 13 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF DY - (A)"); + END IF; + + IF SEC /= 1.0 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF " & + "SEC - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT(TIME_OF) PROCESSING RAISED " & + "EXCEPTION - (A)"); + END; + END; -- (A) + + --------------------------------------------- + + BEGIN -- (B) + DECLARE + NOW : TIME; + BEGIN + NOW := TIME_OF (YEAR => 1984, + MONTH => 8, + DAY => 13, + SECONDS => 60.0); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON TIME_OF() RAISED " & + "EXCEPTION - (B)"); + END; + + + DECLARE + NOW : TIME := CLOCK; + YR : YEAR_NUMBER := 1984; + MO : MONTH_NUMBER := 8; + DY : DAY_NUMBER := 13; + SEC : DAY_DURATION := 0.0; + BEGIN + SPLIT (DATE => NOW, + YEAR => YR, + MONTH => MO, + DAY => DY, + SECONDS => SEC); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON SPLIT() RAISED " & + "EXCEPTION - (B)2"); + END; + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + NOW : TIME; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 13); + IF SECONDS (NOW) /= 0.0 THEN + FAILED ("TIME_OF() DID NOT ZERO SECONDS - (C)"); + END IF; + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + -- ASSUMES TIME_OF() WORKS CORRECTLY. + HOLIDAY : TIME; + BEGIN -- (D) + HOLIDAY := TIME_OF (1958, 9, 9, 1.0); + + IF YEAR (DATE => HOLIDAY) /= 1958 THEN + FAILED ("YEAR() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF MONTH (DATE => HOLIDAY) /= 9 THEN + FAILED ("MONTH() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF DAY (DATE => HOLIDAY) /= 9 THEN + FAILED ("DAY() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF SECONDS (HOLIDAY) /= 1.0 THEN + FAILED ("SECONDS() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (E) + SPLIT (CLOCK, YR, MO, DY, SEC); + DELAY SYSTEM.TICK; + + IF TIME_OF (YR, MO, DY, SEC) > CLOCK THEN + FAILED ("SPLIT() ON CLOCK INCORRECT - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT() ON CLOCK RAISED EXCEPTION - (E)"); + END; -- (E) + + --------------------------------------------- + + BEGIN -- (F) + IF DURATION'SMALL > 0.020 THEN + FAILED ("DURATION'SMALL LARGER THAN SPECIFIED - (F)"); + END IF; + END; -- (F) + + --------------------------------------------- + + RESULT; +END C96008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008b.ada b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada new file mode 100644 index 000000000..7a23bcfb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada @@ -0,0 +1,71 @@ +-- C96008B.ADA + +-- 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. +--* +-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE +-- CALENDAR. SUBTESTS ARE: +-- (A) THE FUNCTION TIME_OF() MUST ADVANCE DAY WHEN CALLED WITH THE +-- SECONDS ARGUMENT HAVING THE VALUE 86_400. + +-- CPP 8/16/84 +-- JRK 12/4/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96008B IS + + NOW1, NOW2 : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + +BEGIN + + TEST ("C96008B", "CHECK THAT TIME_OF() ADVANCES DAY"); + + NOW1 := TIME_OF (1984, 8, 13, 86_400.0); + NOW2 := TIME_OF (1984, 8, 14, 0.0); + + IF NOW1 /= NOW2 THEN + FAILED ("TIME_OF DID NOT CONVERT 86_400 SECONDS TO A DAY"); + END IF; + + SPLIT (NOW2, YR, MO, DY, SEC); + + IF DY /= 14 THEN + FAILED ("DAY OF NOW2 INCORRECT"); + END IF; + IF SEC /= 0.0 THEN + FAILED ("SECONDS OF NOW2 INCORRECT"); + END IF; + + SPLIT (NOW1, YR, MO, DY, SEC); + + IF DY /= 14 OR SEC /= 0.0 OR + DAY (NOW1) /= 14 OR SECONDS (NOW1) /= 0.0 THEN + FAILED ("TIME_OF DID NOT ADVANCE DAY"); + END IF; + + RESULT; +END C96008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97112a.ada b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada new file mode 100644 index 000000000..ef7dca2d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada @@ -0,0 +1,134 @@ +-- C97112A.ADA + +-- 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. +--* +-- CHECK THAT A DELAY STATEMENT IS ALLOWED IN THE SEQUENCE OF STATEMENTS +-- OF A SELECT ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A TERMINATE +-- ALTERNATIVE OR AN ELSE PART. + +-- WRG 7/9/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97112A IS + + ACCEPT_ALTERNATIVE_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97112A", "CHECK THAT A DELAY STATEMENT IS ALLOWED IN " & + "THE SEQUENCE OF STATEMENTS OF A SELECT " & + "ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A " & + "TERMINATE ALTERNATIVE OR AN ELSE PART"); + + -------------------------------------------------- + + A: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + SELECT + ACCEPT E; + ACCEPT_ALTERNATIVE_TAKEN := TRUE; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (A)"); + END IF; + OR + TERMINATE; + END SELECT; + END T; + + BEGIN + + T.E; + + END A; + + IF NOT ACCEPT_ALTERNATIVE_TAKEN THEN + FAILED ("ACCEPT ALTERNATIVE NOT TAKEN"); + END IF; + + -------------------------------------------------- + + B: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-1)"); + END IF; + ELSE + FAILED ("ELSE PART EXECUTED (B-1)"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPT STATEMENT EXECUTED (B-2)"); + ELSE + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-2)"); + END IF; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.E; + + END B; + + -------------------------------------------------- + + RESULT; + +END C97112A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97113a.ada b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada new file mode 100644 index 000000000..f05d4380c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada @@ -0,0 +1,113 @@ +-- C97113A.ADA + +-- 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. +--* +-- CHECK THAT ALL CONDITIONS, OPEN DELAY ALTERNATIVE EXPRESSIONS, AND +-- OPEN ENTRY FAMILY INDICES ARE EVALUATED (EVEN WHEN SOME (PERHAPS +-- ALL BUT ONE) OF THE ALTERNATIVES CAN BE RULED OUT WITHOUT +-- COMPLETING THE EVALUATIONS). + +-- RM 5/06/82 +-- SPS 11/21/82 +-- WRG 7/9/86 ADDED DELAY EXPRESSIONS AND ENTRY FAMILY INDICES. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97113A IS + + EXPR1_EVALUATED : BOOLEAN := FALSE; + EXPR2_EVALUATED : BOOLEAN := FALSE; + EXPR3_EVALUATED : BOOLEAN := FALSE; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + EXPR1_EVALUATED := TRUE; + RETURN TRUE; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN INTEGER IS + BEGIN + EXPR2_EVALUATED := TRUE; + RETURN X; + END F2; + + FUNCTION F3 (X : DURATION) RETURN DURATION IS + BEGIN + EXPR3_EVALUATED := TRUE; + RETURN X; + END F3; + +BEGIN + + TEST ("C97113A", "CHECK THAT ALL CONDITIONS, OPEN DELAY " & + "ALTERNATIVE EXPRESSIONS, AND OPEN ENTRY " & + "FAMILY INDICES ARE EVALUATED"); + + DECLARE + + TASK T IS + ENTRY E1; + ENTRY E2; + ENTRY E3 (1..1); + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E1 HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E1'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E1; + OR + WHEN F1 => + ACCEPT E2; + OR + ACCEPT E3 ( F2(1) ); + OR + DELAY F3 ( 1.0 ) * Impdef.One_Second; + END SELECT; + END T; + + BEGIN + + T.E1; + + END; + + IF NOT EXPR1_EVALUATED THEN + FAILED ("GUARD NOT EVALUATED"); + END IF; + + IF NOT EXPR2_EVALUATED THEN + FAILED ("ENTRY FAMILY INDEX NOT EVALUATED"); + END IF; + + IF NOT EXPR3_EVALUATED THEN + FAILED ("OPEN DELAY ALTERNATIVE EXPRESSION NOT EVALUATED"); + END IF; + + RESULT; + +END C97113A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97114a.ada b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada new file mode 100644 index 000000000..2a28fe8e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada @@ -0,0 +1,196 @@ +-- C97114A.ADA + +-- 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. +--* +-- CHECK WHETHER A DELAY EXPRESSION FOLLOWING AN OPEN GUARD IS EVALUATED +-- DIRECTLY AFTER THE GUARD OR ONLY AFTER ALL GUARDS HAVE BEEN +-- EVALUATED, OR IN SOME MIXED ORDER SUCH THAT DELAY EXPRESSIONS ARE +-- EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE OPEN. + +-- RM 5/10/82 +-- SPS 11/21/82 +-- JBG 10/24/83 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97114A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + DUMMY : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION D1( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'D'; -- 123: DDD ( 'D' FOR 'DELAY' ) + RETURN ( 1.0 ); + END D1; + + + FUNCTION D2( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 2.0 ); + END D2; + + + FUNCTION D3( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 3.0 ); + END D3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + +BEGIN + + + TEST ("C97114A", "CHECK THAT THE DELAY EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + DELAY D1( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F2(7) = 13 => + DELAY D2( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F3(7) = 13 => + DELAY D3( DUMMY ) * Impdef.One_Second; + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("EVALUATIONS WERE DONE IN THE ORDER " & EVAL_ORD); + COMMENT ("FUNCTIONS WERE CALLED IN THE ORDER " & EVAL_ORDER); + + IF EVAL_ORD = "GGGDDD" THEN + COMMENT ("ALL GUARDS EVALUATED FIRST"); + ELSIF EVAL_ORD = "GDGDGD" THEN + COMMENT ("DELAY EXPRESSION EVALUATED AFTER EACH GUARD"); + END IF; + +-- CHECK THAT GUARDS ARE ALWAYS EVALUATED BEFORE DELAY EXPRESSIONS + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("A DELAY EXPRESSION WAS EVALUATED BEFORE ITS " & + "GUARD"); + END IF; + + + RESULT; + + +END C97114A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97115a.ada b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada new file mode 100644 index 000000000..8e9845ea6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada @@ -0,0 +1,189 @@ +-- C97115A.ADA + +-- 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. +--* +-- CHECK WHETHER AN ENTRY FAMILY INDEX EXPRESSION FOLLOWING AN OPEN +-- GUARD IS EVALUATED DIRECTLY AFTER THE GUARD, OR ONLY AFTER ALL GUARDS +-- HAVE BEEN EVALUATED, OR IN SOME MIXED ORDER SUCH THAT INDEX +-- EXPRESSIONS ARE EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE +-- OPEN. + +-- RM 5/11/82 +-- SPS 11/21/82 +-- JBG 10/24/83 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97115A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION I1 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'I'; -- 123: III ( 'I' FOR 'INDEX' ) + RETURN ( IDENT_BOOL(TRUE) ); -- (THAT'S ENTRY-FAMILY INDEX) + END I1; + + + FUNCTION I2 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I2; + + + FUNCTION I3 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + + +BEGIN + + + TEST ("C97115A", "CHECK THAT THE INDEX EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E ( BOOLEAN ); + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + ACCEPT E ( I1(17) ); + + OR + + WHEN 6 + F2(7) = 13 => + ACCEPT E ( I2(17) ); + + OR + + WHEN 6 + F3(7) = 13 => + ACCEPT E ( I3(17) ); + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("GUARD AND INDEX FUNCTIONS WERE CALLED IN ORDER " & + EVAL_ORDER); + COMMENT ("GUARD AND INDEX EXPRESSIONS WERE EVALUATED IN THE " & + "ORDER " & EVAL_ORD); + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("AN INDEX EXPRESSION WAS EVALUATED TOO EARLY"); + END IF; + + RESULT; + +END C97115A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97116a.ada b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada new file mode 100644 index 000000000..737d2528e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada @@ -0,0 +1,102 @@ +-- C97116A.ADA + +-- 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 THE GUARD CONDITIONS IN A SELECTIVE WAIT STATEMENT +-- ARE NOT RE-EVALUATED DURING THE WAIT. + +-- HISTORY: +-- WRG 7/10/86 CREATED ORIGINAL TEST. +-- RJW 5/15/90 REMOVED SHARED VARIABLES. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97116A IS + + GUARD_EVALUATIONS : NATURAL := 0; + + FUNCTION GUARD RETURN BOOLEAN IS + BEGIN + GUARD_EVALUATIONS := GUARD_EVALUATIONS + 1; + RETURN FALSE; + END GUARD; + + FUNCTION SO_LONG RETURN DURATION IS + BEGIN + RETURN 20.0; + END SO_LONG; + +BEGIN + + TEST ("C97116A", "CHECK THAT THE GUARD CONDITIONS IN A " & + "SELECTIVE WAIT STATEMENT ARE NOT RE-EVALUATED " & + "DURING THE WAIT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT CALL TO E"); + OR WHEN GUARD => + DELAY 0.0; + FAILED ("EXECUTED ALTERNATIVE CLOSED BY FALSE " & + "GUARD FUNCTION" ); + OR + DELAY SO_LONG * Impdef.One_Second; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + TASK GET_CPU; + + TASK BODY GET_CPU IS + BEGIN + WHILE NOT T'TERMINATED LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + END GET_CPU; + + BEGIN + + NULL; + + END; + + IF GUARD_EVALUATIONS /= 1 THEN + FAILED ("GUARD EVALUATED" & + NATURAL'IMAGE(GUARD_EVALUATIONS) & " TIMES"); + END IF; + + RESULT; + +END C97116A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117a.ada b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada new file mode 100644 index 000000000..cf5e1b911 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada @@ -0,0 +1,72 @@ +-- C97117A.ADA + +-- 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. +--* +-- CHECK THAT PROGRAM_ERROR IS RAISED IF ALL ALTERNATIVES ARE CLOSED AND +-- NO ELSE PART IS PRESENT. + +-- WRG 7/10/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97117A IS + +BEGIN + + TEST ("C97117A", "CHECK THAT PROGRAM_ERROR IS RAISED IF ALL " & + "ALTERNATIVES ARE CLOSED AND NO ELSE PART IS " & + "PRESENT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (FALSE) => + DELAY 0.0; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + END SELECT; + FAILED ("PROGRAM_ERROR NOT RAISED"); + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END T; + + BEGIN + + NULL; + + END; + + RESULT; + +END C97117A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117b.ada b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada new file mode 100644 index 000000000..bc05ebf35 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada @@ -0,0 +1,88 @@ +-- C97117B.ADA + +-- 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. +--* +-- CHECK THAT AN ELSE PART IS EXECUTED IF ALL ALTERNATIVES ARE CLOSED OR +-- IF THERE ARE NO TASKS QUEUED FOR OPEN ALTERNATIVES. + +-- WRG 7/10/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97117B IS + +BEGIN + + TEST ("C97117B", "CHECK THAT AN ELSE PART IS EXECUTED IF ALL " & + "ALTERNATIVES ARE CLOSED OR IF THERE ARE NO " & + "TASKS QUEUED FOR OPEN ALTERNATIVES"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT NO_GO HAS BEEN CALLED BEFORE PROCEEDING: + WHILE NO_GO'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL - 1"); + OR + WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 1"); + ELSE + COMMENT ("ELSE PART EXECUTED - 1"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL - 2"); + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 2"); + ELSE + COMMENT ("ELSE PART EXECUTED - 2"); + END SELECT; + + ACCEPT NO_GO; + END T; + + BEGIN + + T.NO_GO; + + END; + + RESULT; + +END C97117B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117c.ada b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada new file mode 100644 index 000000000..cda428029 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada @@ -0,0 +1,74 @@ +-- C97117C.ADA + +-- 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. +--* +-- CHECK THAT AN ELSE PART IS NOT EXECUTED IF A TASK IS QUEUED AT AN +-- OPEN ALTERNATIVE. + +-- WRG 7/10/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97117C IS + +BEGIN + + TEST ("C97117C", "CHECK THAT AN ELSE PART IS NOT EXECUTED IF A " & + "TASK IS QUEUED AT AN OPEN ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + +END C97117C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97118a.ada b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada new file mode 100644 index 000000000..e1eceaf67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada @@ -0,0 +1,73 @@ +-- C97118A.ADA + +-- 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. +--* +-- CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF A SELECTIVE WAIT IS NOT +-- ACCEPTED. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97118A IS + +BEGIN + + TEST ("C97118A", "CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF " & + "A SELECTIVE WAIT IS NOT ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("ACCEPTED CALL TO CLOSED ALTERNATIVE"); + ELSE + NULL; + END SELECT; + + IF E'COUNT = 1 THEN + ACCEPT E; + END IF; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + +END C97118A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120a.ada b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada new file mode 100644 index 000000000..4fd5293c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada @@ -0,0 +1,81 @@ +-- C97120A.ADA + +-- 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. +--* +-- CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST AS LONG AS IS SPECIFIED +-- IN A DELAY ALTERNATIVE. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97120A IS + +BEGIN + + TEST ("C97120A", "CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST " & + "AS LONG AS IS SPECIFIED IN A DELAY ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY NO_GO; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + -- ENSURE THAT SYNCH HAS BEEN CALLED BEFORE PROCEEDING: + WHILE SYNCH'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + BEFORE := CLOCK; + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY"); + END IF; + END SELECT; + + ACCEPT SYNCH; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.SYNCH; -- SUSPEND MAIN TASK BEFORE READING CLOCK. + + END; + + RESULT; + +END C97120A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120b.ada b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada new file mode 100644 index 000000000..5cc9806bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada @@ -0,0 +1,103 @@ +-- C97120B.ADA + +-- 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. +--* +-- CHECK THAT IF A SPECIFIED DELAY IS ZERO OR NEGATIVE AND AN ENTRY CALL +-- IS WAITING AT AN OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS +-- EXECUTED, THE CALL IS ACCEPTED. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97120B IS + + ZERO, NEG : DURATION := 1.0; + +BEGIN + + TEST ("C97120B", "CHECK THAT IF A SPECIFIED DELAY IS ZERO OR " & + "NEGATIVE AND AN ENTRY CALL IS WAITING AT AN " & + "OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS " & + "EXECUTED, THE CALL IS ACCEPTED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + NEG := -1.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + A: BEGIN + SELECT + WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR + DELAY ZERO * Impdef.One_Second; + FAILED ("ZERO DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (A)"); + END A; + + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + B: BEGIN + SELECT + ACCEPT E; + OR + DELAY NEG; + FAILED ("NEGATIVE DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (B)"); + END B; + + END T; + + BEGIN + + T.E; + T.E; + + END; + + RESULT; + +END C97120B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201a.ada b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada new file mode 100644 index 000000000..18186cbc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada @@ -0,0 +1,151 @@ +-- C97201A.ADA + +-- 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. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE A: THE TASK TO BE CALLED IS NOT YET ACTIVE AS OF THE +-- MOMENT OF CALL (CONDITIONAL_ENTRY_CALL), +-- AND THIS FACT CAN BE DETERMINED STATICALLY. + + +-- RM 4/20/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201A IS + + ELSE_BRANCH_TAKEN : INTEGER := 3 ; + +BEGIN + + + TEST ("C97201A", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN OCCUR WHILE" & + " THE CALLED TASK IS NOT YET ACTIVE" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) ; + END T ; + + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT ; + PACKAGE BODY SECOND_ATTEMPT IS + BEGIN + + SELECT + DO_IT_NOW_ORELSE (FALSE) ;--CALLING (OWN) ENTRY + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 2 * ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#2)" ); + END SELECT; + + END SECOND_ATTEMPT ; + + BEGIN + + ACCEPT DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_ORELSE ; + + + END T ; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT ; + PACKAGE BODY FIRST_ATTEMPT IS + BEGIN + SELECT + T.DO_IT_NOW_ORELSE (FALSE) ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 1 + ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT ; + + + BEGIN + + T.DO_IT_NOW_ORELSE ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED) + + + CASE ELSE_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'ELSE'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'ELSE' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'ELSE' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'ELSE': #2,#1 " ); + + WHEN 8 => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + + RESULT; + + +END C97201A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201b.ada b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada new file mode 100644 index 000000000..d8e44b055 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada @@ -0,0 +1,108 @@ +-- C97201B.ADA + +-- 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. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF THERE IS +-- ANOTHER TASK QUEUED FOR THE ENTRY. + +-- WRG 7/11/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97201B IS + + +BEGIN + + TEST ("C97201B", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF THERE IS ANOTHER TASK QUEUED " & + "FOR THE ENTRY"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + ENTRY DONE; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + ACCEPT SYNCH; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + OR + ACCEPT DONE DO + IF E'COUNT /= 1 THEN + FAILED (NATURAL'IMAGE(E'COUNT) & + " CALLS WERE QUEUED FOR ENTRY " & + "E OF TASK T"); + END IF; + END DONE; + OR + DELAY 1000.0 * Impdef.One_Second; + FAILED ("DELAY EXPIRED; E'COUNT =" & + NATURAL'IMAGE(E'COUNT) ); + END SELECT; + + WHILE E'COUNT > 0 LOOP + ACCEPT E; + END LOOP; + END T; + + TASK AGENT; + + TASK BODY AGENT IS + BEGIN + T.E; + END AGENT; + + BEGIN + + T.SYNCH; + + DELAY 10.0 * Impdef.One_Second; + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED" ); + ELSE + COMMENT ("ELSE PART EXECUTED"); + T.DONE; + END SELECT; + + END; + + RESULT; + +END C97201B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201c.ada b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada new file mode 100644 index 000000000..e09d01ee3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada @@ -0,0 +1,70 @@ +-- C97201C.ADA + +-- 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. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF AN ACCEPT +-- STATEMENT FOR THE CALLED ENTRY HAS NOT YET BEEN REACHED. + +-- WRG 7/11/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97201C IS + +BEGIN + + TEST ("C97201C", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF AN ACCEPT STATEMENT FOR THE " & + "CALLED ENTRY HAS NOT YET BEEN REACHED"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY BARRIER; + END T; + + TASK BODY T IS + BEGIN + ACCEPT BARRIER; + IF E'COUNT > 0 THEN + FAILED ("ENTRY CALL WAS QUEUED"); + ACCEPT E; + END IF; + END T; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED"); + ELSE + COMMENT ("ELSE PART EXECUTED"); + END SELECT; + + T.BARRIER; + + END; + + RESULT; + +END C97201C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201d.ada b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada new file mode 100644 index 000000000..2ea7ba01a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada @@ -0,0 +1,102 @@ +-- C97201D.ADA + +-- 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. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- AND THIS FACT IS DETERMINED STATICALLY. + + +-- RM 4/12/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201D IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201D", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ; + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201D ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201e.ada b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada new file mode 100644 index 000000000..5473b572a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada @@ -0,0 +1,107 @@ +-- C97201E.ADA + +-- 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. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- AND THIS FACT CAN NOT BE DETERMINED STATICALLY. +-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS +-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + + +-- RM 4/13/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201E IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201E", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( SHORT ) ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + ACCEPT DO_IT_NOW_ORELSE ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE (10) ; -- ACCEPT_STATEMENT HAS 15 + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_ORELSE(KEEP_ALIVE) ;-- THIS ALSO UPDATES NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201E ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201g.ada b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada new file mode 100644 index 000000000..ae5fad3bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada @@ -0,0 +1,133 @@ +-- C97201G.ADA + +-- 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. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE G: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED +-- AND THIS FACT IS STATICALLY DETERMINABLE. + + +-- RM 4/21/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201G IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + +BEGIN + + + TEST ("C97201G", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = 5 => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201G ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201h.ada b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada new file mode 100644 index 000000000..ad4a46189 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada @@ -0,0 +1,133 @@ +-- C97201H.ADA + +-- 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. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE H: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED +-- AND THIS FACT IS NOT STATICALLY DETERMINABLE. + + +-- RM 4/22/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201H IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + +BEGIN + + + TEST ("C97201H", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = IDENT_INT(5) => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201H ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201x.ada b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada new file mode 100644 index 000000000..e7f74d982 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada @@ -0,0 +1,170 @@ +-- C97201X.ADA + +-- 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. +--* +-- CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF BOTH PARTNERS REFUSE TO +-- WAIT (THAT IS, IF THE ENTRY CALL IS ISSUED BY A +-- "CONDITIONAL_ENTRY_CALL" AND THUS FOLLOWS A NO-WAIT POLICY +-- (DEMANDING UNCONDITIONALLY THAT "YOU DO IT N O W , OR ELSE"), +-- WHILE THE CALLEE IS ALSO COMMITTED TO A NO-WAIT POLICY, +-- BY VIRTUE OF A SELECTIVE_WAIT STATEMENT OF THE THIRD KIND +-- (WITH AN "ELSE" PART) IN WHICH THE CORRESPONDING ACCEPT_STATEMENT +-- IS EMBEDDED). +-- ("CLOSE ENCOUNTERS OF THE THIRD KIND" -- ARE THEY POSSIBLE?) + + +-- THE SEMANTICS OF THIS ENTRY CALL REQUIRES THAT THE CALLING TASK +-- N O T ENTER ITSELF ON ANY QUEUE BUT RATHER ATTEMPT AN IMMEDIATE +-- RENDEZVOUS WHICH IS TO TAKE PLACE IF AND ONLY IF THE CALLED TASK +-- HAS REACHED A POINT WHERE IT IS READY TO ACCEPT THE CALL (I.E. +-- IT IS EITHER WAITING AT AN ACCEPT STATEMENT FOR THE CORRESPONDING +-- ENTRY OR IT IS WAITING AT A SELECTIVE_WAIT STATEMENT WITH AN OPEN +-- ALTERNATIVE STARTING WITH SUCH AN ACCEPT STATEMENT). IT ALSO +-- REQUIRES THAT THE ENTRY CALL BE CANCELLED IF THE CALLED TASK +-- IS NOT AT SUCH A POINT. ON THE OTHER HAND, THE SEMANTICS OF THE +-- SELECTIVE_WAIT STATEMENT WITH AN 'ELSE' PART SPECIFIES THAT +-- THE 'ELSE' PART MUST BE SELECTED IF NO 'ACCEPT' ALTERNATIVE +-- CAN BE IMMEDIATELY SELECTED, AND THAT SUCH AN ALTERNATIVE +-- IS DEEMED TO BE IMMEDIATELY SELECTABLE ("SELECTION OF ONE SUCH +-- ALTERNATIVE OCCURS IMMEDIATELY"), AND A CORRESPONDING RENDEZVOUS +-- POSSIBLE, IF AND ONLY IF THERE IS A CORRESPONDING ENTRY CALL +-- W A I T I N G TO BE ACCCEPTED. A "CONDITIONAL ENTRY CALL" +-- NEVER WAITS, AND IS NEVER ENTERED IN WAIT QUEUES; IT TAKES +-- THE 'ELSE' PART INSTEAD. + + +-- NOTE: IF THIS TEST PROGRAM HANGS UP, THE COMPILER WILL BE DEEMED +-- TO HAVE FAILED. + + +-- RM 3/19/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201X IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + + CALLER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + SERVER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201X", "CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF" & + " BOTH PARTNERS REFUSE TO WAIT" ); + + + DECLARE + + + TASK T IS + ENTRY SYNCHRONIZE ; + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + + ACCEPT SYNCHRONIZE ; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN ) + DO + DID_YOU_DO_IT := TRUE ; + END ; + ELSE -- (I.E. TASK ADOPTS NO-WAIT POLICY) + -- 'ELSE' BRANCH MUST THEREFORE BE CHOSEN + SERVER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF IT GETS TO + -- THE NO-WAIT MEETING-PLACE + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + + END T ; + + + BEGIN + + + T.SYNCHRONIZE ; -- TO MINIMIZE THE N E E D TO WAIT + + + SELECT + T.DO_IT_NOW_ORELSE ( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER TOO ADOPTS A NO-WAIT POLICY) + -- MUST THEREFORE CHOOSE THIS BRANCH + CALLER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + + END; -- END OF BLOCK CONTAINING THE NO-WAIT ENTRY CALL + + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF CALLER_TAKES_WRONG_BRANCH OR + SERVER_TAKES_WRONG_BRANCH + THEN + FAILED( "WRONG BRANCH TAKEN" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + + RESULT; + + +END C97201X ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97202a.ada b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada new file mode 100644 index 000000000..3856e7fd2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada @@ -0,0 +1,100 @@ +-- C97202A.ADA + +-- 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. +--* +-- CHECK THAT THE INDEX IS EVALUATED BEFORE THE ENTRY PARAMETER AND BOTH +-- THE INDEX AND THE ENTRY PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS +-- IS ATTEMPED. + +-- RM 4/05/82 +-- TBN 2/3/86 ADDED A CHECK THAT INDEX IS EVALUATED BEFORE THE ENTRY +-- PARAMETER AND FIXED APPROPRIATE COMMENTS. + +WITH REPORT; USE REPORT; +PROCEDURE C97202A IS + + INDEX_COMPUTED : BOOLEAN := FALSE ; + FORMAL_COMPUTED : BOOLEAN := FALSE ; + +BEGIN + + TEST ("C97202A", "CHECK THAT THE INDEX IS EVALUATED BEFORE THE " & + "ENTRY PARAMETER AND BOTH INDEX AND THE ENTRY " & + "PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS " & + "IS ATTEMPTED"); + + DECLARE + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE (SHORT) + (DID_YOU_DO_IT : IN BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE ; + END T ; + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + IF FORMAL_COMPUTED THEN + FAILED ("INDEX WAS NOT EVALUATED FIRST"); + END IF; + INDEX_COMPUTED := TRUE ; + RETURN (7) ; + END F1 ; + + FUNCTION F2 (X:INTEGER) RETURN BOOLEAN IS + BEGIN + FORMAL_COMPUTED := TRUE ; + RETURN (FALSE) ; + END F2 ; + + BEGIN + SELECT + T.DO_IT_NOW_ORELSE ( 6 + F1(7) ) + ( NOT(F2(7)) ) ; + ELSE + NULL ; + END SELECT; + + T.KEEP_ALIVE ; + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF INDEX_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY INDEX WAS NOT COMPUTED" ); + END IF; + + IF FORMAL_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY PARAMETER WAS NOT COMPUTED" ); + END IF; + + RESULT; + +END C97202A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203a.ada b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada new file mode 100644 index 000000000..64510dd9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada @@ -0,0 +1,125 @@ +-- C97203A.ADA + +-- 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. +--* +-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/01/1982 + + +WITH REPORT; +USE REPORT; +PROCEDURE C97203A IS + + +BEGIN + + + TEST ( "C97203A" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97203A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203b.ada b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada new file mode 100644 index 000000000..089815495 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada @@ -0,0 +1,131 @@ +-- C97203B.ADA + +-- 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. +--* +-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/09/1982 + + +WITH REPORT; +USE REPORT; +PROCEDURE C97203B IS + + +BEGIN + + + TEST ( "C97203B" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF COND_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF COND_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97203B ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203c.ada b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada new file mode 100644 index 000000000..d8d9bf5a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada @@ -0,0 +1,124 @@ +-- C97203C.ADA + +-- 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. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE WAIT IS NOT ALLOWED. + +-- PART 3: TASK BODY NESTED WITHIN A TASK. + +-- WRG 7/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97203C IS + +BEGIN + + TEST ("C97203C", "CHECK THAT A CONDITIONAL ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (1)"); + ELSE + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (2)"); + ELSE + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - OUTER"); + ELSE + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + +END C97203C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204a.ada b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada new file mode 100644 index 000000000..a1913a0b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada @@ -0,0 +1,122 @@ +-- C97204A.ADA + +-- 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. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED +-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE +-- CONDITIONAL_ENTRY_CALL. + + +-- RM 5/28/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97204A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97204A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " CONDITIONAL_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + ELSE + FAILED( "'ELSE' BRANCH TAKEN INSTEAD OF TSKG_ERR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C97204A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204b.ada b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada new file mode 100644 index 000000000..9e52a9deb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada @@ -0,0 +1,82 @@ +-- C97204B.ADA + +-- 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. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED +-- BEFORE THE CONDITIONAL ENTRY CALL IS EXECUTED. + +-- WRG 7/13/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97204B IS + +BEGIN + + TEST ("C97204B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE CONDITIONAL " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("CONDITIONAL ENTRY CALL MADE"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C97204B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205a.ada b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada new file mode 100644 index 000000000..a0bd4d9b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada @@ -0,0 +1,94 @@ +-- C97205A.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97205A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + +BEGIN + + TEST ("C97205A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97205A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205b.ada b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada new file mode 100644 index 000000000..ec49ad577 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada @@ -0,0 +1,98 @@ +-- C97205B.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97205B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + +BEGIN + + TEST ("C97205B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97205B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301a.ada b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada new file mode 100644 index 000000000..81c65fb11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada @@ -0,0 +1,158 @@ +-- C97301A.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE A: THE TASK TO BE CALLED HAS NOT YET BEEN ACTIVATED AS OF THE +-- MOMENT OF CALL. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301A IS + + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + OR_BRANCH_TAKEN : INTEGER := 3; + +BEGIN + + TEST ("C97301A", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "CALLED TASK IS NOT ACTIVE" ); + + ------------------------------------------------------------------ + + DECLARE + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ); + END T; + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT; + PACKAGE BODY SECOND_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + DO_IT_NOW_OR_WAIT (FALSE); --CALLING OWN ENTRY. + OR + -- THEREFORE THIS BRANCH + -- MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#2)" ); + END IF; + OR_BRANCH_TAKEN := 2 * OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#2)" ); + END SELECT; + END SECOND_ATTEMPT; + + BEGIN + + ACCEPT DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_OR_WAIT; + + + END T; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT; + PACKAGE BODY FIRST_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (FALSE); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#1)" ); + END IF; + OR_BRANCH_TAKEN := 1 + OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT; + + BEGIN + + T.DO_IT_NOW_OR_WAIT ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL. + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------ + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED). + + + CASE OR_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'OR'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'OR' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'OR' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'OR': #2,#1" ); + + WHEN 8 => + NULL; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + RESULT; + +END C97301A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301b.ada b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada new file mode 100644 index 000000000..f6dead392 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada @@ -0,0 +1,147 @@ +-- C97301B.ADA + +-- 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 TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + +-- CASE B: THE QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS +-- ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE COMPLETED WITHIN +-- THE SPECIFIED DELAY. + +--HISTORY: +-- RJW 03/31/86 CREATED ORIGINAL TEST. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301B IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301B", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS " & + "ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE " & + "COMPLETED WITHIN THE SPECIFIED DELAY" ); + + + DECLARE + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T1; + + TASK T2 IS + ENTRY AWAKEN_T2; + END T2; + + TASK T3 IS + ENTRY AWAKEN_T3; + ENTRY RELEASE_T; + END T3; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT (X : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X = 1 THEN + T2.AWAKEN_T2; + WHILE DO_IT_NOW_OR_WAIT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + T3.AWAKEN_T3; + T3.RELEASE_T; + ELSE + FAILED ("WRONG TASK IN RENDEZVOUS - 1"); + END IF; + END DO_IT_NOW_OR_WAIT; + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X /= 2 THEN + FAILED ("WRONG TASK IN RENDEZVOUS - 2"); + END IF; + END DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T1 IS + BEGIN + T.DO_IT_NOW_OR_WAIT (1); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT AWAKEN_T2; + T.DO_IT_NOW_OR_WAIT (2); + END T2; + + TASK BODY T3 IS + START_TIME : TIME; + STOP_TIME : TIME; + BEGIN + BEGIN + ACCEPT AWAKEN_T3; + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (3); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + ACCEPT RELEASE_T; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, THE TASK T IS EFFECTIVELY + -- TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + END T3; + BEGIN + NULL; + END; + + RESULT; + +END C97301B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301c.ada b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada new file mode 100644 index 000000000..a2b3abbc0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada @@ -0,0 +1,101 @@ +-- C97301C.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE C: AN ACCEPT STATEMENT FOR THE CALLED ENTRY HAS NOT BEEN +-- REACHED. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301C IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301C", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN AN " & + "ACCEPT STATEMENT FOR THE CALLED ENTRY HAS " & + "NOT BEEN REACHED" ); + + + DECLARE + START_TIME : TIME; + STOP_TIME : TIME; + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T IS + ENTRY NO_SPIN; + ENTRY DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T IS + BEGIN + ACCEPT NO_SPIN; + ACCEPT DO_IT_NOW_OR_WAIT; + END T; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + FAILED("RENDEZVOUS OCCURRED"); + ABORT T; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + T.NO_SPIN; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + T.DO_IT_NOW_OR_WAIT; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + +END C97301C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301d.ada b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada new file mode 100644 index 000000000..e473fa772 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada @@ -0,0 +1,106 @@ +-- C97301D.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301D IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301D", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "BODY OF THE TASK CONTAINING THE CALLED ENTRY " & + "DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR " & + "THAT ENTRY" ); + + DECLARE + START_TIME : TIME; + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT; + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + + ACCEPT KEEP_ALIVE; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT WAITING TIME" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR RAISED" ); + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL. + + -- BY NOW, THE TASK IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + +END C97301D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301e.ada b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada new file mode 100644 index 000000000..39bf159de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada @@ -0,0 +1,118 @@ +-- C97301E.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + +-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS +-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301E IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301E", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME " & + "IN THE ABSENCE OF A CORRESPONDING " & + "ACCEPT_STATEMENT " ); + + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + START_TIME : TIME; + + STOP_TIME : TIME; + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( SHORT ) ; + END T ; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + ACCEPT DO_IT_NOW_OR_WAIT ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END ; + + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (10) ; -- ACCEPT_STATEMENT HAS 15. + OR + -- THEREFORE THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE ; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_OR_WAIT (KEEP_ALIVE) ; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + + END; -- END OF BLOCK CONTAINING THE TIMED ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + +END C97301E ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97302a.ada b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada new file mode 100644 index 000000000..18c7afbd3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada @@ -0,0 +1,116 @@ +-- C97302A.ADA + +-- 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. +--* +-- CHECK THAT WHENEVER AN INDEX IS PRESENT IN A TIMED_ENTRY_CALL, IT +-- IS EVALUATED BEFORE ANY PARAMETER ASSOCIATIONS ARE EVALUATED, AND +-- PARAMETER ASSOCIATIONS ARE EVALUATED BEFORE THE DELAY EXPRESSION. +-- THEN A RENDEZVOUS IS ATTEMPTED. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97302A IS + + INDEX_COMPUTED : BOOLEAN := FALSE; + PARAM_COMPUTED : BOOLEAN := FALSE; + DELAY_COMPUTED : BOOLEAN := FALSE; +BEGIN + + TEST ("C97302A", "CHECK THAT WHENEVER AN INDEX IS PRESENT IN " & + "A TIMED_ENTRY_CALL, IT IS EVALUATED BEFORE " & + "ANY PARAMETER ASSOCIATIONS ARE EVALUATED, " & + "AND PARAMETER ASSOCIATIONS ARE EVALUATED " & + "BEFORE THE DELAY EXPRESSION" ); + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TYPE SHORT IS RANGE 10 .. 20; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT + ( SHORT ) + ( DID_YOU_DO_IT : IN BOOLEAN ); + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE; + END T; + + FUNCTION F1 (X : SHORT) RETURN SHORT IS + BEGIN + INDEX_COMPUTED := TRUE; + RETURN (15); + END F1; + + FUNCTION F2 RETURN BOOLEAN IS + BEGIN + IF INDEX_COMPUTED THEN + NULL; + ELSE + FAILED ( "INDEX NOT EVALUATED FIRST" ); + END IF; + PARAM_COMPUTED := TRUE; + RETURN (FALSE); + END F2; + + FUNCTION F3 RETURN DURATION IS + BEGIN + IF PARAM_COMPUTED THEN + NULL; + ELSE + FAILED ( "PARAMETERS NOT EVALUATED BEFORE DELAY " & + "EXPRESSION" ); + END IF; + DELAY_COMPUTED := TRUE; + RETURN (WAIT_TIME); + END; + BEGIN + + SELECT + T.DO_IT_NOW_OR_WAIT + ( F1 (15) ) + ( NOT F2 ); + FAILED ("RENDEZVOUS OCCURRED"); + OR + DELAY F3; + END SELECT; + + T.KEEP_ALIVE; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF DELAY_COMPUTED THEN + NULL; + ELSE + FAILED( "DELAY EXPRESSION NOT EVALUATED" ); + END IF; + + RESULT; + +END C97302A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303a.ada b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada new file mode 100644 index 000000000..67504fcf5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada @@ -0,0 +1,128 @@ +-- C97303A.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/06/1982 + +with Impdef; +WITH REPORT; +USE REPORT; +PROCEDURE C97303A IS + + +BEGIN + + + TEST ( "C97303A" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 2.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C97303A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303b.ada b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada new file mode 100644 index 000000000..5043fa1db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada @@ -0,0 +1,133 @@ +-- C97303B.ADA + +-- 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. +--* +-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/12/1982 + +with Impdef; +WITH REPORT; +USE REPORT; +PROCEDURE C97303B IS + + +BEGIN + + + TEST ( "C97303B" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF TIMED_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF TIMED_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97303B ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303c.ada b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada new file mode 100644 index 000000000..a6143037c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada @@ -0,0 +1,128 @@ +-- C97303C.ADA + +-- 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. +--* +-- CHECK THAT A TIMED ENTRY CALL CAN APPEAR IN PLACES WHERE A SELECTIVE +-- WAIT IS NOT ALLOWED. + +-- PART 3: TASK BODY NESTED WITHIN A TASK. + +-- WRG 7/15/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97303C IS + +BEGIN + + TEST ("C97303C", "CHECK THAT A TIMED ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (1)"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (2)"); + OR + DELAY 1.0 * Impdef.One_Second; + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - OUTER"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + +END C97303C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304a.ada b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada new file mode 100644 index 000000000..8e4504730 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada @@ -0,0 +1,123 @@ +-- C97304A.ADA + +-- 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. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED +-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE +-- TIMED_ENTRY_CALL. + + +-- RM 5/28/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97304A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97304A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " TIMED_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED( "'OR' BRANCH TAKEN INSTEAD OF TSKG_ERROR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C97304A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304b.ada b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada new file mode 100644 index 000000000..1d7f4cd06 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada @@ -0,0 +1,84 @@ +-- C97304B.ADA + +-- 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. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED +-- BEFORE THE TIMED ENTRY CALL IS EXECUTED. + +-- WRG 7/13/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97304B IS + +BEGIN + + TEST ("C97304B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE TIMED " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("TIMED ENTRY CALL MADE"); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED ("DELAY ALTERNATIVE TAKEN"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C97304B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305a.ada b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada new file mode 100644 index 000000000..81349b87d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada @@ -0,0 +1,100 @@ +-- C97305A.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- TIMED ENTRY CALL), IT IS PERFORMED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + +BEGIN + + TEST ("C97305A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97305A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305b.ada b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada new file mode 100644 index 000000000..13a28a39e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada @@ -0,0 +1,104 @@ +-- C97305B.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- TIMED ENTRY CALL), IT IS PERFORMED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + +BEGIN + + TEST ("C97305B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97305B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305c.ada b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada new file mode 100644 index 000000000..ee9953ba4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada @@ -0,0 +1,90 @@ +-- C97305C.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES +-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305C IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + +BEGIN + + TEST ("C97305C", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Long_Second; + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Long_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + +END C97305C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305d.ada b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada new file mode 100644 index 000000000..022b0adcb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada @@ -0,0 +1,95 @@ +-- C97305D.ADA + +-- 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. +--* +-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES +-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305D IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + +BEGIN + + TEST ("C97305D", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + +END C97305D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97307a.ada b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada new file mode 100644 index 000000000..32d26e6b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada @@ -0,0 +1,209 @@ +-- C97307A.ADA + +-- 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. +--* +-- CHECK THAT A TIMED ENTRY CALL THAT IS CANCELED (BECAUSE THE DELAY HAS +-- EXPIRED) IS REMOVED FROM THE QUEUE OF THE CALLED TASK'S ENTRY. + +-- WRG 7/14/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97307A IS + +BEGIN + + TEST ("C97307A", "CHECK THAT A TIMED ENTRY CALL THAT IS " & + "CANCELED (BECAUSE THE DELAY HAS EXPIRED) IS " & + "REMOVED FROM THE QUEUE OF THE CALLED TASK'S " & + "ENTRY"); + + DECLARE + + DELAY_TIME : CONSTANT DURATION := 2 * 60.0 * Impdef.One_Second; + + TASK EXPIRED IS + ENTRY INCREMENT; + ENTRY READ (COUNT : OUT NATURAL); + END EXPIRED; + + TASK TYPE NON_TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END NON_TIMED_CALLER; + + TASK TYPE TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END TIMED_CALLER; + + CALLER1 : TIMED_CALLER; + CALLER2 : NON_TIMED_CALLER; + CALLER3 : TIMED_CALLER; + CALLER4 : NON_TIMED_CALLER; + CALLER5 : TIMED_CALLER; + + TASK T IS + ENTRY E (NAME : NATURAL); + END T; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + -------------------------------------------------- + + TASK BODY EXPIRED IS + EXPIRED_CALLS : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT INCREMENT DO + EXPIRED_CALLS := EXPIRED_CALLS + 1; + END INCREMENT; + OR + ACCEPT READ (COUNT : OUT NATURAL) DO + COUNT := EXPIRED_CALLS; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END EXPIRED; + + -------------------------------------------------- + + TASK BODY NON_TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + T.E (MY_NAME); + END NON_TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + SELECT + T.E (MY_NAME); + FAILED ("TIMED ENTRY CALL NOT CANCELED FOR CALLER" & + NATURAL'IMAGE(MY_NAME)); + OR + DELAY DELAY_TIME; + EXPIRED.INCREMENT; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TIMED_CALLER -- " & + "CALLER" & NATURAL'IMAGE(MY_NAME)); + END TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY DISPATCH IS + BEGIN + CALLER1.NAME (1); + ACCEPT READY; + + CALLER2.NAME (2); + ACCEPT READY; + + CALLER3.NAME (3); + ACCEPT READY; + + CALLER4.NAME (4); + ACCEPT READY; + + CALLER5.NAME (5); + END DISPATCH; + + -------------------------------------------------- + + TASK BODY T IS + + DESIRED_QUEUE_LENGTH : NATURAL := 1; + EXPIRED_CALLS : NATURAL; + + ACCEPTED : ARRAY (1..5) OF NATURAL RANGE 0..5 + := (OTHERS => 0); + ACCEPTED_INDEX : NATURAL := 0; + + BEGIN + LOOP + LOOP + EXPIRED.READ (EXPIRED_CALLS); + EXIT WHEN E'COUNT >= DESIRED_QUEUE_LENGTH - + EXPIRED_CALLS; + DELAY 2.0 * Impdef.One_Long_Second; + END LOOP; + EXIT WHEN DESIRED_QUEUE_LENGTH = 5; + DISPATCH.READY; + DESIRED_QUEUE_LENGTH := DESIRED_QUEUE_LENGTH + 1; + END LOOP; + + -- AT THIS POINT, FIVE TASKS WERE QUEUED. + -- LET THE TIMED ENTRY CALLS ISSUED BY CALLER1, + -- CALLER3, AND CALLER5 EXPIRE: + + DELAY DELAY_TIME + 10.0 * Impdef.One_Long_Second; + + -- AT THIS POINT, ALL THE TIMED ENTRY CALLS MUST HAVE + -- EXPIRED AND BEEN REMOVED FROM THE ENTRY QUEUE FOR E, + -- OTHERWISE THE IMPLEMENTATION HAS FAILED THIS TEST. + + WHILE E'COUNT > 0 LOOP + ACCEPT E (NAME : NATURAL) DO + ACCEPTED_INDEX := ACCEPTED_INDEX + 1; + ACCEPTED (ACCEPTED_INDEX) := NAME; + END E; + END LOOP; + + IF ACCEPTED /= (2, 4, 0, 0, 0) THEN + FAILED ("SOME TIMED CALLS NOT REMOVED FROM ENTRY " & + "QUEUE"); + COMMENT ("ORDER ACCEPTED WAS:" & + NATURAL'IMAGE (ACCEPTED (1)) & ',' & + NATURAL'IMAGE (ACCEPTED (2)) & ',' & + NATURAL'IMAGE (ACCEPTED (3)) & ',' & + NATURAL'IMAGE (ACCEPTED (4)) & ',' & + NATURAL'IMAGE (ACCEPTED (5)) ); + END IF; + END T; + + -------------------------------------------------- + + BEGIN + + NULL; + + END; + + RESULT; + +END C97307A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974001.a b/gcc/testsuite/ada/acats/tests/c9/c974001.a new file mode 100644 index 000000000..04ac93e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974001.a @@ -0,0 +1,152 @@ +-- C974001.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 the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a delay_relative +-- statement and check that the sequence of statements of the triggering +-- alternative is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_relative triggering statement. Parameterize +-- the accept statement with the time to be used in the delay. Simulate a +-- time-consuming calculation by declaring a procedure containing an +-- infinite loop. Call this procedure in the abortable part. +-- +-- The delay will expire before the abortable part completes, at which +-- time the abortable part is aborted, and the sequence of statements +-- following the triggering statement is executed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C974001 is + + + --========================================================-- + + -- Medium length delay + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + + Calculation_Canceled : exception; + + + Count : Integer := 1234; + + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + delay ImpDef.Minimum_Task_Switch; -- allow other task + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + -- + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay Time_Limit; -- Time_Limit is not up yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + then abort + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C974001", "Asynchronous Select: Trigger is delay_relative" & + " which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + null; -- expected behavior + end; + + Report.Result; + +end C974001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974002.a b/gcc/testsuite/ada/acats/tests/c9/c974002.a new file mode 100644 index 000000000..1138e8da3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974002.a @@ -0,0 +1,209 @@ +-- C974002.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 the sequence of statements of the triggering alternative +-- of an asynchronous select statement is executed if the triggering +-- statement is a delay_until statement, and the specified time has +-- already passed. Check that the abortable part is not executed after +-- the sequence of statements of the triggering alternative is left. +-- +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the abortable +-- part completes before the triggering statement, and the triggering +-- statement is a delay_until statement. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_until triggering statement. Parameterize +-- the accept statement with the time to be used in the delay. Simulate +-- a quick calculation by declaring a procedure which sets a Boolean +-- flag. Call this procedure in the abortable part. +-- +-- Make two calls to the task entry: (1) with a time that has already +-- expired, and (2) with a time that will not expire before the quick +-- calculation completes. +-- +-- For (1), the sequence of statements following the triggering statement +-- is executed, and the abortable part never starts. +-- +-- For (2), the abortable part completes before the triggering statement, +-- the delay is canceled, and the sequence of statements following the +-- triggering statement never starts. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Bug fix for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Calendar; +with ImpDef; +procedure C974002 is + + function "-" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "+" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + Abortable_Part_Executed : Boolean; + Triggering_Alternative_Executed : Boolean; + + + --========================================================-- + + + procedure Quick_Calculation is + begin + if Report.Equal (1, 1) then + Abortable_Part_Executed := True; + end if; + end Quick_Calculation; + + + --========================================================-- + + + task type Timed_Calculation_Task is + entry Calculation (Time_Out : in Ada.Calendar.Time); + end Timed_Calculation_Task; + + + task body Timed_Calculation_Task is + begin + loop + select + accept Calculation (Time_Out : in Ada.Calendar.Time) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay until Time_Out; -- Triggering + -- statement. + + Triggering_Alternative_Executed := True; -- Triggering + -- alternative. + then abort + Quick_Calculation; -- Abortable part. + end select; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation_Task"); + end Timed_Calculation_Task; + + + --========================================================-- + + + Start_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_of (1901,1,1); + Minute : constant Duration := 60.0; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C974002", "Asynchronous Select with Delay_Until"); + + -- take care of implementations that start the clock at 1/1/01 + delay ImpDef.Delay_For_Time_Past; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + NO_DELAY_SUBTEST: + + declare + -- Set Expiry to a time which has already passed + Expiry : constant Ada.Calendar.Time := Start_Time; + Timed : Timed_Calculation_Task; + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. Since it has already passed, the + -- abortable part should not execute, and the sequence of statements + -- of the triggering alternative should be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select + -- inside accept block. + if Abortable_Part_Executed then + Report.Failed ("No delay: Abortable part was executed"); + end if; + + if not Triggering_Alternative_Executed then + Report.Failed ("No delay: triggering alternative sequence " & + "of statements was not executed"); + end if; + end No_Delay_Subtest; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + LONG_DELAY_SUBTEST: + + declare + + -- Quick_Calculation should finish before expiry. + Expiry : constant Ada.Calendar.Time := + Ada.Calendar.Clock + Minute; + Timed : Timed_Calculation_Task; + + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. It should not pass before the abortable + -- part completes, at which time control should return to the caller; + -- the sequence of statements of the triggering alternative should + -- not be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select. + + if not Abortable_Part_Executed then + Report.Failed ("Long delay: Abortable part was not executed"); + end if; + + if Triggering_Alternative_Executed then + Report.Failed ("Long delay: triggering alternative sequence " & + "of statements was executed"); + end if; + end Long_Delay_Subtest; + + + Report.Result; + +end C974002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974003.a b/gcc/testsuite/ada/acats/tests/c9/c974003.a new file mode 100644 index 000000000..c353a918d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974003.a @@ -0,0 +1,249 @@ +-- C974003.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 the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a task entry call, and +-- the entry call is queued. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires), which causes the task to execute the +-- accept statement corresponding to the triggering entry call. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974003_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + TC_Triggering_Statement_Completed : Boolean := False; + TC_Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974003_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974003_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Minimum_Task_Switch; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + -- then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + TC_Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + TC_Count := (TC_Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (TC_Count, TC_Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974003_0; + + + --==================================================================-- + + +with Report; + +with C974003_0; -- Automated teller machine abstraction. +use C974003_0; + +procedure C974003 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974003", "Asynchronous Select: Trigger is queued on a " & + "task entry and completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974003_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and completes before this call + -- finishes; it is then aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end; + + Report.Result; + +end C974003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974004.a b/gcc/testsuite/ada/acats/tests/c9/c974004.a new file mode 100644 index 000000000..b1200c103 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974004.a @@ -0,0 +1,273 @@ +-- C974004.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 the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a task entry call, +-- the entry call is queued, and the entry call completes by propagating +-- an exception and that the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left and that +-- the exception propagated by the entry call is re-raised immediately +-- following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires), which causes the task to execute the +-- accept statement corresponding to the triggering entry call. Raise +-- an exception in the accept statement which is not handled by the task, +-- and which is thus propagated to the caller. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974004_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; -- Global to defeat + -- optimization. + Propagated_From_Task : exception; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974004_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974004_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls to be + Listen_For_Input (Key_Pressed); -- queued, then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now true, so accept + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed + ("Exception not propagated in ATM_Keyboard_Task"); + + -- User has canceled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + end loop; + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974004_0; + + + --==================================================================-- + + +with Report; + +with C974004_0; -- Automated teller machine abstraction. +use C974004_0; + +procedure C974004 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974004", "Asynchronous Select: Trigger is queued on a " & + "task entry and is completed first by an " & + "exception"); + + Read_Card (Card_Data); + + begin + + declare + -- Create the task for this transaction + Keyboard : C974004_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call finishes; it is then + -- aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + end select; + -- The propagated exception is + -- re-raised here; control passes to + -- the exception handler. + + Perform_Transaction(Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + -- This is the expected test path + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + when Tasking_Error => + Report.Failed ("Tasking_Error raised"); + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Propagated_From_Task => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + +end C974004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974005.a b/gcc/testsuite/ada/acats/tests/c9/c974005.a new file mode 100644 index 000000000..196a8edc0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974005.a @@ -0,0 +1,259 @@ +-- C974005.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 Tasking_Error is raised at the point of an entry call +-- which is the triggering statement of an asynchronous select, if +-- the entry call is queued, but the task containing the entry completes +-- before it can be accepted or canceled. +-- +-- Check that the abortable part is aborted if it does not complete +-- before the triggering statement completes. +-- +-- Check that the sequence of statements of the triggering alternative +-- is not executed. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires) which is NOT the input expected by the +-- guard on the accept statement. The entry remains closed, and the +-- task completes its execution. Since the entry was not accepted before +-- its task completed, Tasking_Error is raised at the point of the entry +-- call. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974005_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974005_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974005_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses a transaction key (NOT Cancel). + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Deposit; -- Cancel is NOT pressed. + end if; + end Listen_For_Input; + + + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + + -- Note: no loop. If the user does not press Cancel, the task completes. + -- In this model of the keyboard monitor, the user only gets one chance + -- to cancel the card validation. + -- Force entry + Listen_For_Input (Key_Pressed); -- calls to be + -- queued, but do + -- NOT set guard + -- to true. + select + when (Key_Pressed = Cancel) => -- Guard is false, + accept Cancel_Pressed do -- so entry call + Report.Failed ("Accept statement executed"); -- remains queued. + end Cancel_Pressed; + else -- Else alternative + Key_Pressed := None; -- executed, then + end select; -- task ends. + exception + when others => + Report.Failed ("Unexpected exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + + -- Synch Point to allow transfer of control to Keyboard task + -- during this simulation + delay ImpDef.Minimum_Task_Switch; + + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Additional analysis added to aid developers + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974005_0; + + + --==================================================================-- + + +with Report; + +with C974005_0; -- Automated teller machine abstraction. +use C974005_0; + +procedure C974005 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974005", "ATC: trigger is queued but task terminates" & + " before call is serviced"); + + Read_Card (Card_Data); + + begin + + declare + Keyboard : C974005_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + -- Tasking_Error raised here when + -- Keyboard completes before entry + -- call can be accepted, and before + -- abortable part completes. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard task completes before + -- Keyboard.Cancel_Pressed is + -- accepted, and before this call + -- finishes. Tasking_Error is raised + -- at the point of the entry call, + -- and this call is aborted. + -- Check that the whole of the abortable part is aborted, not just + -- the statement in the abortable part that was executing at + -- the time + Report.Failed ("Abortable part not aborted"); + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Tasking_Error => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + +end C974005; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974006.a b/gcc/testsuite/ada/acats/tests/c9/c974006.a new file mode 100644 index 000000000..f6f4d92e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974006.a @@ -0,0 +1,197 @@ +-- C974006.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 the sequence of statements of the triggering alternative +-- of an asynchronous select statement is executed if the triggering +-- statement is a protected entry call, and the entry is accepted +-- immediately. Check that the corresponding entry body is executed +-- before the sequence of statements of the triggering alternative. +-- Check that the abortable part is not executed. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a +-- protected entry call as triggering statement. Declare a protected +-- procedure which sets the protected entry's barrier true. Force the +-- entry call to be accepted immediately by calling this protected +-- procedure prior to the asynchronous select. Since the entry call +-- is accepted immediately, the abortable part should never start. When +-- entry call completes, the sequence of statements of the triggering +-- alternative should execute. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974006_0 is -- Automated teller machine abstraction. + + + -- Flag for testing purposes: + + Entry_Body_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974006_0; + + + --==================================================================-- + + +with Report; +package body C974006_0 is + + + protected body ATM_Keyboard_Protected is + + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Entry_Body_Executed := True; + end Cancel_Pressed; + + procedure Read_Key is + begin + -- Simulate a procedure which processes user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not fully executed"); + end Perform_Transaction; + + +end C974006_0; + + + --==================================================================-- + + +with Report; + +with C974006_0; -- Automated teller machine abstraction. +use C974006_0; + +procedure C974006 is + + Card_Data : ATM_Card_Type; + +begin + + Report.Test ("C974006", "ATC: trigger is protected entry call" & + " and completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974006_0.ATM_Keyboard_Protected; + begin + + -- Simulate the situation where the user hits cancel before the + -- validation process can start: + Keyboard.Read_Key; -- Force Keyboard.Cancel_Pressed to + -- be accepted immediately. + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is accepted immediately, + -- so abortable part does NOT start. + + if not Entry_Body_Executed then -- Executes after entry completes. + Report.Failed ("Triggering alternative sequence of statements " & + "executed before triggering statement complete"); + end if; + + raise Transaction_Canceled; -- Control passes to exception + -- handler. + then abort + Validate_Card (Card_Data); -- Should not be executed. + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + null; + end; + + Report.Result; + +end C974006; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974007.a b/gcc/testsuite/ada/acats/tests/c9/c974007.a new file mode 100644 index 000000000..07007b9bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974007.a @@ -0,0 +1,205 @@ +-- C974007.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 the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the triggering +-- statement is a protected entry call, and the entry is not accepted +-- before the abortable part completes. Check that execution continues +-- immediately following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a +-- protected entry call as triggering statement. Declare a protected +-- procedure which sets the protected entry's barrier true. Ensure +-- that the entry call is never accepted by not calling the protected +-- procedure; the barrier remains false, and the entry call from +-- asynchronous select is queued. Since the abortable part will complete +-- before the entry is accepted, the sequence of statements of the +-- triggering alternative is never executed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974007_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + Abortable_Part_Executed : Boolean := False; + Perform_Transaction_Executed : Boolean := False; + Triggering_Statement_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974007_0; + + + --==================================================================-- + + +with Report; +package body C974007_0 is + + + protected body ATM_Keyboard_Protected is + + -- Barrier is false for the live of the test + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Triggering_Statement_Executed := true; -- Test has failed + -- (Note: cannot call Report.Failed in the protected entry body] + end Cancel_Pressed; + + procedure Read_Key is -- Never + begin -- called. + -- Simulate a procedure which reads user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Abortable_Part_Executed := True; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Perform_Transaction_Executed := True; + end Perform_Transaction; + + +end C974007_0; + + + --==================================================================-- +with Report; + +with C974007_0; -- Automated teller machine abstraction. +use C974007_0; + +procedure C974007 is + + Card_Data : ATM_Card_Type; + +begin + + Report.Test ("C974007", "ATC: trigger is protected entry call" & + " and abortable part completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974007_0.ATM_Keyboard_Protected; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Barrier is never set true, so + -- entry call is queued and never + -- accepted. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- This call completes before + -- Keyboard.Cancel_Pressed can be + -- accepted. + end select; + Perform_Transaction (Card_Data); -- Execution proceeds here after + -- Validate_Card completes. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + end; + + + if Triggering_Statement_Executed then + Report.Failed ("Triggering statement was executed"); + end if; + + if not Abortable_Part_Executed then + Report.Failed ("Abortable part not executed"); + end if; + + if not Perform_Transaction_Executed then + Report.Failed ("Statements following asynchronous select not " & + "executed"); + end if; + + Report.Result; + +end C974007; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974008.a b/gcc/testsuite/ada/acats/tests/c9/c974008.a new file mode 100644 index 000000000..b76db7bd0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974008.a @@ -0,0 +1,229 @@ +-- C974008.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 the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call, and +-- the entry call is not queued. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Ensure that the task is waiting +-- at the accept statement so the rendezvous is executed immediately (the +-- entry call is not queued). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974008_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Triggering_Statement_Completed : Boolean := False; + Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974008_0; + + + --==================================================================-- + + +with Report; +package body C974008_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where the user presses the cancel key + -- before the card is validated + + -- press the cancel key immediately + Key := Cancel; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + -- NOTE: Normal usage for this routine would be the loop with + -- the select statement included. This particular test + -- requires that the task be waiting at the accept + -- for the call. To ensure that this is the case the + -- extraneous commands are commented out (we leave them + -- in this form to show the reader the surrounds to the + -- fragment of code remaining) + + -- loop + + Listen_For_Input (Key_Pressed); + + -- select + -- when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + -- exit; + -- else + -- Key_Pressed := None; + -- end select; + + -- end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + end Perform_Transaction; + + +end C974008_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974008_0; -- Automated teller machine abstraction. +use C974008_0; + +procedure C974008 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974008", "Asynchronous Select: Trigger is a call to a " & + "waiting task entry and completes immediately"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974008_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting at the accept + -- This is the time required to activate another task and allow it + -- to run to its first accept statement. + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is executed immediately + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + + -- In other similar tests Validate_Card is called here. In this + -- test we just check to see if the abortable part is called at + -- all. Since the triggering call is not queued the abortable + -- part should not be started + -- + Report.Failed ("Abortable part started"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + + if not Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + + end; + + Report.Result; + +end C974008; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974009.a b/gcc/testsuite/ada/acats/tests/c9/c974009.a new file mode 100644 index 000000000..419f2a3e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974009.a @@ -0,0 +1,206 @@ +-- C974009.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 the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call, +-- the entry call is not queued and the entry call completes by +-- propagating an exception. +-- +-- Check that the exception is properly propagated to the asynchronous +-- select statement and thus the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left. +-- +-- Check that the exception propagated by the entry call is re-raised +-- immediately following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- +-- Use a small subset of the base Automated teller machine simulation +-- which is shown in greater detail in other tests of this series. +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the task to be waiting at +-- the accept statement so that the call is not queued and the rendezvous +-- is executed immediately. Simulate an unexpected exception in the +-- rendezvous. Use stripped down versions of called procedures to check +-- the correct path in the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974009_0 is -- Automated teller machine abstraction. + + + Propagated_From_Task : exception; + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974009_0; + + + --==================================================================-- + + +with Report; +package body C974009_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + accept Cancel_Pressed do -- queued entry call. + null; --:::: stub, user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed ("Exception not propagated in ATM_Keyboard_Task"); + + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + +end C974009_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974009_0; -- Automated teller machine abstraction. +use C974009_0; + +procedure C974009 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974009", "Asynchronous Select: Trigger is a call to a " & + "task entry, is not queued and is completed " & + "first by an exception"); + + + begin + + declare + -- Create the task for this transaction + Keyboard : C974009_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting a the accept so the call is not queued + -- This is the time required to activate another task and allow it + -- to run to its first accept statement + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call is executed + end select; + + -- The propagated exception is re-raised here. + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + null; -- This is the expected test path + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when others => + Report.Failed ("Unexpected exception raised"); + end; + + Report.Result; + +end C974009; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974010.a b/gcc/testsuite/ada/acats/tests/c9/c974010.a new file mode 100644 index 000000000..caeb9d570 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974010.a @@ -0,0 +1,209 @@ +-- C974010.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 the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call to +-- a task that has already terminated. +-- +-- Check that Tasking_Error is properly propagated to the asynchronous +-- select statement and thus the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left. +-- +-- Check that Tasking_Error is re-raised immediately following the +-- asynchronous select. +-- +-- TEST DESCRIPTION: +-- +-- Use a small subset of the base Automated Teller Machine simulation +-- which is shown in greater detail in other tests of this series. +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Ensure that the task is +-- terminated before the entry call. Use stripped down versions of +-- the called procedures to check the correct path in the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974010_0 is -- Automated teller machine abstraction. + + + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974010_0; + + + --==================================================================-- + + +with Report; +package body C974010_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + TC_Suicide : exception; + Key_Pressed : Key_Enum := None; + begin + raise TC_Suicide; -- Simulate early, unexpected termination + + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + + end Cancel_Pressed; + + exception + when TC_Suicide => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + +end C974010_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974010_0; -- Automated teller machine abstraction. +use C974010_0; + +procedure C974010 is + + Card_Data : ATM_Card_Type; + TC_Tasking_Error_Handled : Boolean := false; + +begin -- Main program. + + Report.Test ("C974010", "Asynchronous Select: Trigger is a call to a " & + "task entry of a task that is already completed"); + + + declare + -- Create the task for this transaction + Keyboard : C974010_0.ATM_Keyboard_Task; + begin + + -- Ensure the task is already completed before calling + -- + while not Keyboard'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + + then abort + + -- Since the triggering call is not queued the abortable part + -- should not be executed. + -- + Validate_Card (Card_Data); + + end select; + -- + -- The propagated exception is re-raised here. + + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + -- This is the expected test path + TC_Tasking_Error_Handled := true; + when others => + Report.Failed ("Wrong exception raised: "); + end; + + + if not TC_Tasking_Error_Handled then + Report.Failed ("Tasking_Error not properly propagated"); + end if; + + Report.Result; + +exception + when Tasking_Error => + Report.Failed ("Tasking_Error propagated to wrong handler"); + Report.Result; + + +end C974010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974011.a b/gcc/testsuite/ada/acats/tests/c9/c974011.a new file mode 100644 index 000000000..4682db628 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974011.a @@ -0,0 +1,275 @@ +-- C974011.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 the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the triggering +-- statement is a task entry call and the entry is not accepted +-- before the abortable part completes. +-- Check that the call queued on the entry is cancelled +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates (with a delay) a routine waiting +-- for user input +-- +-- Once the call is known to be queued, complete the abortable part. +-- Check that the rendezvous (and thus the trigger) does not complete. +-- Then clear the barrier and check that the entry has been cancelled +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Nov 95 SAIC Eliminated shared global variable for ACVC 2.0.1 +-- +--! + +with ImpDef; +-- +package C974011_0 is -- Automated teller machine abstraction. + + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + protected Key_PO is + procedure Set (K : Key_Enum); + function Value return Key_Enum; + private + Current : Key_Enum := None; + end Key_PO; + + + -- Flags for testing purposes + TC_Abortable_Part_Completed : Boolean := False; + TC_Rendezvous_Entered : Boolean := False; + TC_Delay_Time : constant duration := ImpDef.Switch_To_New_Task; + + + Count : Integer := 1234; -- Global to defeat optimization. + + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974011_0; + + + --==================================================================-- + + +with Report; +package body C974011_0 is + + protected body Key_PO is + procedure Set (K : Key_Enum) is + begin + Current := K; + end Set; + + function Value return Key_Enum is + begin + return Current; + end Value; + end Key_PO; + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user does not press cancel thus + -- allowing validation to complete + + delay TC_Delay_Time; -- Long enough to force queuing on + -- Keyboard.Cancel_Pressed. + + Key := Key_PO.Value; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + + select + when (Key_Pressed = Cancel) => + accept Cancel_Pressed do + TC_Rendezvous_Entered := True; + end Cancel_Pressed; + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + delay ImpDef.Switch_To_New_Task; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Count := (Count + 1) mod Integer (Card.PIN); + + -- Simulate a validation activity which is longer than the time + -- taken in Listen_For_Input but not inordinately so. + delay TC_Delay_Time * 2; + + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + if TC_Rendezvous_Entered then + Report.Failed ("Triggering statement completed"); + end if; + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + if not TC_Abortable_Part_Completed then + Report.Failed ("Abortable part did not complete"); + end if; + end Perform_Transaction; + + +end C974011_0; + + + --==================================================================-- + + +with Report; + +with C974011_0; -- Automated teller machine abstraction. +use C974011_0; + +procedure C974011 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974011", "Asynchronous Select: Trigger is queued on a " & + "task entry and the abortable part " & + "completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974011_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + raise Transaction_Canceled; -- This would be executed if we + -- completed the rendezvous + then abort + + Validate_Card (Card_Data); + TC_Abortable_Part_Completed := true; + + end select; + + Perform_Transaction (Card_Data); + + + -- Now clear the entry barrier to allow the rendezvous to complete + -- if the triggering call has not been cancelled + Key_PO.Set (Cancel); + -- + delay TC_Delay_Time; -- to allow it all to take place + + if TC_Rendezvous_Entered then + Report.Failed ("Triggering Call was not cancelled"); + end if; + + abort Keyboard; -- clean up. (Note: the task will only exit the + -- loop and terminate if the call hanging on the + -- entry is executed.) + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Others => + Report.Failed ("Unexpected exception in the Main"); + end; + + Report.Result; + +end C974011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974012.a b/gcc/testsuite/ada/acats/tests/c9/c974012.a new file mode 100644 index 000000000..4e43c72a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974012.a @@ -0,0 +1,165 @@ +-- C974012.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 the abortable part of an asynchronous select statement is +-- aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a call on a protected +-- entry which is queued. +-- +-- TEST DESCRIPTION: +-- A fraction of in-line code is simulated. A voltage deficiency causes +-- the routine to seek an alternate best-cost route on an electrical grid +-- system. +-- +-- An asynchronous select is used with the triggering alternative being a +-- call to a protected entry with a barrier. The abortable part is a +-- routine simulating the lengthy alternate path negotiation. The entry +-- barrier would be cleared if the voltage deficiency is rectified before +-- the alternate can be found thus nullifying the need for the alternate. +-- +-- The test simulates a return to normal in the middle of the +-- negotiation. The barrier is cleared, the triggering alternative +-- completes first and the abortable part should be aborted. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C974012 is + + subtype Grid_Path is string(1..21); + subtype Deficiency is integer range 100..1_000; -- in MWh + + New_Path : Grid_Path; + Dummy_Deficiency : Deficiency := 520; + Path_Available : Boolean := false; + + TC_Terminate_Negotiation_Executed : Boolean := false; + TC_Trigger_Completed : Boolean := false; + TC_Negotiation_Completed : Boolean := false; + + protected Local_Deficit is + procedure Set_Good_Voltage; + procedure Bad_Voltage; + entry Terminate_Negotiation; + private + Good_Voltage : Boolean := false; -- barrier + end Local_Deficit; + + protected body Local_Deficit is + + procedure Set_Good_Voltage is + begin + Good_Voltage := true; + end Set_Good_Voltage; + + procedure Bad_Voltage is + begin + Good_Voltage := false; + end Bad_Voltage; + + -- Trigger is queued on this entry with barrier condition + entry Terminate_Negotiation when Good_Voltage is + begin + -- complete the triggering call thus terminating grid_path + -- negotiation. + null; --::: stub - signal main board + TC_Terminate_Negotiation_Executed := true; -- show path traversal + end Terminate_Negotiation; + + end Local_Deficit; + + + -- Routine to find the most cost effective grid path for this + -- particular deficiency at this particular time + -- + procedure Path_Negotiation (Requirement : in Deficiency; + Best_Path : out Grid_Path ) is + + Dummy_Path : Grid_Path := "NYC.425_NY.227_NH.132"; + Match : Deficiency := Report.Ident_Int (Requirement); + + begin + -- + null; --::: stub + -- + -- Simulate a lengthy path negotiation + for i in 1..5 loop + delay ImpDef.Minimum_Task_Switch; + -- Part of the way through the negotiation simulate some external + -- event returning the voltage to acceptable level + if i = 3 then + Local_Deficit.Set_Good_Voltage; -- clear the barrier + end if; + end loop; + + Best_Path := Dummy_Path; + TC_Negotiation_Completed := true; + + end Path_Negotiation; + + + +begin + + Report.Test ("C974012", "Asynchronous Select: Trigger is queued on a " & + "protected entry and completes before the " & + "abortable part"); + + -- ::::::::: Fragment of code + + Local_Deficit.Bad_Voltage; -- Set barrier condition + + -- For the given voltage deficiency start negotiating the best grid + -- path. If voltage returns to acceptable level cancel the negotiation + -- + select + -- Prepare to terminate the Path_Negotiation if voltage improves + Local_Deficit.Terminate_Negotiation; + TC_Trigger_Completed := true; + then abort + Path_Negotiation (Dummy_Deficiency, New_Path) ; + Path_Available := true; + end select; + -- ::::::::: + + if not TC_Terminate_Negotiation_Executed or else not + TC_Trigger_Completed then + Report.Failed ("Unexpected test path taken"); + end if; + + if Path_Available or else TC_Negotiation_Completed then + Report.Failed ("Abortable part was not aborted"); + end if; + Report.Result; + +end C974012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974013.a b/gcc/testsuite/ada/acats/tests/c9/c974013.a new file mode 100644 index 000000000..4a930da93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974013.a @@ -0,0 +1,167 @@ +-- C974013.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 the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a delay_until +-- statement. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_until triggering statement. Parameterize +-- the accept statement with the amount of time to be added to the +-- current time to be used for the delay. Simulate a time-consuming +-- calculation by declaring a procedure containing an infinite loop. +-- Call this procedure in the abortable part. +-- +-- The delay will expire before the abortable part completes, at which +-- time the abortable part is aborted, and the sequence of statements +-- following the triggering statement is executed. +-- +-- Main test logic is identical to c974001 which uses simple delay +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Nov 95 SAIC Fixed problems for ACVC 2.0.1. +-- +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C974013 is + + + --========================================================-- + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + Calculation_Canceled : exception; + + Count : Integer := 1234; + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + exit when not Report.Equal (Count, Count); -- Condition always false. + delay 0.0; -- abort completion point + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + Delay_Time : Ada.Calendar.Time; + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- We have to construct an "until" time artificially + -- as we have no control over when the test will be run + -- + Delay_Time := Ada.Calendar.Clock + Time_Limit; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + delay until Delay_Time; -- Time not reached yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + + then abort + + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + + +begin -- Main program. + + Report.Test ("C974013", "Asynchronous Select: Trigger is delay_until " & + "which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + Report.Failed ("wrong exception handler used"); + end; + + Report.Result; + +end C974013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974014.a b/gcc/testsuite/ada/acats/tests/c9/c974014.a new file mode 100644 index 000000000..03ca915f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974014.a @@ -0,0 +1,132 @@ +-- C974014.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 if the triggering alternative of an asynchronous select +-- statement is a delay and the abortable part completes before the delay +-- expires then the delay is cancelled and the optional statements in the +-- triggering part are not performed. In particular, check the case of +-- the ATC in non-tasking code. +-- +-- TEST DESCRIPTION: +-- A fraction of in-line code is simulated. An asynchronous select +-- is used with a triggering delay of several minutes. The abortable +-- part, which is simulating a very lengthy, time consuming procedure +-- actually returns almost immediately thus ensuring that it completes +-- first. At the conclusion, if a substantial amount of time has passed +-- the delay is assumed not to have been cancelled. +-- (based on example in LRM 9.7.4) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with Ada.Calendar; + +procedure C974014 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + Maximum_Allowable_Time : duration := 300.0; -- for Calculate_Gamma_Function + +begin + + Report.Test ("C974014", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed"); + + declare -- encapsulate test code + + type Gamma_Index is digits 5; -- float precision + + -- (These two fields are assumed filled elsewhere) + Input_Field, Result_of_Beta : Gamma_Index; + + -- Notify and take corrective action in the event that + -- the procedure Calculate_Gamma_Function does not converge. + -- + procedure Non_Convergent is + begin + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Non_Convergent; + + + -- This is a very time consuming calculation. It is possible, + -- that, with certain parameters, it will not converge. If it + -- runs for more than Maximum_Allowable_Time it is considered + -- not to be convergent and should be aborted. + -- + Procedure Calculate_Gamma_Function (X, Y : Gamma_Index) is + begin + null; -- Stub + -- + end Calculate_Gamma_Function; + + begin -- declare + + -- ..... Isolated segment of inline code + + -- Now Print Gamma Function (abort and display if not convergent) + -- + select + delay Maximum_Allowable_Time; -- for Calculate_Gamma_Function + Non_Convergent; -- Display error and flag result as failed + + then abort + Calculate_Gamma_Function (Input_Field, Result_of_Beta); + end select; + + -- ..... End of Isolated segment of inline code + + end; -- declare + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Note: We are not checking for "cancellation within a reasonable time", + -- we are checking for cancellation/non-cancellation of the delay. We + -- use a number which, if exceeded, means that the delay was not + -- cancelled and has proceeded to full term. + -- + if ( TC_Elapsed_Time > Maximum_Allowable_Time/2 ) then + -- Test time exceeds a reasonable value. + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + + Report.Result; + +end C974014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980001.a b/gcc/testsuite/ada/acats/tests/c9/c980001.a new file mode 100644 index 000000000..3bd4196f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980001.a @@ -0,0 +1,303 @@ +-- C980001.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 when a construct is aborted the execution of an Initialize +-- procedure as the last step of the default initialization of a +-- controlled object is abort-deferred. +-- +-- Check that when a construct is aborted the execution of a Finalize +-- procedure as part of the finalization of a controlled object is +-- abort-deferred. +-- +-- Check that an assignment operation to an object with a controlled +-- part is an abort-deferred operation. +-- +-- TEST DESCRIPTION: +-- The controlled operations which are being tested call a subprogram +-- which guarantees that the enclosing operation becomes aborted. +-- +-- Each object is created with a unique value to prevent optimizations +-- due to the values being the same. +-- +-- Two protected objects are utilized to warrant that the operations +-- are delayed in their execution until such time that the abort is +-- processed. The object Hold_Up is used to hold the targeted +-- operation in execution, the object Progress is used to communicate +-- to the driver software that progress is indeed being made. +-- +-- +-- CHANGE HISTORY: +-- 01 MAY 95 SAIC Initial version +-- 01 MAY 96 SAIC Revised for 2.1 +-- 11 DEC 96 SAIC Final revision for 2.1 +-- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock +--! + +---------------------------------------------------------------- C980001_0 + +with Impdef; +with Ada.Finalization; +package C980001_0 is + + A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0; + Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration + := Impdef.Switch_To_New_Task * 4.0; + + function TC_Unique return Integer; + + type Sticks_In_Initialize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Initialize( AV: in out Sticks_In_Initialize ); + + type Sticks_In_Adjust is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Adjust ( AV: in out Sticks_In_Adjust ); + + type Sticks_In_Finalize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Finalize ( AV: in out Sticks_In_Finalize ); + + Initialize_Called : Boolean := False; + Adjust_Called : Boolean := False; + Finalize_Called : Boolean := False; + + protected type Sticker is + entry Lock; + procedure Unlock; + function Is_Locked return Boolean; + private + Locked : Boolean := False; + end Sticker; + + Hold_Up : Sticker; + Progress : Sticker; + + procedure Fail_And_Clear( Message : String ); + + +end C980001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body C980001_0 is + + TC_Master_Value : Integer := 0; + + + function TC_Unique return Integer is -- make all values unique. + begin + TC_Master_Value := TC_Master_Value +1; + return TC_Master_Value; + end TC_Unique; + + protected body Sticker is + + entry Lock when not Locked is + begin + Locked := True; + end Lock; + + procedure Unlock is + begin + Locked := False; + end Unlock; + + function Is_Locked return Boolean is + begin + return Locked; + end Is_Locked; + + end Sticker; + + procedure Initialize( AV: in out Sticks_In_Initialize ) is + begin + TCTouch.Touch('I'); -------------------------------------------------- I + Hold_Up.Unlock; -- cause the select to abort + Initialize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('i'); -------------------------------------------------- i + Progress.Unlock; -- allows Wait_Your_Turn to continue + end Initialize; + + procedure Adjust ( AV: in out Sticks_In_Adjust ) is + begin + TCTouch.Touch('A'); -------------------------------------------------- A + Hold_Up.Unlock; -- cause the select to abort + Adjust_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('a'); -------------------------------------------------- a + Progress.Unlock; + end Adjust; + + procedure Finalize ( AV: in out Sticks_In_Finalize ) is + begin + TCTouch.Touch('F'); -------------------------------------------------- F + Hold_Up.Unlock; -- cause the select to abort + Finalize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('f'); -------------------------------------------------- f + Progress.Unlock; + end Finalize; + + procedure Fail_And_Clear( Message : String ) is + begin + Report.Failed(Message); + Hold_Up.Unlock; + Progress.Unlock; + end Fail_And_Clear; + +end C980001_0; + +--------------------------------------------------------------------------- + +with Report; +with TCTouch; +with Impdef; +with C980001_0; +procedure C980001 is + + procedure Check_Initialize_Conditions is + begin + if not C980001_0.Initialize_Called then + C980001_0.Fail_And_Clear("Initialize did not correctly complete"); + end if; + TCTouch.Validate("Ii", "Initialization Sequence"); + end Check_Initialize_Conditions; + + procedure Check_Adjust_Conditions is + begin + if not C980001_0.Adjust_Called then + C980001_0.Fail_And_Clear("Adjust did not correctly complete"); + end if; + TCTouch.Validate("Aa", "Adjust Sequence"); + end Check_Adjust_Conditions; + + procedure Check_Finalize_Conditions is + begin + if not C980001_0.Finalize_Called then + C980001_0.Fail_And_Clear("Finalize did not correctly complete"); + end if; + TCTouch.Validate("FfFfFf", "Finalization Sequence", + Order_Meaningful => False); + end Check_Finalize_Conditions; + + procedure Wait_Your_Turn is + Overrun : Natural := 0; + begin + while C980001_0.Progress.Is_Locked loop -- and waits + delay C980001_0.A_Little_While; + Overrun := Overrun +1; + if Overrun > 10 then + C980001_0.Fail_And_Clear("Overrun expired lock"); + end if; + end loop; + end Wait_Your_Turn; + +begin -- Main test procedure. + + Report.Test ("C980001", "Check the interaction between asynchronous " & + "transfer of control and controlled types" ); + + C980001_0.Progress.Lock; + C980001_0.Hold_Up.Lock; + + select + C980001_0.Hold_Up.Lock; -- Init will unlock + + Wait_Your_Turn; -- abortable part is stuck in Initialize + Check_Initialize_Conditions; + + then abort + declare + Object : C980001_0.Sticks_In_Initialize; + begin + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object.Item ) /= Object.Item then + Report.Failed("Optimization foil caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Initialize test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Adjust will unlock + + Wait_Your_Turn; -- abortable part is stuck in Adjust + Check_Adjust_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Adjust; + Object2 : C980001_0.Sticks_In_Adjust; + begin + Object1 := Object2; + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 1 caused failure"); + end if; + C980001_0.Fail_And_Clear("Adjust test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Finalize will unlock + + Wait_Your_Turn; -- abortable part is stuck in Finalize + Check_Finalize_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Finalize; + Object2 : C980001_0.Sticks_In_Finalize; + begin + Object1 := Object2; -- cause a finalize call + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 2 caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Finalize test executed beyond expected region"); + end; + end select; + + Report.Result; + +exception + when others => C980001_0.Fail_And_Clear("Exception in main"); + Report.Result; +end C980001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980002.a b/gcc/testsuite/ada/acats/tests/c9/c980002.a new file mode 100644 index 000000000..f2b9c5247 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980002.a @@ -0,0 +1,165 @@ +-- C980002.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 aborts are deferred during protected actions. +-- +-- TEST DESCRIPTION: +-- This test uses an asynchronous transfer of control to attempt +-- to abort a protected operation. The protected operation +-- includes several requeues to check that the requeue does not +-- allow the abort to occur. +-- +-- +-- CHANGE HISTORY: +-- 30 OCT 95 SAIC ACVC 2.1 +-- +--! + +with Report; +procedure C980002 is + + Max_Checkpoints : constant := 7; + type Checkpoint_ID is range 1..Max_Checkpoints; + type Points_Array is array (Checkpoint_ID) of Boolean; +begin + Report.Test ("C980002", + "Check that aborts are deferred during a protected action" & + " including requeues"); + + declare -- test encapsulation + + protected Checkpoint is + procedure Got_Here (Id : Checkpoint_ID); + function Results return Points_Array; + private + Reached_Points : Points_Array := (others => False); + end Checkpoint; + + protected body Checkpoint is + procedure Got_Here (Id : Checkpoint_ID) is + begin + Reached_Points (Id) := True; + end Got_Here; + + function Results return Points_Array is + begin + return Reached_Points; + end Results; + end Checkpoint; + + + protected Start_Here is + entry AST_Waits_Here; + entry Start_PO; + private + Open : Boolean := False; + entry First_Stop; + end Start_Here; + + protected Middle_PO is + entry Stop_1; + entry Stop_2; + end Middle_PO; + + protected Final_PO is + entry Final_Stop; + end Final_PO; + + + protected body Start_Here is + entry AST_Waits_Here when Open is + begin + null; + end AST_Waits_Here; + + entry Start_PO when True is + begin + Open := True; + Checkpoint.Got_Here (1); + requeue First_Stop; + end Start_PO; + + -- make sure the AST has been accepted before continuing + entry First_Stop when AST_Waits_Here'Count = 0 is + begin + Checkpoint.Got_Here (2); + requeue Middle_PO.Stop_1; + end First_Stop; + end Start_Here; + + protected body Middle_PO is + entry Stop_1 when True is + begin + Checkpoint.Got_Here (3); + requeue Stop_2; + end Stop_1; + + entry Stop_2 when True is + begin + Checkpoint.Got_Here (4); + requeue Final_PO.Final_Stop; + end Stop_2; + end Middle_PO; + + protected body Final_PO is + entry Final_Stop when True is + begin + Checkpoint.Got_Here (5); + end Final_Stop; + end Final_PO; + + + begin -- test encapsulation + select + Start_Here.AST_Waits_Here; + Checkpoint.Got_Here (6); + then abort + Start_Here.Start_PO; + delay 0.0; -- abort completion point + Checkpoint.Got_Here (7); + end select; + + Check_The_Results: declare + Chk : constant Points_Array := Checkpoint.Results; + Expected : constant Points_Array := (1..6 => True, + 7 => False); + begin + for I in Checkpoint_ID loop + if Chk (I) /= Expected (I) then + Report.Failed ("checkpoint error" & + Checkpoint_ID'Image (I) & + " actual is " & + Boolean'Image (Chk(I))); + end if; + end loop; + end Check_The_Results; + exception + when others => + Report.Failed ("unexpected exception"); + end; -- test encapsulation + + Report.Result; +end C980002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980003.a b/gcc/testsuite/ada/acats/tests/c9/c980003.a new file mode 100644 index 000000000..dd69fc7ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980003.a @@ -0,0 +1,294 @@ +-- C980003.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 aborts are deferred during the execution of an +-- Initialize procedure (as the last step of the default +-- initialization of a controlled object), during the execution +-- of a Finalize procedure (as part of the finalization of a +-- controlled object), and during an assignment operation to an +-- object with a controlled part. +-- +-- TEST DESCRIPTION: +-- A controlled type is created with Initialize, Adjust, and +-- Finalize operations. These operations note in a protected +-- object when the operation starts and completes. This change +-- in state of the protected object will open the barrier for +-- the entry in the protected object. +-- The test contains declarations of objects of the controlled +-- type. An asynchronous select is used to attempt to abort +-- the operations on the controlled type. The asynchronous select +-- makes use of the state change to the protected object to +-- trigger the abort. +-- +-- +-- CHANGE HISTORY: +-- 11 Jan 96 SAIC Initial Release for 2.1 +-- 5 May 96 SAIC Incorporated Reviewer comments. +-- 10 Oct 96 SAIC Addressed issue where assignment statement +-- can be 2 assignment operations. +-- +--! + +with Ada.Finalization; +package C980003_0 is + Verbose : constant Boolean := False; + + -- the following flag is set true whenever the + -- Initialize operation is called. + Init_Occurred : Boolean; + + type Is_Controlled is new Ada.Finalization.Controlled with + record + Id : Integer; + end record; + + procedure Initialize (Object : in out Is_Controlled); + procedure Finalize (Object : in out Is_Controlled); + procedure Adjust (Object : in out Is_Controlled); + + type States is (Unknown, + Start_Init, Finished_Init, + Start_Adjust, Finished_Adjust, + Start_Final, Finished_Final); + + protected State_Manager is + procedure Reset; + procedure Set (New_State : States); + function Current return States; + entry Wait_For_Change; + private + Current_State : States := Unknown; + Changed : Boolean := False; + end State_Manager; + +end C980003_0; + + +with Report; +with ImpDef; +package body C980003_0 is + protected body State_Manager is + procedure Reset is + begin + Current_State := Unknown; + Changed := False; + end Reset; + + procedure Set (New_State : States) is + begin + Changed := True; + Current_State := New_State; + end Set; + + function Current return States is + begin + return Current_State; + end Current; + + entry Wait_For_Change when Changed is + begin + Changed := False; + end Wait_For_Change; + end State_Manager; + + procedure Initialize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting initialize"); + end if; + State_Manager.Set (Start_Init); + if Verbose then + Report.Comment ("in initialize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Init); + if Verbose then + Report.Comment ("finished initialize"); + end if; + Init_Occurred := True; + end Initialize; + + procedure Finalize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting finalize"); + end if; + State_Manager.Set (Start_Final); + if Verbose then + Report.Comment ("in finalize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Final); + if Verbose then + Report.Comment ("finished finalize"); + end if; + end Finalize; + + procedure Adjust (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting adjust"); + end if; + State_Manager.Set (Start_Adjust); + if Verbose then + Report.Comment ("in adjust"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Adjust); + if Verbose then + Report.Comment ("finished adjust"); + end if; + end Adjust; +end C980003_0; + + +with Report; +with ImpDef; +with C980003_0; use C980003_0; +with Ada.Unchecked_Deallocation; +procedure C980003 is + + procedure Check_State (Should_Be : States; + Msg : String) is + Cur : States := State_Manager.Current; + begin + if Cur /= Should_Be then + Report.Failed (Msg); + Report.Comment ("expected: " & States'Image (Should_Be) & + " found: " & States'Image (Cur)); + elsif Verbose then + Report.Comment ("passed: " & Msg); + end if; + end Check_State; + +begin + + Report.Test ("C980003", "Check that aborts are deferred during" & + " initialization, finalization, and assignment" & + " operations on controlled objects"); + + Check_State (Unknown, "initial condition"); + + -- check that initialization and finalization take place + Init_Occurred := False; + select + State_Manager.Wait_For_Change; + then abort + declare + My_Controlled_Obj : Is_Controlled; + begin + delay 0.0; -- abort completion point + Report.Failed ("state change did not occur"); + end; + end select; + if not Init_Occurred then + Report.Failed ("Initialize did not complete"); + end if; + Check_State (Finished_Final, "init/final for declared item"); + + -- check adjust + State_Manager.Reset; + declare + Source, Dest : Is_Controlled; + begin + Check_State (Finished_Init, "adjust initial state"); + Source.Id := 3; + Dest.Id := 4; + State_Manager.Reset; -- so we will wait for change + select + State_Manager.Wait_For_Change; + then abort + Dest := Source; + end select; + + -- there are two implementation methods for the + -- assignment statement: + -- 1. no temporary was used in the assignment statement + -- thus the entire + -- assignment statement is abort deferred. + -- 2. a temporary was used in the assignment statement so + -- there are two assignment operations. An abort may + -- occur between the assignment operations + -- Various optimizations are allowed by 7.6 that can affect + -- how many times Adjust and Finalize are called. + -- Depending upon the implementation, the state can be either + -- Finished_Adjust or Finished_Finalize. If it is any other + -- state then the abort took place at the wrong time. + + case State_Manager.Current is + when Finished_Adjust => + if Verbose then + Report.Comment ("assignment aborted after adjust"); + end if; + when Finished_Final => + if Verbose then + Report.Comment ("assignment aborted after finalize"); + end if; + when Start_Adjust => + Report.Failed ("assignment aborted in adjust"); + when Start_Final => + Report.Failed ("assignment aborted in finalize"); + when Start_Init => + Report.Failed ("assignment aborted in initialize"); + when Finished_Init => + Report.Failed ("assignment aborted after initialize"); + when Unknown => + Report.Failed ("assignment aborted in unknown state"); + end case; + + + if Dest.Id /= 3 then + if Verbose then + Report.Comment ("assignment not performed"); + end if; + end if; + end; + + + -- check dynamically allocated objects + State_Manager.Reset; + declare + type Pointer_Type is access Is_Controlled; + procedure Free is new Ada.Unchecked_Deallocation ( + Is_Controlled, Pointer_Type); + Ptr : Pointer_Type; + begin + -- make sure initialize is done when object is allocated + Ptr := new Is_Controlled; + Check_State (Finished_Init, "init when item allocated"); + -- now try aborting the finalize + State_Manager.Reset; + select + State_Manager.Wait_For_Change; + then abort + Free (Ptr); + end select; + Check_State (Finished_Final, "finalization in dealloc"); + end; + + Report.Result; + +end C980003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c99004a.ada b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada new file mode 100644 index 000000000..8774314d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada @@ -0,0 +1,166 @@ +-- C99004A.ADA + +-- 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 THE PREFIX OF 'TERMINATED AND 'CALLABLE CAN BE A +-- FUNCTION CALL RETURNING AN OBJECT HAVING A TASK TYPE. + +-- NOTE: SEE TEST C38202A FOR CHECKS INVOLVING PREFIXES WHICH ARE +-- ACCESS TYPES DENOTING TASK TYPES OR WHICH ARE FUNCTIONS +-- RETURNING ACCESS TYPES DENOTING TASK TYPES. + +-- HISTORY: +-- RJW 09/16/86 CREATED ORIGINAL TEST. +-- DHH 10/15/87 CORRECTED HEADER COMMENTS. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C99004A IS + + TYPE ENUM IS (A, B, C, D); + + EARRAY : ARRAY (ENUM) OF STRING (1 .. 17) := + (A => "BEFORE ACTIVATION", + B => "DURING ACTIVATION", + C => "DURING EXECUTION ", + D => "AFTER TERMINATION" ); + + FUNCTION CHECK (S : STRING; CALL, B1, TERM, B2 : BOOLEAN; + E : ENUM) RETURN BOOLEAN IS + BEGIN + IF CALL /= B1 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'CALLABLE " & + EARRAY (E) & " OF TASK" ); + END IF; + + IF TERM /= B2 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'TERMINATED " & + EARRAY (E) & " OF TASK" ); + END IF; + + RETURN IDENT_BOOL (TRUE); + END CHECK; + + +BEGIN + TEST ( "C99004A", "CHECK THAT THE PREFIX OF 'TERMINATED AND " & + "'CALLABLE CAN BE A FUNCTION CALL RETURNING " & + "AN OBJECT HAVING A TASK TYPE" ); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + PACKAGE PKG1 IS + T1 : TT; + END PKG1; + + FUNCTION F RETURN TT IS + BEGIN + RETURN PKG1.T1; + END F; + + PACKAGE PKG2 IS + A1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, A); + END PKG2; + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, B); + C1 : BOOLEAN; + BEGIN + C1 := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + PACKAGE BODY PKG1 IS + BEGIN + NULL; + END; + + TASK BODY MAIN_TASK IS + D1 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT PKG1.T1; + DELAY 5.0 * Impdef.One_Long_Second; + D1 := CHECK ("F", F'CALLABLE, FALSE, + F'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + T2 : TT; + + A2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, A); + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, B); + C2 : BOOLEAN; + BEGIN + C2 := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + TASK BODY MAIN_TASK IS + D2 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT T2; + DELAY 5.0 * Impdef.One_Long_Second; + D2 := CHECK ("T2", T2'CALLABLE, FALSE, + T2'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + RESULT; +END C99004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c99005a.ada b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada new file mode 100644 index 000000000..f3bcbaa6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada @@ -0,0 +1,183 @@ +-- C99005A.ADA + +-- 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 THE ATTRIBUTE 'COUNT RETURNS THE CORRECT VALUE. + +-- HISTORY: +-- DHH 03/24/88 CREATED ORIGINAL TEST. + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C99005A IS + +BEGIN + + TEST("C99005A", "CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE " & + "CORRECT VALUE"); + + DECLARE + TASK A IS + END A; + + TASK B IS + END B; + + TASK C IS + END C; + + TASK D IS + END D; + + TASK E IS + END E; + + TASK F IS + END F; + + TASK G IS + END G; + + TASK H IS + END H; + + TASK I IS + END I; + + TASK J IS + END J; + + TASK T IS + ENTRY WAIT; + END T; + + TASK CHOICE IS + ENTRY RETURN_CALL; + ENTRY E2; + ENTRY E1; + END CHOICE; + + TASK BODY A IS + BEGIN + CHOICE.E1; + END A; + + TASK BODY B IS + BEGIN + CHOICE.E1; + END B; + + TASK BODY C IS + BEGIN + CHOICE.E1; + END C; + + TASK BODY D IS + BEGIN + CHOICE.E1; + END D; + + TASK BODY E IS + BEGIN + CHOICE.E1; + END E; + + TASK BODY F IS + BEGIN + CHOICE.E2; + END F; + + TASK BODY G IS + BEGIN + CHOICE.E2; + END G; + + TASK BODY H IS + BEGIN + CHOICE.E2; + END H; + + TASK BODY I IS + BEGIN + CHOICE.E2; + END I; + + TASK BODY J IS + BEGIN + CHOICE.E2; + END J; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT WAIT DO + DELAY 1.0 * Impdef.One_Second; + END WAIT; + CHOICE.RETURN_CALL; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + TASK BODY CHOICE IS + BEGIN + WHILE E1'COUNT + E2'COUNT < 10 LOOP + T.WAIT; + ACCEPT RETURN_CALL; + END LOOP; + + FOR I IN REVERSE 1 ..10 LOOP + SELECT + ACCEPT E2 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E2; + OR + ACCEPT E1 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E1; + END SELECT; + END LOOP; + END CHOICE; + + BEGIN + NULL; + END; + + RESULT; +END C99005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada new file mode 100644 index 000000000..e8d7706cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada @@ -0,0 +1,105 @@ +-- C9A003A.ADA + +-- 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. +--* +-- CHECK THAT ABORTING A TERMINATED TASK DOES NOT CAUSE EXCEPTIONS. + + +-- RM 5/21/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A003A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A003A", "CHECK THAT ABORTING A TERMINATED TASK" & + " DOES NOT CAUSE EXCEPTIONS" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 20 S.)" ); + END IF; + + + BEGIN + ABORT T_OBJECT1 ; + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED (WHEN ABORTING A" & + " TERMINATED TASK)" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C9A003A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada new file mode 100644 index 000000000..124724379 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada @@ -0,0 +1,108 @@ +-- C9A004A.ADA + +-- 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. +--* +-- CHECK THAT IF A TASK IS ABORTED BEFORE BEING ACTIVATED, THE TASK IS +-- TERMINATED. + + +-- RM 5/21/82 +-- SPS 11/21/82 +-- JBG 6/3/85 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A004A IS + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A004A", "CHECK THAT IF A TASK IS ABORTED" & + " BEFORE BEING ACTIVATED," & + " THE TASK IS TERMINATED" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + PACKAGE P IS + X : INTEGER := 0 ; + END P ; + + + PACKAGE BODY P IS + BEGIN + + IF T_OBJECT1'TERMINATED OR + NOT T_OBJECT1'CALLABLE + THEN + FAILED( "WRONG VALUES FOR ATTRIBUTES" ); + END IF; + + ABORT T_OBJECT1 ; -- ELABORATED BUT NOT YET ACTIVATED. + + END P ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + FAILED( "ABORTED (BEFORE ACTIVATION) TASK" & + " NOT TERMINATED" ); + END IF; + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + + END; + + RESULT; + +END C9A004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada new file mode 100644 index 000000000..9339930a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada @@ -0,0 +1,293 @@ +-- C9A007A.ADA + +-- 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. +--* +-- CHECK THAT A TASK MAY ABORT A TASK IT DEPENDS ON. + + +-- RM 5/26/82 +-- RM 7/02/82 +-- SPS 11/21/82 +-- JBG 2/27/84 +-- JBG 3/8/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. +-- EDS 08/04/98 ENSURE THAT ABORTED TASKS HAVE TIME TO EFFECT THEIR ABORTIONS. + +WITH IMPDEF; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A007A IS + + TASK_NOT_ABORTED : BOOLEAN := FALSE; + TEST_VALID : BOOLEAN := TRUE ; + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ( "C9A007A" , "CHECK THAT A TASK MAY ABORT A TASK" & + " IT DEPENDS ON" ); + + + DECLARE + + + TASK REGISTER IS + + + ENTRY BIRTHS_AND_DEATHS; + + ENTRY SYNC1; + ENTRY SYNC2; + + + END REGISTER; + + + TASK BODY REGISTER IS + + + TASK TYPE SECONDARY IS + + + ENTRY WAIT_INDEFINITELY; + + END SECONDARY; + + + TASK TYPE T_TYPE1 IS + + + ENTRY E; + + END T_TYPE1; + + + TASK TYPE T_TYPE2 IS + + + ENTRY E; + + END T_TYPE2; + + + T_OBJECT1 : T_TYPE1; + T_OBJECT2 : T_TYPE2; + + + TASK BODY SECONDARY IS + BEGIN + SYNC1; + ABORT T_OBJECT1; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END SECONDARY; + + + TASK BODY T_TYPE1 IS + + TYPE ACCESS_TO_TASK IS ACCESS SECONDARY; + + BEGIN + + + DECLARE + DEPENDENT_BY_ACCESS : ACCESS_TO_TASK := + NEW SECONDARY ; + BEGIN + NULL; + END; + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE1; + + + TASK BODY T_TYPE2 IS + + TASK INNER_TASK IS + + + ENTRY WAIT_INDEFINITELY; + + END INNER_TASK; + + TASK BODY INNER_TASK IS + BEGIN + SYNC2; + ABORT T_OBJECT2; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END INNER_TASK; + + BEGIN + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE2; + + + BEGIN + + DECLARE + OLD_COUNT : INTEGER := 0; + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN BIRTHS_AND_DEATHS'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + IF OLD_COUNT = 2 THEN + + ACCEPT SYNC1; -- ALLOWING ABORT#1 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #1 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT1.E; + FAILED( "T_OBJECT1.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 1"); + + END; + + IF T_OBJECT1'CALLABLE THEN + FAILED( "T_OBJECT1'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#1 NOT REMOVED FROM QUEUE" ); + END IF; + + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + + ACCEPT SYNC2; -- ALLOWING ABORT#2 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #2 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT2.E; + FAILED( "T_OBJECT2.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 2"); + + END; + + IF T_OBJECT2'CALLABLE THEN + FAILED( "T_OBJECT2'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#2 NOT REMOVED FROM QUEUE" ); + END IF; + + + IF BIRTHS_AND_DEATHS'COUNT /= 0 THEN + FAILED( "SOME TASKS STILL QUEUED" ); + END IF; + + + ELSE + + COMMENT( "LINEUP NOT COMPLETE (AFTER 50 S.)" ); + TEST_VALID := FALSE; + + END IF; + + + END; + + + WHILE BIRTHS_AND_DEATHS'COUNT > 0 LOOP + ACCEPT BIRTHS_AND_DEATHS; + END LOOP; + + + END REGISTER; + + + BEGIN + + NULL; + + END; + + + ------------------------------------------------------------------- + + + IF TEST_VALID AND TASK_NOT_ABORTED THEN + FAILED( "SOME TASKS NOT ABORTED" ); + END IF; + + + RESULT; + + +END C9A007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada new file mode 100644 index 000000000..ba3b0845d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada @@ -0,0 +1,117 @@ +-- C9A009A.ADA + +-- 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 ABORT DURING RENDEZVOUS + +-- CALLING TASK IN RENDEVOUS IS NAMED IN ABORT STATEMENT. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009D-B.ADA + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A009A IS + +BEGIN + + TEST("C9A009A", "CALLING TASK IS ABORTED DIRECTLY"); + + DECLARE + -- T1 CALLS T2, WHICH ABORTS T1 WHILE IN RENDEVOUS + + T2_CONTINUED : BOOLEAN := FALSE; + + TASK CONTINUED IS + ENTRY GET (T2_CONTINUED : OUT BOOLEAN); + ENTRY PUT (T2_CONTINUED : IN BOOLEAN); + END CONTINUED; + + TASK BODY CONTINUED IS + CONTINUED : BOOLEAN := FALSE; + BEGIN + LOOP + SELECT + ACCEPT GET (T2_CONTINUED : OUT BOOLEAN) DO + T2_CONTINUED := CONTINUED; + END GET; + OR + ACCEPT PUT (T2_CONTINUED : IN BOOLEAN) DO + CONTINUED := T2_CONTINUED; + END PUT; + OR + TERMINATE; + END SELECT; + END LOOP; + END CONTINUED; + + BEGIN -- THIS BLOCK WILL MAKE SURE T2 IS TERMINATED, AND SO, + -- T2_CONTINUED IS ASSIGNED A VALUE IF T2 CONTINUES + -- EXECUTION CORRECTLY. + + DECLARE + + TASK T1; + + TASK T2 IS + ENTRY E1; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED ("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ABORT T1; + ABORT T1; -- WHY NOT? + IF T1'TERMINATED THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + END E1; + CONTINUED.PUT (T2_CONTINUED => TRUE); + END T2; + BEGIN + NULL; + END; + -- T2 NOW TERMINATED + CONTINUED.GET (T2_CONTINUED); + IF NOT T2_CONTINUED THEN + FAILED ("WHEN CALLER WAS ABORTED IN RENDEVOUS, CALLED " & + "TASK DID NOT CONTINUE"); + END IF; + END; + + RESULT; + +END C9A009A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada new file mode 100644 index 000000000..89b7390b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada @@ -0,0 +1,95 @@ +-- C9A009C.ADA + +-- 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 ABORT DURING RENDEZVOUS + +-- THE CALLING TASK IN THE RENDEVOUS IS DEPENDENT ON THE ABORTED TASK, +-- SO THE DEPENDENT TASK IS INDIRECTLY ABORTED WHILE IN A RENDEVOUS; +-- NEITHER THE CALLING TASK NOR ITS MASTER CAN BE TERMINATED WHILE THE +-- RENDEVOUS CONTINUES. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A009C IS + +BEGIN + + TEST("C9A009C", "DEPENDENT TASK IN RENDEVOUS WHEN MASTER IS " & + "ABORTED"); + + DECLARE + -- T2 CONTAINS DEPENDENT TASK T3 WHICH CALLS T1. + -- T1 ABORTS T2 WHILE IN RENDEVOUS WITH T3. + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2; + + TASK BODY T2 IS + TASK T3; + TASK BODY T3 IS + BEGIN + T1.E1; + FAILED ("T3 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T3"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T3"); + END; + BEGIN -- T3 ACTIVATED NOW + NULL; + END T2; + + BEGIN -- T1 + ACCEPT E1 DO + ABORT T2; + ABORT T2; + ABORT T2; -- WHY NOT? + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED PREMATURELY"); + END IF; + END E1; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1 BECAUSE CALLING TASK "& + "WAS ABORTED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION - T1"); + END T1; + + BEGIN + NULL; + END; + + RESULT; + +END C9A009C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada new file mode 100644 index 000000000..e100a9f0c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada @@ -0,0 +1,88 @@ +-- C9A009F.ADA + +-- 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. +--* +-- CHECK THAT A TASK ABORTED DURING AN ENTRY CALL IS NOT TERMINATED +-- BEFORE THE END OF THE RENDEZVOUS. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT,SYSTEM; +USE REPORT,SYSTEM; +PROCEDURE C9A009F IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + +BEGIN + + TEST("C9A009F", "ABORTED TASK NOT TERMINATED BEFORE END OF " & + "RENDEVOUS"); + + DECLARE -- T1 ABORTED WHILE IN RENDEVOUS WITH BLOCKING. + + TASK T1 IS + END T1; + TASK BODY T1 IS + BEGIN + BLOCKING.STOP; + FAILED ("T1 NOT ABORTED"); + END; + + BEGIN + BLOCKING.START; -- ALLOWS T1 TO ENTER RENDEVOUS + + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 1"); + END IF; + + IF T1'TERMINATED THEN -- T1 STILL IN RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 1"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + +END C9A009F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada new file mode 100644 index 000000000..7dea8a4ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada @@ -0,0 +1,95 @@ +-- C9A009G.ADA + +-- 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. +--* +-- CHECK THAT A MASTER ABORTED WITH SUBTASKS IN AN ENTRY CALL BECOMES +-- COMPLETED, BUT NOT TERMINATED, BEFORE THE END OF THE RENDEZVOUS. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT,SYSTEM; +USE REPORT,SYSTEM; +PROCEDURE C9A009G IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + +BEGIN + + TEST("C9A009G", "MASTER COMPLETED BUT NOT TERMINATED"); + + DECLARE -- T1 ABORTED WHILE DEPENDENT TASK IN RENDEVOUS 9C? + + TASK T1 IS + ENTRY LOCK; + END T1; + + TASK BODY T1 IS + TASK T2; + + TASK BODY T2 IS + BEGIN + BLOCKING.STOP; + FAILED ("T2 NOT ABORTED"); + END; + BEGIN + BLOCKING.NO_CALL; -- WILL DEADLOCK UNTIL ABORT + END T1; + + BEGIN + BLOCKING.START; + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 2"); + END IF; + + IF T1'TERMINATED THEN -- T1'S DEPENDENT TASK, T2, STILL IN + -- RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 2"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + +END C9A009G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada new file mode 100644 index 000000000..914fce187 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada @@ -0,0 +1,77 @@ +-- C9A009H.ADA + +-- 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. +--* +-- CHECK THAT A TASK ABORTED DURING A RENDEVOUS IS NEITHER CALLABLE NOR +-- TERMINATED BEFORE THE END OF THE RENDEVOUS. + +-- J.P ROSEN, ADA PROJECT, NYU +-- JBG 6/1/84 + +WITH REPORT; USE REPORT; +PROCEDURE C9A009H IS +BEGIN + TEST ("C9A009H", "TASK ABORTED IN RENDEVOUS IS NOT CALLABLE OR " & + "TERMINATED"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + FAILED ("T2 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN ABORTED TASK"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END T2; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + ABORT T2; + IF T2'CALLABLE THEN + FAILED ("T2 STILL CALLABLE"); + END IF; + + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED"); + END IF; + END E1; + END T1; + + BEGIN + NULL; + END; + + RESULT; + +END C9A009H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada new file mode 100644 index 000000000..553b72d80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada @@ -0,0 +1,89 @@ +-- C9A010A.ADA + +-- 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 ABORT DURING RENDEZVOUS + +-- ABORTING AN ABNORMAL (NOT YET TERMINATED) TASK. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009E-B.ADA +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A010A IS + +BEGIN + + TEST("C9A010A", "ABORTING AN ABNORMAL TASK"); + + DECLARE + -- T1 CALLS T2. WHILE IN RENDEVOUS, T2 ABORTS T1 AND WAITS FOR A + -- CALL FROM THE MAIN PROGRAM. WHEN THE CALL IS ACCEPTED, THE MAIN + -- PROGRAM AGAIN ABORTS T1, WHICH IS NOW ABNORMAL, SINCE T1 HAS NOT + -- YET COMPLETED ITS RENDEVOUS WITH T2. + + TASK T1 IS + END T1; + + TASK T2 IS + ENTRY E1; + ENTRY E2; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ACCEPT E2; -- NOTE CALLER REMAINS IN RENDEVOUS + ACCEPT E2; -- UNTIL TWO ENTRY CALLS ACCEPTED + END E1; + END T2; + BEGIN + T2.E2; -- ONLY ACCEPTED AFTER T1 HAS BEEN ABORTED. + ABORT T1; -- T1 IS ABNORMAL BECAUSE IT IS STILL IN RENDEVOUS. + IF T1'CALLABLE THEN + FAILED ("T1 CALLABLE AFTER BEING ABORTED"); + END IF; + IF T1'TERMINATED THEN + FAILED ("T1 TERMINATED ALTHOUGH IN RENDEVOUS"); + END IF; + T2.E2; -- T1'S RENDEVOUS CAN NOW COMPLETE; T1 CAN TERMINATE. + END; + + RESULT; + +END C9A010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada new file mode 100644 index 000000000..1d415b07b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada @@ -0,0 +1,71 @@ +-- C9A011A.ADA + +-- 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 IF A CALLED TASK IS ABORTED WHILE IN RENDEZVOUS, THEN +-- "TASKING_ERROR" IS RAISED IN THE CALLING TASK. + +-- HISTORY: +-- DHH 03/28/88 CREATED ORIGINAL TEST. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A011A IS + + TASK TYPE CHOICE IS + ENTRY E1; + END CHOICE; + + T : CHOICE; + + TASK BODY CHOICE IS + X : INTEGER; + BEGIN + ACCEPT E1 DO + X := IDENT_INT(3); + IF EQUAL(X,X) THEN + ABORT CHOICE; + END IF; + END E1; + END CHOICE; + +BEGIN + + TEST("C9A011A", "CHECK THAT IF A CALLED TASK IS ABORTED WHILE " & + "IN RENDEZVOUS, THEN ""TASKING_ERROR"" IS " & + "RAISED IN THE CALLING TASK"); + + T.E1; + FAILED("EXCEPTION NOT RAISED ON ABORT"); + + RESULT; + +EXCEPTION + WHEN TASKING_ERROR => + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED ON ABORT"); + RESULT; +END C9A011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada new file mode 100644 index 000000000..fe1ba1649 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada @@ -0,0 +1,102 @@ +-- C9A011B.ADA + +-- 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 "TASKING_ERROR" IS RAISED BY A TIMED ENTRY CALL IF +-- THE CALLED TASK IS ABORTED BEFORE THE DELAY EXPIRES BUT NOT +-- WHEN THE CALL IS FIRST EXECUTED. + +-- HISTORY: +-- DHH 06/14/88 CREATED ORIGINAL TEST. + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A011B IS + + TASK TIMED_ENTRY IS + ENTRY WAIT_AROUND; + END TIMED_ENTRY; + + TASK OWNER IS + ENTRY START; + ENTRY SELF_ABORT; + END OWNER; + + TASK BODY TIMED_ENTRY IS + BEGIN + SELECT + OWNER.SELF_ABORT; + OR + DELAY 60.0 * Impdef.One_Second; + END SELECT; + FAILED("NO EXCEPTION RAISED"); + + ACCEPT WAIT_AROUND; + EXCEPTION + WHEN TASKING_ERROR => + ACCEPT WAIT_AROUND; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + ACCEPT WAIT_AROUND; + END TIMED_ENTRY; + + TASK BODY OWNER IS + BEGIN + ACCEPT START DO + WHILE SELF_ABORT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + END START; + + ABORT OWNER; + + ACCEPT SELF_ABORT; + + END OWNER; + +BEGIN + + TEST("C9A011B", "CHECK THAT ""TASKING_ERROR"" IS RAISED BY A " & + "TIMED ENTRY CALL IF THE CALLED TASK IS " & + "ABORTED BEFORE THE DELAY EXPIRES BUT NOT " & + "WHEN THE CALL IS FIRST EXECUTED"); + + OWNER.START; + DELAY 5.0 * Impdef.One_Second; + + IF TIMED_ENTRY'CALLABLE THEN + TIMED_ENTRY.WAIT_AROUND; + ELSE + FAILED("TASK ABORTED WHEN TASKING ERROR IS RAISED"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED OUTSIDE OF TASK"); + RESULT; + +END C9A011B; |