ca15003.a

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

-- CA15003.A
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, 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 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.
--*
--
-- OBJECTIVE
--     Check the requirements of 10.1.5(4) and the modified 10.1.5(5)
--     from Technical Corrigendum 1. (Originally discussed as AI95-00136.)
--     Specifically:
--     Check that program unit pragma for a generic package are accepted
--     when given at the beginning of the package specification.
--     Check that a program unit pragma can be given for a generic
--     instantiation by placing the pragma immediately after the instantation.
--
-- TEST DESCRIPTION
--     This test checks the cases that are *not* forbidden by the RM,
--     and makes sure such legal cases actually work.
--
-- CHANGE HISTORY:
--      29 JUN 1999   RAD   Initial Version
--      08 JUL 1999   RLB   Cleaned up and added to test suite.
--      27 AUG 1999   RLB   Repaired errors introduced by me.
--
--!

with System;
package CA15003A is
    pragma Pure;

    type Big_Int is range -System.Max_Int .. System.Max_Int;
    type Big_Positive is new Big_Int range 1..Big_Int'Last;
end CA15003A;

generic
    type Int is new Big_Int;
package CA15003A.Pure is
    pragma Pure;
    function F(X: access Int) return Int;
end CA15003A.Pure;

with CA15003A.Pure;
package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive);
    pragma Pure(CA15003A.Pure_Instance);

package body CA15003A.Pure is
    function F(X: access Int) return Int is
    begin
        X.all := X.all + 1;
        return X.all;
    end F;
end CA15003A.Pure;

generic
package CA15003A.Pure.Preelaborate is
    pragma Preelaborate;
    One: Int := 1;
    function F(X: access Int) return Int;
end CA15003A.Pure.Preelaborate;

package body CA15003A.Pure.Preelaborate is
    function F(X: access Int) return Int is
    begin
        X.all := X.all + One;
        return X.all;
    end F;
end CA15003A.Pure.Preelaborate;

with CA15003A.Pure_Instance;
with CA15003A.Pure.Preelaborate;
package CA15003A.Pure_Preelaborate_Instance is
    new CA15003A.Pure_Instance.Preelaborate;
        pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance);

package CA15003A.Empty_Pure is
    pragma Pure;
    pragma Elaborate_Body;
end CA15003A.Empty_Pure;

package body CA15003A.Empty_Pure is
end CA15003A.Empty_Pure;

package CA15003A.Empty_Preelaborate is
    pragma Preelaborate;
    pragma Elaborate_Body;
    One: Big_Int := 1;
end CA15003A.Empty_Preelaborate;

package body CA15003A.Empty_Preelaborate is
    function F(X: access Big_Int) return Big_Int is
    begin
        X.all := X.all + One;
        return X.all;
    end F;
end CA15003A.Empty_Preelaborate;

package CA15003A.Empty_Elaborate_Body is
    pragma Elaborate_Body;
    Three: aliased Big_Positive := 1;
    Two, Tres: Big_Positive'Base := 0;
end CA15003A.Empty_Elaborate_Body;

with Report; use Report; pragma Elaborate_All(Report);
with CA15003A.Pure_Instance;
with CA15003A.Pure_Preelaborate_Instance;
use CA15003A;
package body CA15003A.Empty_Elaborate_Body is
begin
    if Two /= Big_Positive'Base(Ident_Int(0)) then
	Failed ("Two should be zero now");
    end if;
    if Tres /= Big_Positive'Base(Ident_Int(0)) then
	Failed ("Tres should be zero now");
    end if;
    if Two /= Tres then
	Failed ("Tres should be zero now");
    end if;
    Two := Pure_Instance.F(Three'Access);
    Tres := Pure_Preelaborate_Instance.F(Three'Access);
    if Two /= Big_Positive(Ident_Int(2)) then
	Failed ("Two should be 2 now");
    end if;
    if Tres /= Big_Positive(Ident_Int(3)) then
	Failed ("Tres should be 3 now");
    end if;
end CA15003A.Empty_Elaborate_Body;

with Report; use Report;
with CA15003A.Empty_Pure;
with CA15003A.Empty_Preelaborate;
with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body;
use type CA15003A.Big_Positive'Base;
procedure CA15003 is
begin
    Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages");
    if Two /= 2 then
	Failed ("Two should be 2 now");
    end if;
    if Tres /= 3 then
	Failed ("Tres should be 3 now");
    end if;
    Result;
end CA15003;