diff gcc/testsuite/ada/acats/tests/ca/ca15003.a @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/ca/ca15003.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,161 @@
+-- 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;