1-- C58005H.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-- CHECK THAT CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE 26-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER. 27 28-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH 29-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES. 30 31-- SPS 3/10/83 32-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations. 33-- The objects must be used, and must be tied somehow to the 34-- calls to Failed. 35 36WITH REPORT; 37USE REPORT; 38PROCEDURE C58005H IS 39 40 PACKAGE PACK IS 41 TYPE PV (D : NATURAL) IS PRIVATE; 42 TYPE LP (D : NATURAL) IS LIMITED PRIVATE; 43 PRIVATE 44 TYPE PV (D : NATURAL) IS RECORD 45 NULL; 46 END RECORD; 47 TYPE LP (D : NATURAL) IS RECORD 48 NULL; 49 END RECORD; 50 END PACK; 51 52 USE PACK; 53 54 TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL; 55 TYPE REC (D : NATURAL) IS RECORD 56 NULL; 57 END RECORD; 58 59 TYPE ACC_REC IS ACCESS REC; 60 TYPE ACC_ARR IS ACCESS ARR; 61 TYPE ACC_PV IS ACCESS PV; 62 TYPE ACC_LP IS ACCESS LP; 63 64 SUBTYPE ACC_REC1 IS ACC_REC (D => 1); 65 SUBTYPE ACC_REC2 IS ACC_REC (D => 2); 66 67 SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10); 68 SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5); 69 70 SUBTYPE ACC_PV1 IS ACC_PV (D => 1); 71 SUBTYPE ACC_PV2 IS ACC_PV (D => 2); 72 73 SUBTYPE ACC_LP1 IS ACC_LP (D => 1); 74 SUBTYPE ACC_LP2 IS ACC_LP (D => 2); 75 76 VAR1 : ACC_REC1 := NEW REC(1); 77 VAR2 : ACC_REC2 := NEW REC(2); 78 VAA1 : ACC_ARR1 := NEW ARR(1 .. 10); 79 VAA2 : ACC_ARR2 := NEW ARR(2 .. 5); 80 VAP1 : ACC_PV1 := NEW PV(1); 81 VAP2 : ACC_PV2 := NEW PV(2); 82 VAL1 : ACC_LP1 := NEW LP(1); 83 VAL2 : ACC_LP2 := NEW LP(2); 84 85 FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS 86 BEGIN 87 RETURN X; 88 END FREC; 89 90 FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS 91 BEGIN 92 RETURN X; 93 END FARR; 94 95 FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS 96 BEGIN 97 RETURN X; 98 END FPV; 99 100 FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS 101 BEGIN 102 RETURN X; 103 END FLP; 104 105 PACKAGE BODY PACK IS 106 FUNCTION LF (X : LP) RETURN INTEGER IS 107 BEGIN 108 RETURN IDENT_INT(3); 109 END LF; 110 BEGIN 111 NULL; 112 END PACK; 113 114BEGIN 115 116 TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " & 117 "OF FUNCTIONS"); 118 119 BEGIN 120 VAR2 := FREC (VAR1); 121 IF VAR2.D /= REPORT.IDENT_INT(2) THEN 122 FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1"); 123 ELSE 124 FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2"); 125 END IF; 126 EXCEPTION 127 WHEN CONSTRAINT_ERROR => NULL; 128 WHEN OTHERS => 129 FAILED ("WRONG EXCEPTION RAISED - REC"); 130 END; 131 132 BEGIN 133 VAA2 := FARR (VAA1); 134 IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN 135 FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1"); 136 ELSE 137 FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2"); 138 END IF; 139 EXCEPTION 140 WHEN CONSTRAINT_ERROR => NULL; 141 WHEN OTHERS => 142 FAILED ("WRONG EXCEPTION RAISED - ARR"); 143 END; 144 145 BEGIN 146 VAP2 := FPV (VAP1); 147 IF VAP2.D /= REPORT.IDENT_INT(2) THEN 148 FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1"); 149 ELSE 150 FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2"); 151 END IF; 152 EXCEPTION 153 WHEN CONSTRAINT_ERROR => NULL; 154 WHEN OTHERS => 155 FAILED ("WRONG EXCEPTION RAISED - PV"); 156 END; 157 158 BEGIN 159 VAL2 := FLP (VAL1); 160 IF VAL2.D /= REPORT.IDENT_INT(2) THEN 161 FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1"); 162 ELSE 163 FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2"); 164 END IF; 165 EXCEPTION 166 WHEN CONSTRAINT_ERROR => NULL; 167 WHEN OTHERS => 168 FAILED ("WRONG EXCEPTION RAISED - LP"); 169 END; 170 171 RESULT; 172END C58005H; 173