1-- C390002.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that a tagged base type may be declared, and derived 28-- from in simple, private and extended forms. (Overlaps with C390B04) 29-- Check that the package Ada.Tags is present and correctly implemented. 30-- Check for the correct operation of Expanded_Name, External_Tag and 31-- Internal_Tag within that package. Check that the exception Tag_Error 32-- is correctly raised on calling Internal_Tag with bad input. 33-- 34-- TEST DESCRIPTION: 35-- This test declares a tagged type, and derives three types from it. 36-- These types are then used to test the presence and function of the 37-- package Ada.Tags. 38-- 39-- 40-- CHANGE HISTORY: 41-- 06 Dec 94 SAIC ACVC 2.0 42-- 19 Dec 94 SAIC Removed RM references from objective text. 43-- 27 Jan 96 SAIC Update RM references for 2.1 44-- 45--! 46 47with Report; 48with Ada.Tags; 49 50procedure C390002 is 51 52 package Vehicle is 53 54 type Object is tagged limited private; -- ancestor type 55 procedure Create( The_Vehicle : in out Object; Wheels : in Natural ); 56 function Wheels( The_Vehicle : Object ) return Natural; 57 58 private 59 60 type Object is tagged limited record 61 Wheel_Count : Natural := 0; 62 end record; 63 64 end Vehicle; 65 66 package Motivators is 67 68 type Bicycle is new Vehicle.Object with null record; -- simple 69 70 type Car is new Vehicle.Object with record -- extended 71 Convertible : Boolean; 72 end record; 73 74 type Truck is new Vehicle.Object with private; -- private 75 76 private 77 78 type Truck is new Vehicle.Object with record 79 Air_Horn : Boolean; 80 end record; 81 82 end Motivators; 83 84 package body Vehicle is 85 86 procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is 87 begin 88 The_Vehicle.Wheel_Count := Wheels; 89 end Create; 90 91 function Wheels( The_Vehicle : Object ) return Natural is 92 begin 93 return The_Vehicle.Wheel_Count; 94 end Wheels; 95 96 end Vehicle; 97 98 function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is 99 begin 100 return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) ); 101 Report.Comment("This message intentionally blank."); 102 end TC_ID_Tag; 103 104 procedure Check_Tags( Machine : in Vehicle.Object'Class; 105 Expected_Name : in String; 106 External_Tag : in String ) is 107 The_Tag : constant Ada.Tags.Tag := Machine'Tag; 108 use type Ada.Tags.Tag; 109 begin 110 if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then 111 Report.Failed ("Failed in Check_Tags, Expanded_Name " 112 & Expected_Name); 113 end if; 114 if Ada.Tags.External_Tag(The_Tag) /= External_Tag then 115 Report.Failed ("Failed in Check_Tags, External_Tag " 116 & Expected_Name); 117 end if; 118 if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then 119 Report.Failed ("Failed in Check_Tags, Internal_Tag " 120 & Expected_Name); 121 end if; 122 end Check_Tags; 123 124 procedure Check_Exception is 125 Boeing_777_Id : Ada.Tags.Tag; 126 begin 127 Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!"); 128 Report.Failed ("Failed in Check_Exception, no exception"); 129 Boeing_777_Id := TC_ID_Tag( Boeing_777_Id ); 130 exception 131 when Ada.Tags.Tag_Error => null; 132 when others => 133 Report.Failed ("Failed in Check_Exception, wrong exception"); 134 end Check_Exception; 135 136 use Motivators; 137 Two_Wheeler : Bicycle; 138 Four_Wheeler : Car; 139 Eighteen_Wheeler : Truck; 140 141begin -- Main test procedure. 142 143 Report.Test ("C390002", "Check that a tagged type may be declared and " & 144 "derived from in simple, private and extended forms. " & 145 "Check package Ada.Tags" ); 146 147 Create( Two_Wheeler, 2 ); 148 Create( Four_Wheeler, 4 ); 149 Create( Eighteen_Wheeler, 18 ); 150 151 Check_Tags( Machine => Two_Wheeler, 152 Expected_Name => "C390002.MOTIVATORS.BICYCLE", 153 External_Tag => Bicycle'External_Tag ); 154 Check_Tags( Machine => Four_Wheeler, 155 Expected_Name => "C390002.MOTIVATORS.CAR", 156 External_Tag => Car'External_Tag ); 157 Check_Tags( Machine => Eighteen_Wheeler, 158 Expected_Name => "C390002.MOTIVATORS.TRUCK", 159 External_Tag => Truck'External_Tag ); 160 161 Check_Exception; 162 163 Report.Result; 164 165end C390002; 166