| -- 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; |
