1-- C37209B.ADA 2 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- 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-- OBJECTIVE: 26-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE SUBTYPE 27-- INDICATION IN A CONSTANT OBJECT DECLARATION SPECIFIES A 28-- CONSTRAINED SUBTYPE WITH DISCRIMINANTS AND THE INITIALIZATION 29-- VALUE DOES NOT BELONG TO THE SUBTYPE (I. E., THE DISCRIMINANT 30-- VALUE DOES NOT MATCH THOSE SPECIFIED BY THE CONSTRAINT). 31 32-- HISTORY: 33-- RJW 08/25/86 CREATED ORIGINAL TEST 34-- VCL 08/19/87 CHANGED THE RETURN TYPE OF FUNTION 'INIT' IN 35-- PACKAGE 'PRIV2' SO THAT 'INIT' IS UNCONSTRAINED, 36-- THUS NOT RAISING A CONSTRAINT ERROR ON RETURN FROM 37-- 'INIT'. 38 39WITH REPORT; USE REPORT; 40PROCEDURE C37209B IS 41 42BEGIN 43 TEST ( "C37209B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & 44 "THE SUBTYPE INDICATION IN A CONSTANT " & 45 "OBJECT DECLARATION SPECIFIES A CONSTRAINED " & 46 "SUBTYPE WITH DISCRIMINANTS AND THE " & 47 "INITIALIZATION VALUE DOES NOT BELONG TO " & 48 "THE SUBTYPE (I. E., THE DISCRIMINANT VALUE " & 49 "DOES NOT MATCH THOSE SPECIFIED BY THE " & 50 "CONSTRAINT)" ); 51 DECLARE 52 53 TYPE REC (D : INTEGER) IS 54 RECORD 55 NULL; 56 END RECORD; 57 58 SUBTYPE REC1 IS REC (IDENT_INT (5)); 59 BEGIN 60 DECLARE 61 R1 : CONSTANT REC1 := (D => IDENT_INT (10)); 62 I : INTEGER := IDENT_INT (R1.D); 63 BEGIN 64 FAILED ( "NO EXCEPTION RAISED FOR DECLARATION OF " & 65 "R1" ); 66 EXCEPTION 67 WHEN OTHERS => 68 FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" ); 69 END; 70 71 EXCEPTION 72 WHEN CONSTRAINT_ERROR => 73 NULL; 74 WHEN OTHERS => 75 FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " & 76 "R1" ); 77 END; 78 79 80 BEGIN 81 DECLARE 82 PACKAGE PRIV1 IS 83 TYPE REC (D : INTEGER) IS PRIVATE; 84 SUBTYPE REC2 IS REC (IDENT_INT (5)); 85 R2 : CONSTANT REC2; 86 87 PRIVATE 88 TYPE REC (D : INTEGER) IS 89 RECORD 90 NULL; 91 END RECORD; 92 93 R2 : CONSTANT REC2 := (D => IDENT_INT (10)); 94 END PRIV1; 95 96 USE PRIV1; 97 98 BEGIN 99 DECLARE 100 I : INTEGER := IDENT_INT (R2.D); 101 BEGIN 102 FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & 103 "OF R2" ); 104 END; 105 END; 106 107 EXCEPTION 108 WHEN CONSTRAINT_ERROR => 109 NULL; 110 WHEN OTHERS => 111 FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & 112 "OF R2" ); 113 END; 114 115 BEGIN 116 DECLARE 117 PACKAGE PRIV2 IS 118 TYPE REC (D : INTEGER) IS PRIVATE; 119 SUBTYPE REC3 IS REC (IDENT_INT (5)); 120 121 FUNCTION INIT (D : INTEGER) RETURN REC; 122 PRIVATE 123 TYPE REC (D : INTEGER) IS 124 RECORD 125 NULL; 126 END RECORD; 127 128 END PRIV2; 129 130 PACKAGE BODY PRIV2 IS 131 FUNCTION INIT (D : INTEGER) RETURN REC IS 132 BEGIN 133 RETURN (D => IDENT_INT (D)); 134 END INIT; 135 END PRIV2; 136 137 USE PRIV2; 138 139 BEGIN 140 DECLARE 141 R3 : CONSTANT REC3 := INIT (10); 142 I : INTEGER := IDENT_INT (R3.D); 143 BEGIN 144 FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & 145 "OF R3" ); 146 END; 147 END; 148 149 EXCEPTION 150 WHEN CONSTRAINT_ERROR => 151 NULL; 152 WHEN OTHERS => 153 FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & 154 "OF R3" ); 155 END; 156 157 BEGIN 158 DECLARE 159 PACKAGE LPRIV IS 160 TYPE REC (D : INTEGER) IS 161 LIMITED PRIVATE; 162 SUBTYPE REC4 IS REC (IDENT_INT (5)); 163 164 R4 : CONSTANT REC4; 165 166 PRIVATE 167 TYPE REC (D : INTEGER) IS 168 RECORD 169 NULL; 170 END RECORD; 171 172 R4 : CONSTANT REC4 := (D => IDENT_INT (10)); 173 END LPRIV; 174 175 USE LPRIV; 176 177 BEGIN 178 DECLARE 179 I : INTEGER := IDENT_INT (R4.D); 180 BEGIN 181 FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & 182 "OF R4" ); 183 END; 184 END; 185 EXCEPTION 186 WHEN CONSTRAINT_ERROR => 187 NULL; 188 WHEN OTHERS => 189 FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & 190 "OF R4" ); 191 END; 192 193 RESULT; 194END C37209B; 195