-- CD30014.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. 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 ACAA 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.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
-- OBJECTIVES:
--     Check that Program_Error is raised if two distinct declarations of
--     tagged types have the same external tag. Part 2: Aspect specifications.
--
-- TEST DESCRIPTION:
--     This test models a unit defining a tagged type including dispatching and
--     class-wide operations, along with its associated unit test. The unit
--     test defines an extension of the basic tagged type; the programmer used
--     cut-and-paste to do so and forgot to change the external tag of the
--     tagged type. This error should be detected; if it is not, then
--     class-wide stream-oriented attributes as well as some operations of
--     package Ada.Tags could malfunction. (We don't test such operations as
--     they are unnecessary to test the objective, but they are often used
--     with tagged types.) 
--
-- APPLICABILITY CRITERIA:
--     All implementations must attempt to compile this test.
--
--     For an implementation that takes advantage of 13.3(76.1/3) to
--     detect this error, either:
--        * This test may report compile time errors at one or more points
--          indicated by "-- OPTIONAL ERROR:", in which case it may be graded
--          as passed; or
--        * The test may report a link time error message that the partition
--          includes multiple tagged types with the same external name, in
--          which case it may be graded as passed.
--
--     For all other implementations, this test must execute and report PASSED.
--
--     Note for the users of the ACATS grading tools: This C-Test can act like
--     a B-Test or L-Test for implementations that take advantage of
--     13.3(76.1/3). As the grading tools will treat this as a C-Test, such
--     an implementation will need to put this test on their manual grading
--     list.
--
-- CHANGE HISTORY:
--     30 Dec 21  RLB  Created test.
--!

package CD30014_0 is

   type My_Root_Type is tagged private;
   
   function Is_OK (Obj : in My_Root_Type) return Boolean;
   
   procedure Do_It (Obj : in out My_Root_Type'Class);

private
   type My_Root_Type is tagged null record
      with External_Tag => "My_Type";
end CD30014_0;

with Report;
package body CD30014_0 is

   function Is_OK (Obj : in My_Root_Type) return Boolean is
   begin
      return True;
   end Is_OK;
   
   procedure Do_It (Obj : in out My_Root_Type'Class) is
   begin
      if Is_OK (Obj) then
         Report.Comment ("OK Obj");
      else
         Report.Failed ("Not OK Obj");
      end if;
   end Do_It;
      
end CD30014_0;

with Report;
with CD30014_0;
procedure CD30014 is
begin
   Report.Test ("CD30014", "Check that Program_Error is raised if two " &
                           "distinct declarations of tagged types have the " &
                           "same external tag. Part 2: Aspect " &
                           "specifications");
                           
   if CD30014_0.My_Root_Type'External_Tag /= "My_Type" then
      Report.Failed ("Ineffective specification of External_Tag for root " &
                     " type - have " & CD30014_0.My_Root_Type'External_Tag);
   end if;
   declare
      package P1 is
         type Test_Type is new CD30014_0.My_Root_Type with null record
            with External_Tag => "Test_Type";
   
         function Is_OK (Obj : in Test_Type) return Boolean is (True);
      end P1;
      
      An_Object : P1.Test_Type;    
   begin
      CD30014_0.Do_It (An_Object);
      if P1.Test_Type'External_Tag /= "Test_Type" then
          Report.Failed ("Ineffective specification of External_Tag for " &
                         "test type - have " & P1.Test_Type'External_Tag);
      end if;
   end;   

   begin
      declare
         package P2 is
            type My_Type is new CD30014_0.My_Root_Type with null record
                with External_Tag => "My_Type"; -- OPTIONAL ERROR: {22}
      
            function Is_OK (Obj : in My_Type) return Boolean is (False);
         end P2;
         
         An_Object : P2.My_Type;    
      begin
         -- Should not get here.
         if P2.My_Type'External_Tag /= "My_Type" then
             Report.Failed ("Ineffective specification of External_Tag for " &
                            "my type - have " & P2.My_Type'External_Tag);
         end if;
         CD30014_0.Do_It (An_Object); -- Should report failed.
         Report.Failed ("Program_Error not raised by conflicting " & 
                        "External_Tag specifications");         
   end;   
   exception
      when Program_Error =>
         Report.Comment ("Program_Error raised as expected for conflicting " &
                         "external tags");
   end;
   Report.Result;
end CD30014;