1-- C41304B.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 L.R RAISES CONSTRAINT_ERROR WHEN: 27-- L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING 28-- DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES 29-- NOT EXIST. 30-- L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT, 31-- FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT 32-- DENOTED BY R DOES NOT EXIST. 33-- L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS 34-- VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE 35-- OBJECT'S CURRENT DISCRIMINANT VALUES. 36-- L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT 37-- DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R 38-- DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT 39-- VALUES. 40 41-- HISTORY: 42-- TBN 05/23/86 CREATED ORIGINAL TEST. 43-- JET 01/08/88 MODIFIED HEADER FORMAT AND ADDED CODE TO 44-- PREVENT OPTIMIZATION. 45 46WITH REPORT; USE REPORT; 47PROCEDURE C41304B IS 48 49 TYPE V (DISC : INTEGER := 0) IS 50 RECORD 51 CASE DISC IS 52 WHEN 1 => 53 X : INTEGER; 54 WHEN OTHERS => 55 Y : INTEGER; 56 END CASE; 57 END RECORD; 58 59 TYPE T IS ACCESS V; 60 61BEGIN 62 TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " & 63 "THE COMPONENT DENOTED BY R DOES NOT EXIST"); 64 65 DECLARE 66 67 VR : V := (DISC => 0, Y => 4); 68 J : INTEGER; 69 70 BEGIN 71 72 IF EQUAL (4, 4) THEN 73 VR := (DISC => 1, X => 3); 74 END IF; 75 76 J := VR.Y; 77 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT"); 78 79 -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. 80 81 IF EQUAL (J,3) THEN 82 FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); 83 END IF; 84 85 EXCEPTION 86 87 WHEN CONSTRAINT_ERROR => 88 NULL; 89 WHEN OTHERS => 90 FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT"); 91 92 END; 93 94 -------------------------------------------------- 95 96 DECLARE 97 98 J : INTEGER; 99 100 FUNCTION F RETURN V IS 101 BEGIN 102 IF EQUAL (4, 4) THEN 103 RETURN (DISC => 2, Y => 3); 104 END IF; 105 RETURN (DISC => 1, X => 4); 106 END F; 107 108 BEGIN 109 110 J := F.X; 111 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & 112 "DELIVERING A RECORD VALUE"); 113 114 -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. 115 116 IF EQUAL (J,3) THEN 117 FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); 118 END IF; 119 120 EXCEPTION 121 122 WHEN CONSTRAINT_ERROR => 123 NULL; 124 WHEN OTHERS => 125 FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & 126 "DELIVERING A RECORD VALUE"); 127 128 END; 129 130 -------------------------------------------------- 131 132 DECLARE 133 134 A : T := NEW V' (DISC => 0, Y => 4); 135 J : INTEGER; 136 137 BEGIN 138 139 IF EQUAL (4, 4) THEN 140 A := NEW V' (DISC => 1, X => 3); 141 END IF; 142 143 J := A.Y; 144 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT"); 145 146 -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. 147 148 IF EQUAL (J,3) THEN 149 FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); 150 END IF; 151 152 EXCEPTION 153 154 WHEN CONSTRAINT_ERROR => 155 NULL; 156 WHEN OTHERS => 157 FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT"); 158 159 END; 160 161 -------------------------------------------------- 162 163 DECLARE 164 165 J : INTEGER; 166 167 FUNCTION F RETURN T IS 168 BEGIN 169 IF EQUAL (4, 4) THEN 170 RETURN NEW V' (DISC => 2, Y => 3); 171 END IF; 172 RETURN NEW V' (DISC => 1, X => 4); 173 END F; 174 175 BEGIN 176 177 J := F.X; 178 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & 179 "DELIVERING AN ACCESS VALUE"); 180 181 -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. 182 183 IF EQUAL (J,3) THEN 184 FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); 185 END IF; 186 187 EXCEPTION 188 189 WHEN CONSTRAINT_ERROR => 190 NULL; 191 WHEN OTHERS => 192 FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & 193 "DELIVERING AN ACCESS VALUE"); 194 195 END; 196 197 RESULT; 198END C41304B; 199