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