diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/ca/ca11018.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/ca/ca11018.a | 366 |
1 files changed, 0 insertions, 366 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a deleted file mode 100644 index a01ebfc32a4..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11018.a +++ /dev/null @@ -1,366 +0,0 @@ --- CA11018.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 body of the parent package may depend on one of its own --- public generic children. --- --- TEST DESCRIPTION: --- A scenario is created that demonstrates the potential of adding a --- public generic child during code maintenance without distubing a large --- subsystem. After child is added to the subsystem, a maintainer --- decides to take advantage of the new functionality and rewrites --- the parent's body. --- --- Declare a message application in a package which highlights some --- key words. Declare a public generic child of this package which adds --- functionality to the original subsystem. In the parent body, --- instantiate the child. --- --- In the main program, check that the operations in the parent, --- and instances of the public child package perform as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst. --- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 --- ---! - --- Simulates application which displays messages. - -package CA11018_0 is - - type Designated_Num is new Integer range 0 .. 100; - - type Particularly_Designated_Num is new Integer range 0 .. 100; - - type Message is new String; - - type Message_Rec is tagged private; - - type Designated_Msg is new Message_Rec with private; - - type Particularly_Designated_Msg is new Message_Rec with private; - - -- Analyzes message for presence of word in the secret message. If found, - -- word is highlighted. - - procedure Highlight_Designated (The_Word : in Message; - In_The_Message : in out Designated_Msg); - - - -- Analyzes message for presence of word in the secret message. If found, - -- word is highlighted and do other actions. - - procedure Highlight_Particularly_Designated - (The_Word : in Message; - In_The_Message : in out Particularly_Designated_Msg); - - - -- Begin test code declarations: ----------------------- - - TC_Designated_Not_Zero : Boolean := false; - - TC_Particularly_Designated_Not_Zero : Boolean := false; - - -- The following two functions are used to check for function - -- calls from the public generic child. - - function TC_Designated_Success return Boolean; - - function TC_Particularly_Designated_Success return Boolean; - - -- End test code declarations. ------------------------- - -private - type Message_Rec is tagged - record - The_Length : natural := 0; - The_Content : Message (1 .. 60); - end record; - - type Designated_Msg is new Message_Rec with null record; - -- ... More components in real application. - - type Particularly_Designated_Msg is new Message_Rec with null record; - -- ... More components in real application. - -end CA11018_0; - - --=================================================================-- - - --- Public generic child package of message display application. Imagine that --- messages of one security level are associated with a type derived from --- integer. For overall system security, messages of a different security --- level are associated with a different type derived from integer. By --- instantiating this package for each security level, the results of Count --- applied to one kind of message cannot inadvertently be compared with the --- results applied to a different kind. - -generic - type Msg_Type is new Message_Rec with private; - -- Derived from parent's type. - type Count is range <>; - -package CA11018_0.CA11018_1 is - - TC_Function_Called : Boolean := false; - - function Find_Word (Wrd : in Message; - Msg : in Msg_Type) return Count; - -end CA11018_0.CA11018_1; - - --=================================================================-- - -package body CA11018_0.CA11018_1 is - - function Find_Word (Wrd : in Message; - Msg : in Msg_Type) return Count is - - Num : Count := Count'first; - - -- Count how many time the word appears within the given message. - - begin - -- ... Error-checking code omitted for brevity. - - for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop - -- Parent's private type - if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd - -- Parent's private type - then - Num := Num + 1; - end if; - - end loop; - - TC_Function_Called := true; - - return (Num); - - end Find_Word; - -end CA11018_0.CA11018_1; - - --=================================================================-- - -with CA11018_0.CA11018_1; -- Public generic child. - -pragma Elaborate (CA11018_0.CA11018_1); -package body CA11018_0 is - - ---------------------------------------------------- - -- Parent's body depends on public generic child. -- - ---------------------------------------------------- - - -- Instantiate the public child for the secret message. - - package Designated_Pkg is new CA11018_0.CA11018_1 - (Msg_Type => Designated_Msg, Count => Designated_Num); - - -- Instantiate the public child for the top secret message. - - package Particularly_Designated_Pkg is new CA11018_0.CA11018_1 - (Particularly_Designated_Msg, Particularly_Designated_Num); - - -- End instantiations. ----------------------------- - - - function TC_Designated_Success return Boolean is - -- Check to see if the function in the public generic child is called. - - begin - return Designated_Pkg.TC_Function_Called; - end TC_Designated_Success; - -------------------------------------------------------------- - function TC_Particularly_Designated_Success return Boolean is - -- Check to see if the function in the public generic child is called. - - begin - return Particularly_Designated_Pkg.TC_Function_Called; - end TC_Particularly_Designated_Success; - -------------------------------------------------------------- - -- Calls functions from public child to search for a key word. - -- If the word appears more than once in each message, - -- highlight all of them. - - procedure Highlight_Designated (The_Word : in Message; - In_The_Message : in out Designated_Msg) is - - -- Not a real highlight procedure. Real application can use graphic - -- device to highlight all occurrences of words. - - begin - -------------------------------------------------------------- - -- Parent's body uses function from instantiation of public -- - -- generic child. -- - -------------------------------------------------------------- - - if Designated_Pkg.Find_Word -- Child's operation. - (The_Word, In_The_Message) > 0 then - - -- Highlight all occurrences in lavender. - - TC_Designated_Not_Zero := true; - end if; - - end Highlight_Designated; - -------------------------------------------------------------- - procedure Highlight_Particularly_Designated - (The_Word : in Message; - In_The_Message : in out Particularly_Designated_Msg) is - - -- Not a real highlight procedure. Real application can use graphic - -- device to highlight all occurrences of words. - - begin - -------------------------------------------------------------- - -- Parent's body uses function from instantiation of public -- - -- generic child. -- - -------------------------------------------------------------- - - if Particularly_Designated_Pkg.Find_Word -- Child's operation. - (The_Word, In_The_Message) > 0 then - - -- Highlight all occurrences in chartreuse. - -- Do other more secret stuff. - - TC_Particularly_Designated_Not_Zero := true; - end if; - - end Highlight_Particularly_Designated; - -end CA11018_0; - - --=================================================================-- - --- Public generic child to copy words to the messages. - -generic - type Message_Type is new Message_Rec with private; - -- Derived from parent's type. - -package CA11018_0.CA11018_2 is - - procedure Copy (From_The_Word : in Message; - To_The_Message : in out Message_Type); - -end CA11018_0.CA11018_2; - - --=================================================================-- - -package body CA11018_0.CA11018_2 is - - procedure Copy (From_The_Word : in Message; - To_The_Message : in out Message_Type) is - - -- Copy words to the appropriate messages. - - begin - To_The_Message.The_Content -- Parent's private type. - (1 .. From_The_Word'length) := From_The_Word; - - To_The_Message.The_Length -- Parent's private type. - := From_The_Word'length; - end Copy; - -end CA11018_0.CA11018_2; - - --=================================================================-- - -with Report; - -with CA11018_0.CA11018_2; -- Public generic child package, copy words - -- to the message. - -- Implicit with parent package (CA11018_0). - -procedure CA11018 is - - package Message_Pkg renames CA11018_0; - -begin - - Report.Test ("CA11018", "Check that body of the parent package can " & - "depend on one of its own public generic children"); - --- Highlight the word "Alert" from the secret message. - - Designated_Subtest: - declare - The_Message : Message_Pkg.Designated_Msg; -- Parent's private type. - - -- Instantiate the public child to copy words to the secret message. - - package Copy_Designated_Pkg is new CA11018_0.CA11018_2 - (Message_Pkg.Designated_Msg); - - begin - Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard", - To_The_Message => The_Message); - - Message_Pkg.Highlight_Designated ("Alert", The_Message); - - if not Message_Pkg.TC_Designated_Not_Zero and - Message_Pkg.TC_Designated_Success then - Report.Failed ("Alert should have been highlighted"); - end if; - - end Designated_Subtest; - --- Highlight the word "Push The Alarm" from the top secret message. - - Particularly_Designated_Subtest: - declare - The_Message : Message_Pkg.Particularly_Designated_Msg ; - -- Parent's private type. - - -- Instantiate the public child to copy words to the top secret - -- message. - - package Copy_Particularly_Designated_Pkg is new - CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg); - - begin - Copy_Particularly_Designated_Pkg.Copy - ("Alert Level 10 : Alert The Guard and Push The Alarm", - The_Message); - - Message_Pkg.Highlight_Particularly_Designated - ("Push The Alarm", The_Message); - - if not Message_Pkg.TC_Particularly_Designated_Not_Zero and - Message_Pkg.TC_Particularly_Designated_Success then - Report.Failed ("Key words should have been highlighted"); - end if; - - end Particularly_Designated_Subtest; - - Report.Result; - -end CA11018; |