c731001.a

来自「linux下编程用 编译软件」· A 代码 · 共 408 行

-- C731001.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--     F08630-91-C-0015, 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 WHATSOVER, 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 inherited operations can be overridden, even when they are
--     inherited in a body.
--     The test cases here are inspired by the AARM examples given in
--     the discussion of AARM-7.3.1(7.a-7.v).
--     This discussion was confirmed by AI95-00035.
--
-- TEST DESCRIPTION
--     See AARM-7.3.1.
--
-- CHANGE HISTORY:
--      29 JUN 1999   RAD   Initial Version
--      23 SEP 1999   RLB   Improved comments, renamed, issued.
--      20 AUG 2001   RLB   Corrected 'verbose' flag.
--
--!

with Report; use Report; pragma Elaborate_All(Report);
package C731001_1 is
    pragma Elaborate_Body;
private
    procedure Check_String(X, Y: String);
    function Check_String(X, Y: String) return String;
        -- This one is a function, so we can call it in package specs.
end C731001_1;

package body C731001_1 is

    Verbose: Boolean := False;

    procedure Check_String(X, Y: String) is
    begin
        if Verbose then
            Comment("""" & X & """ = """ & Y & """?");
        end if;
        if X /= Y then
            Failed("""" & X & """ should be """ & Y & """");
        end if;
    end Check_String;

    function Check_String(X, Y: String) return String is
    begin
        Check_String(X, Y);
        return X;
    end Check_String;

end C731001_1;

private package C731001_1.Parent is

    procedure Call_Main;

    type Root is tagged null record;
    subtype Renames_Root is Root;
    subtype Root_Class is Renames_Root'Class;
    function Make return Root;
    function Op1(X: Root) return String;
    function Call_Op2(X: Root'Class) return String;
private
    function Op2(X: Root) return String;
end C731001_1.Parent;

procedure C731001_1.Parent.Main;

with C731001_1.Parent.Main;
package body C731001_1.Parent is

    procedure Call_Main is
    begin
        Main;
    end Call_Main;

    function Make return Root is
        Result: Root;
    begin
        return Result;
    end Make;

    function Op1(X: Root) return String is
    begin
        return "Parent.Op1 body";
    end Op1;

    function Op2(X: Root) return String is
    begin
        return "Parent.Op2 body";
    end Op2;

    function Call_Op2(X: Root'Class) return String is
    begin
        return Op2(X);
    end Call_Op2;

begin

    Check_String(Op1(Root'(Make)), "Parent.Op1 body");
    Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");

    Check_String(Op2(Root'(Make)), "Parent.Op2 body");
    Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");

end C731001_1.Parent;

with C731001_1.Parent; use C731001_1.Parent;
private package C731001_1.Unrelated is

    type T2 is new Root with null record;
    subtype T2_Class is T2'Class;
    function Make return T2;
    function Op2(X: T2) return String;
end C731001_1.Unrelated;

with C731001_1.Parent; use C731001_1.Parent;
    pragma Elaborate(C731001_1.Parent);
package body C731001_1.Unrelated is

    function Make return T2 is
        Result: T2;
    begin
        return Result;
    end Make;

    function Op2(X: T2) return String is
    begin
        return "Unrelated.Op2 body";
    end Op2;
begin

    Check_String(Op1(T2'(Make)), "Parent.Op1 body");
    Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
    Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");

    Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
    Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
    Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
    Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
    Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");

end C731001_1.Unrelated;

package C731001_1.Parent.Child is
    pragma Elaborate_Body;

    type T3 is new Root with null record;
    subtype T3_Class is T3'Class;
    function Make return T3;

    T3_Obj: T3;
    T3_Class_Obj: T3_Class := T3_Obj;
    T3_Root_Class_Obj: Root_Class := T3_Obj;

    X3: constant String :=
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");

    package Nested is
        type T4 is new Root with null record;
        subtype T4_Class is T4'Class;
        function Make return T4;

        T4_Obj: T4;
        T4_Class_Obj: T4_Class := T4_Obj;
        T4_Root_Class_Obj: Root_Class := T4_Obj;

        X4: constant String :=
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");

    private

        XX4: constant String :=
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");

    end Nested;

    use Nested;

    XXX4: constant String :=
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");

private

    XX3: constant String :=
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &

      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");

    XXXX4: constant String :=
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &

      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");

end C731001_1.Parent.Child;

with C731001_1.Unrelated; use C731001_1.Unrelated;
    pragma Elaborate(C731001_1.Unrelated);
package body C731001_1.Parent.Child is

    XXX3: constant String :=
      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &

      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");

    XXXXX4: constant String :=
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &

      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");

    function Make return T3 is
        Result: T3;
    begin
        return Result;
    end Make;

    package body Nested is
        function Make return T4 is
            Result: T4;
        begin
            return Result;
        end Make;

        XXXXXX4: constant String :=
          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &

          Check_String(Op2(T4_Obj), "Parent.Op2 body") &
          Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
          Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");

    end Nested;

    type T5 is new T2 with null record;
    subtype T5_Class is T5'Class;
    function Make return T5;

    function Make return T5 is
        Result: T5;
    begin
        return Result;
    end Make;

    XXXXXXX4: constant String :=
      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &

      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &

      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");

end C731001_1.Parent.Child;

procedure C731001_1.Main;

with C731001_1.Parent;
procedure C731001_1.Main is
begin
    C731001_1.Parent.Call_Main;
end C731001_1.Main;

with C731001_1.Parent.Child;
    use C731001_1.Parent;
    use C731001_1.Parent.Child;
    use C731001_1.Parent.Child.Nested;
with C731001_1.Unrelated; use C731001_1.Unrelated;
procedure C731001_1.Parent.Main is

    Root_Obj: Root := Make;
    Root_Class_Obj: Root_Class := Root'(Make);

    T2_Obj: T2 := Make;
    T2_Class_Obj: T2_Class := T2_Obj;
    T2_Root_Class_Obj: Root_Class := T2_Class_Obj;

    T3_Obj: T3 := Make;
    T3_Class_Obj: T3_Class := T3_Obj;
    T3_Root_Class_Obj: Root_Class := T3_Obj;

    T4_Obj: T4 := Make;
    T4_Class_Obj: T4_Class := T4_Obj;
    T4_Root_Class_Obj: Root_Class := T4_Obj;

begin
    Test("C731001_1", "Check that inherited operations can be overridden, even"
                    & " when they are inherited in a body");

    Check_String(Op1(Root_Obj), "Parent.Op1 body");
    Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");

    Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");

    Check_String(Op1(T2_Obj), "Parent.Op1 body");
    Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
    Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");

    Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
    Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
    Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");

    Check_String(Op1(T3_Obj), "Parent.Op1 body");
    Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
    Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");

    Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");

    Check_String(Op1(T4_Obj), "Parent.Op1 body");
    Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
    Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");

    Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
    Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");

    Result;
end C731001_1.Parent.Main;

with C731001_1.Main;
procedure C731001 is
begin
    C731001_1.Main;
end C731001;