gcc/testsuite/ada/acats/tests/c3/c390002.a

   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
  47 with Report;
  48 with Ada.Tags;
  49
  50 procedure 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
 141 begin  -- 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
 165 end C390002;