1-- C380001.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that checks are made properly when a per-object expression contains 28-- an attribute whose prefix denotes the current instance of the type. 29-- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, 30-- RM95 3.8(18/1)). 31-- 32-- CHANGE HISTORY: 33-- 9 FEB 2001 PHL Initial version. 34-- 29 JUN 2002 RLB Readied for release. 35-- 36--! 37with Ada.Exceptions; 38use Ada.Exceptions; 39with Report; 40use Report; 41procedure C380001 is 42 43 type Negative is range Integer'First .. -1; 44 45 type R1 is 46 record 47 C : Negative := Negative (Ident_Int (R1'Size)); 48 end record; 49 50 51 type R2; 52 53 type R3 (D1 : access R2; D2 : Natural) is limited null record; 54 55 type R2 is limited 56 record 57 C : R3 (R2'Access, Ident_Int (-1)); 58 end record; 59 60begin 61 Test ("C380001", "Check that checks are made properly when a " & 62 "per-object expression contains an attribute whose " & 63 "prefix denotes the current instance of the type"); 64 begin 65 declare 66 X : R1; 67 begin 68 Failed 69 ("No exception raised when evaluating a per-object expression " & 70 "containing an attribute - 1"); 71 end; 72 exception 73 when Constraint_Error => 74 null; 75 when E: others => 76 Failed ("Exception " & Exception_Name (E) & 77 " raised - " & Exception_Information (E) & " - 1"); 78 end; 79 80 declare 81 type A is access R1; 82 X : A; 83 begin 84 X := new R1; 85 Failed ("No exception raised when evaluating a per-object expression " & 86 "containing an attribute - 2"); 87 exception 88 when Constraint_Error => 89 null; 90 when E: others => 91 Failed ("Exception " & Exception_Name (E) & 92 " raised - " & Exception_Information (E) & " - 2"); 93 end; 94 95 begin 96 declare 97 X : R2; 98 begin 99 Failed 100 ("No exception raised when elaborating a per-object constraint " & 101 "containing an attribute - 3"); 102 end; 103 exception 104 when Constraint_Error => 105 null; 106 when E: others => 107 Failed ("Exception " & Exception_Name (E) & 108 " raised - " & Exception_Information (E) & " - 3"); 109 end; 110 111 declare 112 type A is access R2; 113 X : A; 114 begin 115 X := new R2; 116 Failed 117 ("No exception raised when evaluating a per-object constraint " & 118 "containing an attribute - 4"); 119 exception 120 when Constraint_Error => 121 null; 122 when E: others => 123 Failed ("Exception " & Exception_Name (E) & 124 " raised - " & Exception_Information (E) & " - 4"); 125 end; 126 127 Result; 128end C380001; 129