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, 366 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a new file mode 100644 index 000000000..a01ebfc32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11018.a @@ -0,0 +1,366 @@ +-- 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; |