diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c9')
64 files changed, 0 insertions, 17406 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910001.a b/gcc/testsuite/ada/acats/tests/c9/c910001.a deleted file mode 100644 index 416e13ca8fb..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c910001.a +++ /dev/null @@ -1,224 +0,0 @@ --- 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 deleted file mode 100644 index dc0b9b36bba..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c910002.a +++ /dev/null @@ -1,143 +0,0 @@ --- 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 deleted file mode 100644 index b2e11cef826..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c910003.a +++ /dev/null @@ -1,185 +0,0 @@ --- 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/c930001.a b/gcc/testsuite/ada/acats/tests/c9/c930001.a deleted file mode 100644 index 87451899021..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c930001.a +++ /dev/null @@ -1,153 +0,0 @@ --- 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/c940001.a b/gcc/testsuite/ada/acats/tests/c9/c940001.a deleted file mode 100644 index 2bc1a9ffd03..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940001.a +++ /dev/null @@ -1,212 +0,0 @@ --- 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 deleted file mode 100644 index 420f54440ed..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940002.a +++ /dev/null @@ -1,309 +0,0 @@ --- 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 deleted file mode 100644 index 059c97f41b6..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940004.a +++ /dev/null @@ -1,416 +0,0 @@ --- 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 deleted file mode 100644 index adb58b18ca4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940005.a +++ /dev/null @@ -1,370 +0,0 @@ --- 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.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 deleted file mode 100644 index 36e6c9171a6..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940006.a +++ /dev/null @@ -1,223 +0,0 @@ --- 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 deleted file mode 100644 index c678463633a..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940007.a +++ /dev/null @@ -1,427 +0,0 @@ --- 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.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 deleted file mode 100644 index c4a670552d4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940010.a +++ /dev/null @@ -1,269 +0,0 @@ --- 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 deleted file mode 100644 index 65228666cd3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940011.a +++ /dev/null @@ -1,175 +0,0 @@ --- 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 deleted file mode 100644 index d4bd2079cb2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940012.a +++ /dev/null @@ -1,174 +0,0 @@ --- 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 deleted file mode 100644 index 58d34bc9697..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940013.a +++ /dev/null @@ -1,379 +0,0 @@ --- 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 deleted file mode 100644 index 0eb53ea5127..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940014.a +++ /dev/null @@ -1,177 +0,0 @@ --- 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 deleted file mode 100644 index 92a6699c3d4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940015.a +++ /dev/null @@ -1,149 +0,0 @@ --- 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 deleted file mode 100644 index 2226eefb40d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940016.a +++ /dev/null @@ -1,211 +0,0 @@ --- 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/c940a03.a b/gcc/testsuite/ada/acats/tests/c9/c940a03.a deleted file mode 100644 index 22876d26b18..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940a03.a +++ /dev/null @@ -1,350 +0,0 @@ --- 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/c951001.a b/gcc/testsuite/ada/acats/tests/c9/c951001.a deleted file mode 100644 index c1cf96593b2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c951001.a +++ /dev/null @@ -1,192 +0,0 @@ --- 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 deleted file mode 100644 index 8ccb2d012fe..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c951002.a +++ /dev/null @@ -1,334 +0,0 @@ --- 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.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.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.Switch_To_New_Task; - - Debit_Message.TC_Start; - - while not Debit_Task'terminated loop - delay ImpDef.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 deleted file mode 100644 index bc9c85f302f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c953001.a +++ /dev/null @@ -1,188 +0,0 @@ --- 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 deleted file mode 100644 index d821bb24e4e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c953002.a +++ /dev/null @@ -1,242 +0,0 @@ --- 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 deleted file mode 100644 index 4ac91169e21..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c953003.a +++ /dev/null @@ -1,189 +0,0 @@ --- 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 deleted file mode 100644 index 3112cce2b5c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954001.a +++ /dev/null @@ -1,273 +0,0 @@ --- 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 deleted file mode 100644 index ac39c89a838..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954010.a +++ /dev/null @@ -1,286 +0,0 @@ --- 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 deleted file mode 100644 index 159b32dba58..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954011.a +++ /dev/null @@ -1,384 +0,0 @@ --- 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 deleted file mode 100644 index 44575b1b1e5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954012.a +++ /dev/null @@ -1,496 +0,0 @@ --- 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 deleted file mode 100644 index a9de8c56b12..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954013.a +++ /dev/null @@ -1,521 +0,0 @@ --- 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 deleted file mode 100644 index 53e45a090dd..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954014.a +++ /dev/null @@ -1,485 +0,0 @@ --- 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 deleted file mode 100644 index c86e1078e79..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954015.a +++ /dev/null @@ -1,549 +0,0 @@ --- 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 deleted file mode 100644 index 1390801eec0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954016.a +++ /dev/null @@ -1,182 +0,0 @@ --- 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 deleted file mode 100644 index a5447a756c5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954017.a +++ /dev/null @@ -1,184 +0,0 @@ --- 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 deleted file mode 100644 index a9da1e06bad..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954018.a +++ /dev/null @@ -1,227 +0,0 @@ --- 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 deleted file mode 100644 index fafc6aa591f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954019.a +++ /dev/null @@ -1,314 +0,0 @@ --- 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 deleted file mode 100644 index bc08a6bd4c2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954020.a +++ /dev/null @@ -1,422 +0,0 @@ --- 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 deleted file mode 100644 index 626f2f970a2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954021.a +++ /dev/null @@ -1,524 +0,0 @@ --- 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 deleted file mode 100644 index 5ebff8dcb0f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954022.a +++ /dev/null @@ -1,351 +0,0 @@ --- 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 deleted file mode 100644 index bfa69dc6054..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954023.a +++ /dev/null @@ -1,558 +0,0 @@ --- 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 deleted file mode 100644 index 7f19a818322..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954024.a +++ /dev/null @@ -1,380 +0,0 @@ --- 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 deleted file mode 100644 index f48d4cd9096..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954025.a +++ /dev/null @@ -1,237 +0,0 @@ --- 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_Second; - Plenty_Of_Time : constant Duration := - Countdown_Amount + ImpDef.Clear_Ready_Queue + 1.0 * Impdef.One_Second; - Not_Enough_Time : constant Duration := - Countdown_Amount - 0.5 * Impdef.One_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 deleted file mode 100644 index 881b74af81c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954026.a +++ /dev/null @@ -1,269 +0,0 @@ --- 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_Second; - Plenty_Of_Time : constant Duration := - Allowed_Time + Impdef.Clear_Ready_Queue + 1.0 * Impdef.One_Second; - Not_Enough_Time : constant Duration := Allowed_Time - 0.5 * Impdef.One_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 deleted file mode 100644 index 34f48b29171..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954a01.a +++ /dev/null @@ -1,262 +0,0 @@ --- 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.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.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 deleted file mode 100644 index 7d61aea8c23..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954a02.a +++ /dev/null @@ -1,259 +0,0 @@ --- 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 deleted file mode 100644 index 13d21311c7b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c954a03.a +++ /dev/null @@ -1,322 +0,0 @@ --- 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 deleted file mode 100644 index 4eaa1f49ff1..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c960001.a +++ /dev/null @@ -1,164 +0,0 @@ --- 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 deleted file mode 100644 index 06edaf0c9d5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c960002.a +++ /dev/null @@ -1,171 +0,0 @@ --- 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 deleted file mode 100644 index f394aab66fc..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c960004.a +++ /dev/null @@ -1,206 +0,0 @@ --- 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/c974001.a b/gcc/testsuite/ada/acats/tests/c9/c974001.a deleted file mode 100644 index 04ac93e6d8f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974001.a +++ /dev/null @@ -1,152 +0,0 @@ --- 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 deleted file mode 100644 index 1138e8da3bc..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974002.a +++ /dev/null @@ -1,209 +0,0 @@ --- 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 deleted file mode 100644 index c353a918db1..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974003.a +++ /dev/null @@ -1,249 +0,0 @@ --- 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 deleted file mode 100644 index b1200c10368..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974004.a +++ /dev/null @@ -1,273 +0,0 @@ --- 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 deleted file mode 100644 index 196a8edc04c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974005.a +++ /dev/null @@ -1,259 +0,0 @@ --- 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 deleted file mode 100644 index f6f4d92e869..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974006.a +++ /dev/null @@ -1,197 +0,0 @@ --- 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 deleted file mode 100644 index 07007b9bb56..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974007.a +++ /dev/null @@ -1,205 +0,0 @@ --- 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 deleted file mode 100644 index b76db7bd05e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974008.a +++ /dev/null @@ -1,229 +0,0 @@ --- 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 deleted file mode 100644 index 419f2a3e9ad..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974009.a +++ /dev/null @@ -1,206 +0,0 @@ --- 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 deleted file mode 100644 index caeb9d57059..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974010.a +++ /dev/null @@ -1,209 +0,0 @@ --- 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 deleted file mode 100644 index 4682db6286d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974011.a +++ /dev/null @@ -1,275 +0,0 @@ --- 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 deleted file mode 100644 index 4e43c72a842..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974012.a +++ /dev/null @@ -1,165 +0,0 @@ --- 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 deleted file mode 100644 index 4a930da93b3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974013.a +++ /dev/null @@ -1,167 +0,0 @@ --- 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 deleted file mode 100644 index 03ca915f896..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c974014.a +++ /dev/null @@ -1,132 +0,0 @@ --- 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 deleted file mode 100644 index 3bd4196f0ec..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c980001.a +++ /dev/null @@ -1,303 +0,0 @@ --- 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 deleted file mode 100644 index f2b9c52479c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c980002.a +++ /dev/null @@ -1,165 +0,0 @@ --- 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 deleted file mode 100644 index dd69fc7ee68..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c980003.a +++ /dev/null @@ -1,294 +0,0 @@ --- 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; |