1-- C460013.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 GOVERNMENT 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 if the target subtype excludes null, the value is not 28-- null. Check access parameters, which null-excluding if: 29-- (1) not null is given in their definition; 30-- (2) the access parameter is controlling; 31-- (3) an Ada 95 compiler is in use. 32-- 33-- Note that the not null syntax is required even for Ada 95 compilers 34-- (see AI95-00447). 35-- 36-- CHANGE HISTORY: 37-- 18 DEC 2006 RLB Initial version. 38-- 05 JAN 2007 RLB Corrected syntax error. 39-- 40--! 41with Ada.Exceptions; 42use Ada.Exceptions; 43with Report; 44use Report; 45procedure C460013 is 46 47 48 package Nest1 is 49 type Doggie is tagged record 50 Cnt : Natural; 51 end record; 52 type Doggie_Access is access all Doggie; 53 54 procedure Controlled (P : access Doggie); -- Always null-excluding. 55 end Nest1; 56 57 package Nest2 is 58 type Kitty is record 59 Cnt : Natural; 60 end record; 61 type Kitty_Access is access all Kitty; 62 63 procedure Include (P : access Kitty); -- Null-excluding only in Ada 95. 64 procedure Exclude (P : not null access Kitty); -- Always null-excluding. 65 end Nest2; 66 67 68 package body Nest1 is 69 procedure Controlled (P : access Doggie) is 70 begin 71 if P.Cnt /= Ident_Int(4) then 72 Failed ("Bad value in null-excluding controlling parameter"); 73 -- else OK 74 end if; 75 exception 76 when Constraint_Error => -- Dereference of null 77 Failed ("Null allowed in null-excluding controlling parameter"); 78 end Controlled; 79 end Nest1; 80 81 package body Nest2 is 82 procedure Include (P : access Kitty) is 83 begin 84 if P.Cnt /= Ident_Int(31) then 85 Failed ("Bad value in access parameter"); 86 -- else OK 87 end if; 88 exception 89 when Constraint_Error => -- Dereference of null 90 null; 91 --Comment ("Null allowed in access parameter - Ada 2005 semantics"); 92 end Include; 93 94 procedure Exclude (P : not null access Kitty) is 95 begin 96 if P.Cnt /= Ident_Int(80) then 97 Failed ("Bad value in explicit null-excluding parameter"); 98 -- else OK 99 end if; 100 exception 101 when Constraint_Error => -- Dereference of null 102 Failed ("Null allowed in explicit null-excluding parameter"); 103 end Exclude; 104 end Nest2; 105 106 Shep : aliased Nest1.Doggie := (Cnt => 4); 107 Frisky : aliased Nest2.Kitty := (Cnt => 80); 108 Snuggles : aliased Nest2.Kitty := (Cnt => 31); 109 110begin 111 Test ("C460013", 112 "Check that if the target subtype excludes null, the value is not" & 113 " null - access parameter cases"); 114 115 declare 116 Ptr : Nest1.Doggie_Access := Shep'Access; 117 begin 118 begin 119 Nest1.Controlled (Ptr); -- OK. 120 exception 121 when A: others => 122 Failed ("Unexpected exception " & Exception_Name (A) & 123 " raised (1A) - " & Exception_Message (A)); 124 end; 125 Ptr := null; 126 begin 127 Nest1.Controlled (Ptr); 128 Failed ("Null allowed for null-excluding controlling access parameter (1)"); 129 exception 130 when Constraint_Error => 131 null; 132 when B: others => 133 Failed ("Unexpected exception " & Exception_Name (B) & 134 " raised (1B) - " & Exception_Message (B)); 135 end; 136 end; 137 138 declare 139 Ptr : Nest2.Kitty_Access := Frisky'Access; 140 begin 141 begin 142 Nest2.Exclude (Ptr); -- OK. 143 exception 144 when C: others => 145 Failed ("Unexpected exception " & Exception_Name (C) & 146 " raised (2A) - " & Exception_Message (C)); 147 end; 148 Ptr := null; 149 begin 150 Nest2.Exclude (Ptr); 151 Failed ("Null allowed for null-excluding access parameter (2)"); 152 exception 153 when Constraint_Error => 154 null; 155 when D: others => 156 Failed ("Unexpected exception " & Exception_Name (D) & 157 " raised (2B) - " & Exception_Message (D)); 158 end; 159 end; 160 161 declare 162 Ptr : Nest2.Kitty_Access := Snuggles'Access; 163 begin 164 begin 165 Nest2.Include (Ptr); -- OK. 166 exception 167 when E: others => 168 Failed ("Unexpected exception " & Exception_Name (E) & 169 " raised (3A) - " & Exception_Message (E)); 170 end; 171 Ptr := null; 172 begin 173 Nest2.Include (Ptr); 174 Comment ("Null allowed for normal access parameter - " & 175 "Ada 2005 semantics"); 176 exception 177 when Constraint_Error => 178 Comment ("Null not allowed for normal access parameter - " & 179 "Ada 95 semantics"); 180 when F: others => 181 Failed ("Unexpected exception " & Exception_Name (F) & 182 " raised (3B) - " & Exception_Message (F)); 183 end; 184 end; 185 186 Result; 187end C460013; 188 189