path: root/gcc/testsuite/ada/acats-4/tests/c3/c3a10042.am

-- C3A10042.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.
--
--*
-- OBJECTIVE:
--      See C3A10040.A.
--
-- TEST DESCRIPTION:
--      See C3A10040.A.
--
-- SPECIAL REQUIREMENTS:
--      See C3A10040.A.
--
-- TEST FILES:
--      This test consists of the following files:
--         C3A10040.A
--         C3A10041.A
--      -> C3A10042.AM
--
--  CHANGE HISTORY:
--    12 Jan 2015 RLB Created test, using example of AI95-0217-6 as a basis.
--    13 Mar 2015 RLB Eliminated overlong lines.
--
--!
with Report;
with C3A1004E; use C3A1004E;
package body C3A1004D is -- Departments

   procedure Choose_Manager
     (D       : in out Department;
      Manager :    out Emp_Ptr) is
   begin
      Manager := D.List (1);
   end Choose_Manager;

   procedure Create (D : in out Department; Name : in String) is
   begin
      if Name'Length > D.Id'Length then
         D.Id := Name(Name'First .. Name'First + D.Id'Length - 1);
      else
         D.Id := Name & (Name'Length+1 .. D.Id'Length => ' ');
      end if;
   end Create;

   procedure Display (D : in Department) is
   begin
      Report.Comment ("Department: " & D.Id);
      for I in 1 .. D.Tot loop
         Display (D.List (I).all);
      end loop;
   end Display;

   function Image (D : in Department) return String is
   begin
      return "Department: " & D.Id;
   end Image;

   procedure Appoint
     (E : in out C3A1004E.Employee'Class;
      D : in out Department) is
   begin
      if D.During_Mod then
          return; -- We're already updating this (need to break recursion).
      end if;
      if Current_Department (E) /= null then
         -- Remove from old department:
         declare
            Old : C3A1004E.Dept_Ptr := Current_Department (E);
         begin
            for I in 1 .. Old.Tot loop
               if Old.List(I) = E'Unchecked_Access then
                  Old.List(I..4) := Old.List(I+1..5);
                  Old.Tot := Old.Tot - 1;
               end if;
            end loop;
         end;
      end if;
      if D.Tot = 5 then
         raise Constraint_Error;
      else
         D.During_Mod := True; -- Starting update.
         D.Tot := D.Tot + 1;
         D.List (D.Tot) := E'Unchecked_Access;
         Assign_Employee (E, D); -- Could call Appoint again.
         D.During_Mod := False; -- Done with update.
      end if;
   end Appoint;

   function Is_Member
    (E : in C3A1004E.Employee'Class;
     D : in Department) return Boolean is
      use type Employee;
   begin
      for I in 1 .. D.Tot loop
         if D.List (I).all = E then
            return True;
         end if;
      end loop;
      return False;
   end Is_Member;

end C3A1004D;

-- ----------------------------------------------------------------------------

with Report;
with C3A1004D;
package body C3A1004E is -- Employees

   procedure Assign_Employee
     (E : in out Employee;
      D : in out C3A1004D.Department'Class) is
   begin
      if E.During_Mod then
          return; -- We're already updating this (need to break recursion).
      end if;
--Report.Comment ("Assign Employee: " & E.Id.all & " to " & C3A1004D.Image(D));
      if E.Dept /= D'Unchecked_Access then
         E.During_Mod := True;
         C3A1004D.Appoint (E, D); -- Could call Assign_Employee again.
         E.Dept := D'Unchecked_Access;
         E.During_Mod := False;
      -- else already right, do nothing.
      end if;
   end Assign_Employee;

   function Current_Department
     (E : in Employee) return Dept_Ptr is
   begin
      return E.Dept;
   end Current_Department;

   function Hire (Id : String) return Emp_Ptr is
      Ptr : Emp_Ptr := new Employee;
   begin
      Ptr.Id := new String'(Id);
      return Ptr;
   end Hire;

   procedure Display (E : Employee) is
   begin
      Report.Comment ("Employee: " & E.Id.all);
   end Display;

   function Image (E : Employee) return String is
   begin
      return "Employee: " & E.Id.all;
   end Image;

   function Image (E : Employee;
                   D : C3A1004D.Department'Class) return String is
      use type C3A1004D.Department'Class;
   begin
      if D /= E.Dept.all then
         return "Wrong department for " & Image (E);
      else
         return Image (E) & " of " & C3A1004D.Image(D);
      end if;
   end Image;
end C3A1004E;

-- ----------------------------------------------------------------------------

-- Note: No with of C3A1004D (departments); inherits a limited with
-- from the parent.
package C3A1004E.Child is -- Employee operations

    procedure Recruit (D : access C3A1004D.Department'Class;
                       E : in out C3A1004E.Employee'Class);
       -- Recruit E for D.

    procedure Join (D : in out C3A1004D.Department'Class;
                    E : in out C3A1004E.Employee'Class);
       -- E joins D.

    function Image (D : in C3A1004D.Department'Class;
                    E : in C3A1004E.Employee'Class) return String;

end C3A1004E.Child;

-- ----------------------------------------------------------------------------

package body C3A1004E.Child is -- Employee operations

    procedure Recruit (D : access C3A1004D.Department'Class;
                       E : in out C3A1004E.Employee'Class) is
    begin
       C3A1004E.Assign_Employee (E, D.all);
    end Recruit;

    procedure Join (D : in out C3A1004D.Department'Class;
                    E : in out C3A1004E.Employee'Class) is
    begin
       C3A1004E.Assign_Employee (E, D);
    end Join;

    function Image (D : in C3A1004D.Department'Class;
                    E : in C3A1004E.Employee'Class) return String is
    begin
       return Image (E, D);
    end Image;

end C3A1004E.Child;

-- ----------------------------------------------------------------------------

with Report;
with C3A1004D; use C3A1004D;
with C3A1004E; use C3A1004E;
with C3A1004E.Child;
procedure C3A10042 is
   Dept1, Dept2, Dept3 : aliased Department;
   E1, E2, E3, E4, E5, E6 : C3A1004E.Emp_Ptr;
begin
   Report.Test ("C3A1004", "Check that a parameter of a " &
                           "tagged incomplete type can be passed " &
                           "directly as a parameter");

   E1 := Hire ("Rodgers");
   E2 := Hire ("Nelson");
   E3 := Hire ("Cobb");
   E4 := Hire ("Shields");
   E5 := Hire ("Matthews");
   E6 := Hire ("Hyde");

   Create (Dept1, "Offense");
   Create (Dept2, "Defense");
   Create (Dept3, "Special-Teams");

   -- Sorry, it's NFL playoff season. :-)

   Appoint (E1.all, Dept1);
   Appoint (E2.all, Dept1);
   --Display (Dept1);

   Appoint (E4.all, Dept2);
   Appoint (E5.all, Dept2);
   --Display (Dept2);

   Appoint (E3.all, Dept3);
   Appoint (E6.all, Dept3);
   --Display (Dept3);

   if not Is_Member (E1.all, Dept1) then
      Report.Failed ("Rodgers not on offense!");
   end if;
   if Is_Member (E4.all, Dept1) then
      Report.Failed ("Shields on offense!");
   end if;
   if not Is_Member (E6.all, Dept3) then
      Report.Failed ("Hyde not on special teams!");
   end if;

   C3A1004E.Child.Recruit (Dept2'Unchecked_Access, E6.all);
                                             -- Move Hyde to Defense.

   C3A1004E.Child.Join (Dept1, E3.all);      -- Move Cobb to Offense.

   if not Is_Member (E3.all, Dept1) then
      Report.Failed ("Cobb not on offense!");
   end if;
   if not Is_Member (E6.all, Dept2) then
      Report.Failed ("Hyde not on defense!");
   end if;

   if C3A1004E.Child.Image (Dept2, E5.all) /=
      "Employee: Matthews of Department: Defense      " then
      Report.Failed ("Wrong image (1): " &
                     C3A1004E.Child.Image (Dept2, E5.all));
   end if;

   if C3A1004E.Child.Image (Dept3, E2.all) /=
      "Wrong department for Employee: Nelson" then
      Report.Failed ("Wrong image (2): " &
                     C3A1004E.Child.Image (Dept3, E2.all));
   end if;

   Report.Result;
end C3A10042;